diff --git a/Fixpoint.hs b/Fixpoint.hs new file mode 100644 --- /dev/null +++ b/Fixpoint.hs @@ -0,0 +1,37 @@ + +import Language.Fixpoint.Interface (solveFile) +import System.Environment (getArgs) +-- import System.Console.GetOpt +import Language.Fixpoint.Config hiding (config) +import Data.Maybe (fromMaybe, listToMaybe) +import System.Console.CmdArgs +import System.Console.CmdArgs.Verbosity (whenLoud) + + + +main = do cfg <- getOpts + whenLoud $ putStrLn $ "Options: " ++ show cfg + solveFile cfg + +config = Config { + inFile = def &= typ "TARGET" &= args &= typFile + , outFile = "out" &= help "Output file" + , solver = def &= help "Name of SMT Solver" + , genSorts = def &= help "Generalize qualifier sorts" +} &= verbosity + &= program "fixpoint" + &= help "Predicate Abstraction Based Horn-Clause Solver" + &= summary "fixpoint © Copyright 2009-13 Regents of the University of California." + &= details [ "Predicate Abstraction Based Horn-Clause Solver" + , "" + , "To check a file foo.fq type:" + , " fixpoint foo.fq" + ] + +getOpts :: IO Config +getOpts = do md <- cmdArgs config + putStrLn $ banner md + return md + +banner args = "Liquid-Fixpoint © Copyright 2009-13 Regents of the University of California.\n" + ++ "All Rights Reserved.\n" diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Ranjit Jhala + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ranjit Jhala nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,34 @@ +import Control.Monad +import Data.Maybe +import Distribution.PackageDescription +import Distribution.Simple +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Setup +import System.Posix.Env +import System.Process +import System.Exit + +main = defaultMainWithHooks fixHooks + where + fixHooks = simpleUserHooks { postInst = buildAndCopyFixpoint } + +buildAndCopyFixpoint _ _ pkg lbi + = do putStrLn $ "Post Install: " ++ show binDir + setEnv "Z3MEM" (show z3mem) True + executeShellCommand "./configure" + executeShellCommand "./build.sh" + executeShellCommand "chmod a+x external/fixpoint/fixpoint.native " + executeShellCommand $ "cp external/fixpoint/fixpoint.native " ++ binDir + when z3mem $ + executeShellCommand $ "cp external/z3/lib/libz3.* " ++ binDir + where + allDirs = absoluteInstallDirs pkg lbi NoCopyDest + binDir = bindir allDirs ++ "/" + flags = configConfigurationsFlags $ configFlags lbi + z3mem = fromJust $ lookup (FlagName "z3mem") flags + +executeShellCommand cmd = putStrLn ("EXEC: " ++ cmd) >> system cmd >>= check + where + check (ExitSuccess) = return () + check (ExitFailure n) = error $ "cmd: " ++ cmd ++ " failure code " ++ show n + diff --git a/configure b/configure new file mode 100644 --- /dev/null +++ b/configure @@ -0,0 +1,45 @@ +#!/bin/bash + +ROOTHOME=`pwd` +GHCBIN=`which ghc` +GHCHOME=`dirname $GHCBIN` +OCAMLLIB=`ocamlc -v | tail -1 | cut -d : -f 2 | tr -d " "` + +if [[ $Z3MEM = 'True' ]] +then + Z3HOME=$ROOTHOME/external/z3 +else + Z3HOME= +fi + +cat - > external/fixpoint/config.make < build.sh < Sy.SMap.add v e edefs, pdefs + | Ast.And [Ast.Imp ((Ast.Bexp (Ast.Var v1, _), _), p1), _; + Ast.Imp (p2, (Ast.Bexp (Ast.Var v2, _), _)), _] when v1 = v2 && p1 = p2 && not(P.is_tauto pred) -> + edefs, Sy.SMap.add v1 p1 pdefs + | Ast.And preds -> List.fold_left defs_of_pred (edefs, pdefs) preds + | _ -> edefs, pdefs + +let some_def_applied = ref false +let rec expr_apply_defs edefs pdefs ((e, _) as expr) = + let current_some_def_applied = !some_def_applied in + some_def_applied := false; + let expr'' = + match e with + | Ast.Con _ -> expr + | Ast.Var v -> + begin + try + let expr' = Sy.SMap.find v edefs in + some_def_applied := true; + expr' + with Not_found -> expr + end + | Ast.App (v, es) -> + let edefs' = Sy.SMap.remove v edefs in + Ast.eApp (v, List.map (expr_apply_defs edefs' pdefs) es) + | Ast.Bin (e1, op, e2) -> + Ast.eBin (expr_apply_defs edefs pdefs e1, op, expr_apply_defs edefs pdefs e2) + | Ast.Ite (p, e1, e2) -> + Ast.eIte (pred_apply_defs edefs pdefs p, + expr_apply_defs edefs pdefs e1, + expr_apply_defs edefs pdefs e2) + | Ast.Fld (v, e) -> + let v' = + try + match Sy.SMap.find v edefs with + | (Ast.Var v'', _) -> + some_def_applied := true; + v'' + | _ -> v + with Not_found -> v + in + Ast.eFld (v', expr_apply_defs edefs pdefs e) + | _ -> assertf "Simplification.expr_apply_defs TODO" + in + if !some_def_applied then + let expr''' = expr_apply_defs edefs pdefs expr'' in + some_def_applied := current_some_def_applied; + expr''' + else + begin + some_def_applied := current_some_def_applied; + expr'' + end + +and pred_apply_defs edefs pdefs ((p, _) as pred) = + let current_some_def_applied = !some_def_applied in + some_def_applied := false; + let pred'' = + match p with + | Ast.And ps -> List.map (pred_apply_defs edefs pdefs) ps |> Ast.pAnd + | Ast.Or ps -> List.map (pred_apply_defs edefs pdefs) ps |> Ast.pOr + | Ast.Not p -> pred_apply_defs edefs pdefs p |> Ast.pNot + | Ast.Imp (p, q) -> Ast.pImp (pred_apply_defs edefs pdefs p, pred_apply_defs edefs pdefs q) + | Ast.Bexp (Ast.Var v, _) -> + begin + try + let expr' = Sy.SMap.find v edefs in + some_def_applied := true; + Ast.pBexp expr' + with Not_found -> + try + let pred' = Sy.SMap.find v pdefs in + some_def_applied := true; + pred' + with Not_found -> + pred + end + | Ast.Atom (e1, brel, e2) -> + Ast.pAtom (expr_apply_defs edefs pdefs e1, brel, expr_apply_defs edefs pdefs e2) + | Ast.Forall (qs, p) -> + let vs = List.map fst qs in + let edefs' = List.fold_left (fun defs v -> Sy.SMap.remove v defs) edefs vs in + let pdefs' = List.fold_left (fun defs v -> Sy.SMap.remove v defs) pdefs vs in + Ast.pForall (qs, pred_apply_defs edefs' pdefs' p) + | _ -> pred + in + if !some_def_applied then + let pred''' = pred_apply_defs edefs pdefs pred'' in + some_def_applied := current_some_def_applied; + pred''' + else + begin + some_def_applied := current_some_def_applied; + pred'' + end + +let subs_apply_defs edefs pdefs subs = + List.map (fun (s, e) -> s, expr_apply_defs edefs pdefs e) subs + +let kvar_apply_defs edefs pdefs (subs, sym) = + subs_apply_defs edefs pdefs subs, sym + +let simplify_subs subs = + List.filter (fun (s, e) -> not(P.is_tauto (Ast.pAtom (Ast.eVar s, Ast.Eq, e)))) subs + +let simplify_kvar (subs, sym) = + simplify_subs subs, sym + +let simplify_t t = + let env_ps, pfree_env = (* separate concrete predicates from refinement templates *) + Sy.SMap.fold + (fun bv reft (ps, env) -> + let vv = C.vv_of_reft reft in + let bv_expr = Ast.eVar bv in + let sort = C.sort_of_reft reft in + let reft_ps, reft_ks = C.preds_kvars_of_reft reft in + (List.rev_append (List.map (fun p -> P.subst p vv bv_expr) reft_ps) ps, + if reft_ks = [] then env else Sy.SMap.add bv (vv, sort, reft_ks) env) + ) (C.env_of_t t) ([], Sy.SMap.empty) in + let lhs = C.lhs_of_t t in + let lhs_vv = C.vv_of_reft lhs in + let lhs_ps, lhs_ks = C.preds_kvars_of_reft lhs in + let body_pred = Ast.pAnd (C.grd_of_t t :: List.rev_append lhs_ps env_ps) in + let edefs, pdefs = defs_of_pred (Sy.SMap.empty, Sy.SMap.empty) body_pred in + (* + Printf.printf "\nbody_pred edefs map for %d\n" (C.id_of_t t); + Sy.SMap.iter (fun v exp -> + Printf.printf "%s -> %s\n" (Sy.to_string v) (E.to_string exp) + ) edefs; + Printf.printf "edef for lhs_vv %s = %s (simplified %s)\n" (Sy.to_string lhs_vv) + (try Sy.SMap.find lhs_vv edefs |> E.to_string with Not_found -> "none") + (try + Sy.SMap.find lhs_vv edefs + |> expr_apply_defs edefs pdefs + |> E.to_string with Not_found -> "none"); + *) + let kvar_to_simple_Kvar (subs, sym) = C.Kvar (subs |> Su.to_list |> subs_apply_defs edefs pdefs |> simplify_subs |> Su.of_list, sym) in + let senv = + Sy.SMap.mapi (fun bv (vv, sort, ks) -> + List.map kvar_to_simple_Kvar ks |> C.make_reft vv sort) pfree_env in +(* Printf.printf "body_pred: %s\n" (P.to_string body_pred); *) + let sgrd' = pred_apply_defs edefs pdefs body_pred |> Ast.simplify_pred in + let sgrd = + try + Ast.pAnd [sgrd'; Ast.pAtom (Ast.eVar lhs_vv, Ast.Eq, Sy.SMap.find lhs_vv edefs |> expr_apply_defs edefs pdefs)] + with Not_found -> sgrd' in +(* Printf.printf "simplified body_pred: %s\n" (P.to_string sgrd); *) + let slhs = List.map kvar_to_simple_Kvar lhs_ks |> C.make_reft (C.vv_of_reft lhs) (C.sort_of_reft lhs) in + let rhs = C.rhs_of_t t in + let rhs_ps, rhs_ks = C.preds_kvars_of_reft rhs in + let srhs_pred = pred_apply_defs edefs pdefs (Ast.pAnd rhs_ps) |> Ast.simplify_pred in + let srhs_ks = List.map kvar_to_simple_Kvar rhs_ks in + let srhs = (if P.is_tauto srhs_pred then srhs_ks else (C.Conc srhs_pred) :: srhs_ks) |> + C.make_reft (C.vv_of_reft rhs) (C.sort_of_reft rhs) in + C.make_t senv sgrd slhs srhs (Some (C.id_of_t t)) (C.tag_of_t t) + +let simplify_ts ts = + (* drop t if its rhs is a k variable that is not read *) + let ts_sofar = ref ts in + let pruned = ref true in + while !pruned && !ts_sofar <> [] do + let pruned_ts, rest_ts = + List.partition + (fun t -> + match C.rhs_of_t t |> C.preds_kvars_of_reft with + | [], [(_, sy)] -> + List.for_all + (fun t' -> + List.for_all (fun (_, sy') -> sy <> sy') + (Sy.SMap.fold + (fun _ reft sofar -> List.rev_append (C.kvars_of_reft reft) sofar) + (C.env_of_t t') (C.lhs_of_t t' |> C.kvars_of_reft)) + ) !ts_sofar + | _ -> false + ) !ts_sofar in + ts_sofar := rest_ts; + pruned := pruned_ts <> [] + done; + !ts_sofar + +let is_tauto_t t = + match C.rhs_of_t t |> C.ras_of_reft with + | [] -> true + | [C.Conc p] -> P.is_tauto p + | _ -> false + + diff --git a/external/fixpoint/Simplification.mli b/external/fixpoint/Simplification.mli new file mode 100644 --- /dev/null +++ b/external/fixpoint/Simplification.mli @@ -0,0 +1,5 @@ + +val simplify_t : FixConstraint.t -> FixConstraint.t +val simplify_ts : FixConstraint.t list -> FixConstraint.t list +val is_tauto_t : FixConstraint.t -> bool + diff --git a/external/fixpoint/ast.ml b/external/fixpoint/ast.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/ast.ml @@ -0,0 +1,1652 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +(** + * This module implements a DAG representation for expressions and + * predicates: each sub-predicate or sub-expression is paired with + * a unique int ID, which enables constant time hashing. + * However, one must take care when using DAGS: + * (1) they can only be constructed using the appropriate functions + * (2) when destructed via pattern-matching, one must discard the ID + *) + +(* random touch *) + +module F = Format +module Misc = FixMisc +open Misc.Ops +module SM = Misc.StringMap + +let mydebug = false + +module Cone = struct + type 'a t = Empty | Cone of ('a * 'a t) list + + let rec map f = function + | Empty -> Empty + | Cone xcs -> Cone (List.map (f <**> map f) xcs) +end + +module Sort = + struct + type loc = + | Loc of string + | Lvar of int + | LFun + + type tycon = string + + type t = + | Int + | Bool + | Obj + | Var of int (* type-var *) + | Ptr of loc (* c-pointer *) + | Func of int * t list (* type-var-arity, in-types @ [out-type] *) + | Num (* kind, for numeric tyvars -- ptr(loc(s)) -- *) + | App of tycon * t list (* type constructors *) + + type sub = { locs: (int * string) list; + vars: (int * t) list; } + + + let tycon_string x = x + (* + let is_loc_string s = + let re = Str.regexp "[a-zA-Z]+[0-9]+" in + Str.string_match re s 0 + + let loc_of_string = fun s -> let _ = asserts (is_loc_string s) in Loc s + let loc_of_index = fun i -> Lvar i + *) + + let t_num = Num + let t_obj = Obj + let t_bool = Bool + let t_int = Int + let t_generic = fun i -> let _ = asserts (0 <= i) "t_generic: %d" i in Var i + let t_ptr = fun l -> Ptr l + let t_func = fun i ts -> Func (i, ts) + let tycon s = s + + (* let tycon_re = Str.regexp "[A-Z][0-9 a-z A-Z '.']" + * function | s when Str.string_match tycon_re s 0 -> s + | s -> assertf "Error: Invalid tycon: %s" s + *) + + let t_app c ts = App (c, ts) + + let loc_to_string = function + | Loc s -> s + | Lvar i -> string_of_int i + | LFun -> "" + + let rec to_string = function + | Var i -> Printf.sprintf "@(%d)" i + | Int -> "int" + | Bool -> "bool" + | Obj -> "obj" + | Num -> "num" + | Ptr l -> loc_to_string l + (* Printf.sprintf "ptr(%s)" (loc_to_string l) *) + | Func (n, ts) -> ts |> List.map to_string + |> String.concat " ; " + |> Printf.sprintf "func(%d, [%s])" n + | App (c, ts) -> ts |> List.map to_string_arg + |> String.concat " " + |> Printf.sprintf "%s %s" c + + and to_string_arg t = match t with + | App (_, _) -> Printf.sprintf "(%s)" (to_string t) + | _ -> to_string t + + let to_string_short = function + | Func _ -> "func" + (* | Ptr _ -> "ptr" *) + | t -> to_string t + + let print fmt t = + t |> to_string + |> Format.fprintf fmt "%s" + + let sub_to_string {locs = ls; vars = vs} = + let lts = fun (i, s) -> Printf.sprintf "(%d := %s)" i s in + let vts = fun (i, t) -> Printf.sprintf "(%d := %s)" i (to_string t) in + Printf.sprintf "locs := %s, vars := %s \n" + (String.concat "" (List.map lts ls)) + (String.concat "" (List.map vts vs)) + + let rec map f = function + | Func (n, ts) -> Func (n, List.map (map f) ts) + | App (c, ts) -> App (c, List.map (map f) ts) + | t -> f t + + let rec fold f b = function + | Func (n, ts) as t -> List.fold_left (fold f) (f b t) ts + | t -> f b t + + let subs_tvar ts = + map begin function + | Var i -> Misc.do_catchf "ERROR: subs_tvar" (List.nth ts) i + | t -> t + end + + let is_bool = function + | Bool -> true + | _ -> false + + let is_int = function + | Int -> true + | _ -> false + + let is_func = function + | Func _ -> true + | _ -> false + + let app_of_t = function + | App (c, ts) -> Some (c, ts) + | _ -> None + + + let func_of_t = function + | Func (i, ts) -> let (xts, t) = ts |> Misc.list_snoc |> Misc.swap in + Some (i, xts, t) + | _ -> None + + let ptr_of_t = function + | Ptr l -> Some l + | _ -> None + + (* Sleazy Hack for C pointers. Make this go away... *) + + let compat t1 t2 = match t1, t2 with + | Int, (Ptr _) -> true + | (Ptr _), Int -> true + | _ -> t1 = t2 + + (* {{{ + let concretize ts = function + | Func (n, ats) when n = List.length ts -> + Func (n, List.map (subs_tvar ts) ats) + | _ -> + assertf "ERROR: bad application" + + let is_monotype t = + fold (fun b t -> b && (match t with Var _ -> false | _ -> true)) true t + }}} *) + + + let lookup_var = fun s i -> try Some (List.assoc i s.vars) with Not_found -> None + let lookup_loc = fun s j -> try Some (List.assoc j s.locs) with Not_found -> None + + let rec unifyt s = function + | Num,_ | _, Num -> None + | ct, (Var i) + | (Var i), ct + (* when ct != Bool *) -> + begin match lookup_var s i with + | Some ct' when ct = ct' -> Some s + | Some _ -> None + | None -> Some {s with vars = (i,ct) :: s.vars} + end + + | Ptr LFun, Ptr _ + | Ptr _, Ptr LFun -> Some s + | Ptr (Loc cl), Ptr (Lvar j) + | Ptr (Lvar j), Ptr (Loc cl) -> + begin match lookup_loc s j with + | Some cl' when cl' = cl -> Some s + | Some _ -> None + | None -> Some {s with locs = (j,cl) :: s.locs} + end + + | App (c1, t1s), App (c2, t2s) + when c1 = c2 && List.length t1s = List.length t2s -> + Misc.maybe_fold unifyt s (List.combine t1s t2s) + + | (t1, t2) when t1 = t2 -> + Some s + | _ -> None + + let empty_sub = {vars = []; locs = []} + + let unifyWith s ats cts = + let _ = asserts (List.length ats = List.length cts) "ERROR: unify sorts" in + List.combine ats cts + |> Misc.maybe_fold unifyt s + (* >> (fun so -> Printf.printf "unify: [%s] ~ [%s] = %s \n" + (String.concat "; " (List.map to_string ats)) + (String.concat "; " (List.map to_string cts)) + (match so with None -> "NONE" | Some s -> sub_to_string s)) + *) + + let unify = unifyWith empty_sub + + let apply s = + map begin fun t -> match t with + | Var i -> (match lookup_var s i with Some t' -> t' | _ -> t) + | Ptr (Lvar j) -> (match lookup_loc s j with Some l -> Ptr (Loc l) | _ -> t) + | _ -> t + end + + let rec fold f acc t = match t with + | Var _ | Int | Bool | Obj | Num | Ptr _ + -> f acc t + | Func (_, ts) | App (_, ts) + -> List.fold_left (fold f) (f acc t) ts + + let vars_of_t = fold begin fun acc -> function + | Var i -> i :: acc + | _ -> acc + end [] + + let locs_of_t = fold begin fun acc -> function + | Ptr (Loc l) -> l :: acc + | _ -> acc + end [] + + let subst_locs_vars lim = map begin function + | Ptr (Loc l) when SM.mem l lim -> Var (SM.find l lim) + | t -> t + end + + (* API *) + let generalize ts = + let locs = ts |> Misc.flap locs_of_t |> Misc.sort_and_compact in + let idx = ts |> Misc.flap vars_of_t |> Misc.list_max (-1) |> (+) 1 in + let lim = Misc.index_from idx locs |>: Misc.swap |> SM.of_list in + List.map (subst_locs_vars lim) ts + + (* API *) + let sub_args s = List.sort compare s.vars + + (* API *) + let check_arity n s = s.vars |>: fst |> Misc.sort_and_compact |> List.length |> (=) n + (* if ... then s else assertf "Type Inst. With Wrong Arity!" *) + + end + +module Symbol = + struct + type t = string + + let mk_wild = + let t,_ = Misc.mk_int_factory () in + t <+> string_of_int <+> (^) "~A" + + let is_wild_fresh s = s = "_" + let is_wild_any s = s.[0] = '~' + let is_wild_pre s = s.[0] = '@' + let is_wild s = is_wild_fresh s || is_wild_any s || is_wild_pre s + + let is_safe s = + let re = Str.regexp "[A-Za-z '~' '_' '\'' '@' ][0-9 a-z A-Z '_' '@' '\'' '.' '#']*$" in + Str.string_match re s 0 + + let of_string, to_string = + let of_t = Hashtbl.create 117 in + let to_t = Hashtbl.create 117 in + let bind = fun s sy -> Hashtbl.replace of_t s sy; Hashtbl.replace to_t sy s in + let f,_ = Misc.mk_string_factory "FIXPOINTSYMBOL_" in + ((fun s -> + if is_wild_fresh s then mk_wild () else + if is_safe s then s else + try Hashtbl.find of_t s with Not_found -> + let sy = f () in + let _ = bind s sy in sy), + (fun sy -> try Hashtbl.find to_t sy with Not_found -> sy)) + + let to_string = fun s -> s (* if is_safe s then s else "'" ^ s ^ "'" *) + + let suffix = fun s suff -> of_string ((to_string s) ^ suff) + + let print fmt s = + to_string s |> Format.fprintf fmt "%s" + + let vvprefix = "VV_" + let vvsuffix = function + | Sort.Ptr l -> Sort.loc_to_string l + | t -> Sort.to_string_short t + + + + let is_value_variable = Misc.is_prefix vvprefix + let value_variable t = vvprefix ^ (vvsuffix t) + + (* DEBUG *) + let vvprefix = "VV" + let is_value_variable = (=) vvprefix + let value_variable _ = vvprefix + + module SMap = Misc.EMap (struct type t = string + let compare i1 i2 = compare i1 i2 + let print = print end) + + module SSet = Misc.ESet (struct type t = string + let compare i1 i2 = compare i1 i2 end) + + (* let sm_length m = + SMap.fold (fun _ _ i -> i+1) m 0 + + let sm_filter f sm = + SMap.fold begin fun x y sm -> + if f x y then SMap.add x y sm else sm + end sm SMap.empty + + let sm_to_list sm = + SMap.fold (fun x y acc -> (x,y)::acc) sm [] + + let sm_of_list xs = + List.fold_left (fun sm (k,v) -> SMap.add k v sm) SMap.empty xs + *) + + end + +module Constant = + struct + type t = Int of int + + let to_string = function + | Int i -> string_of_int i + + let print fmt s = + to_string s |> Format.fprintf fmt "%s" + end + + +type tag = int + +type brel = Eq | Ne | Gt | Ge | Lt | Le + +type bop = Plus | Minus | Times | Div | Mod (* NOTE: For "Mod" 2nd expr should be a constant or a var *) + +type expr = expr_int * tag + +and expr_int = + | Con of Constant.t + | Var of Symbol.t + | App of Symbol.t * expr list + | Bin of expr * bop * expr + | Ite of pred * expr * expr + | Fld of Symbol.t * expr (* NOTE: Fld (s, e) == App ("field"^s,[e]) *) + | Cst of expr * Sort.t + | Bot + | MExp of expr list + | MBin of expr * bop list * expr + +and pred = pred_int * tag + +and pred_int = + | True + | False + | And of pred list + | Or of pred list + | Not of pred + | Imp of pred * pred + | Iff of pred * pred + | Bexp of expr + | Atom of expr * brel * expr + | MAtom of expr * brel list * expr + | Forall of ((Symbol.t * Sort.t) list) * pred + +let list_hash b xs = + List.fold_left (fun v (_,id) -> 2*v + id) b xs + +module Hashcons (X : sig type t + val sub_equal : t -> t -> bool + val hash : t -> int end) = struct + + module HashStruct = struct + type t = X.t * int + let equal (x,_) (y,_) = X.sub_equal x y + let hash (x,_) = X.hash x + end + + module Hash = Weak.Make(HashStruct) + + let wrap = + let tab = Hash.create 251 in + let ctr = ref 0 in + fun e -> + let res = Hash.merge tab (e, !ctr) in + let _ = if snd res = !ctr then incr ctr in + res + + let unwrap (e,_) = e + +end + +module ExprHashconsStruct = struct + type t = expr_int + let sub_equal e1 e2 = + match e1, e2 with + | Con c1, Con c2 -> + c1 = c2 + | MExp es1, MExp es2 -> + es1 = es2 + | Var x1, Var x2 -> + x1 = x2 + | App (s1, e1s), App (s2, e2s) -> + (s1 = s2) && + (try List.for_all2 (==) e1s e2s with _ -> false) + | Bin (e1, op1, e1'), Bin (e2, op2, e2') -> + op1 = op2 && e1 == e2 && e1' == e2' + | MBin (e1, ops1, e1'), MBin (e2, ops2, e2') -> + ops1 = ops2 && e1 == e2 && e1' == e2' + | Ite (ip1,te1,ee1), Ite (ip2,te2,ee2) -> + ip1 == ip2 && te1 == te2 && ee1 == ee2 + | Fld (s1, e1), Fld (s2, e2) -> + s1 = s2 && e1 == e2 + | Cst (e1, s1), Cst (e2, s2) -> + s1 = s2 && e1 == e2 + | _ -> + false + + let hash = function + | Con (Constant.Int x) -> + x + | MExp es -> + list_hash 6 es + | Var x -> + Hashtbl.hash x + | App (s, es) -> + list_hash ((Hashtbl.hash s) + 1) es + | Bin ((_,id1), op, (_,id2)) -> + (Hashtbl.hash op) + 1 + (2 * id1) + id2 + | MBin ((_,id1), op::_ , (_,id2)) -> + (Hashtbl.hash op) + 1 + (2 * id1) + id2 + | Ite ((_,id1), (_,id2), (_,id3)) -> + 32 + (4 * id1) + (2 * id2) + id3 + | Fld (s, (_,id)) -> + (Hashtbl.hash s) + 12 + id + | Cst ((_, id), t) -> + id + Hashtbl.hash (Sort.to_string t) + | Bot -> + 0 + | _ -> assertf "pattern error in A.pred hash" + +end + +module ExprHashcons = Hashcons(ExprHashconsStruct) + +module PredHashconsStruct = struct + + type t = pred_int + + let sub_equal p1 p2 = + match p1, p2 with + | True, True | False, False -> + true + | And p1s, And p2s | Or p1s, Or p2s -> + (try List.for_all2 (==) p1s p2s with _ -> false) + | Not p1, Not p2 -> + p1 == p2 + | Imp (p1, p1'), Imp (p2, p2') -> + p1 == p2 && p1' == p2' + | Iff (p1,p1'), Iff (p2,p2') -> + p1 == p2 && p1' == p2' + | Bexp e1, Bexp e2 -> + e1 == e2 + | Atom (e1, r1, e1'), Atom (e2, r2, e2') -> + r1 = r2 && e1 == e2 && e1' == e2' + | MAtom (e1, r1, e1'), MAtom (e2, r2, e2') -> + r1 = r2 && e1 == e2 && e1' == e2' + | Forall(q1s,p1), Forall(q2s,p2) -> + q1s = q2s && p1 == p2 + | _ -> + false + + let hash = function + | True -> + 0 + | False -> + 1 + | And ps -> + list_hash 2 ps + | Or ps -> + list_hash 3 ps + | Not (_,id) -> + 8 + id + | Imp ((_,id1), (_,id2)) -> + 20 + (2 * id1) + id2 + | Iff ((_,id1), (_,id2)) -> + 28 + (2 * id1) + id2 + | Bexp (_, id) -> + 32 + id + | Atom ((_,id1), r, (_,id2)) -> + 36 + (Hashtbl.hash r) + (2 * id1) + id2 + | MAtom ((_,id1), r, (_,id2)) -> + 42 + (Hashtbl.hash r) + (2 * id1) + id2 + | Forall(qs,(_,id)) -> + 50 + (2 * (Hashtbl.hash qs)) + id +end + +module PredHashcons = Hashcons(PredHashconsStruct) + +let ewr = ExprHashcons.wrap +let euw = ExprHashcons.unwrap +let pwr = PredHashcons.wrap +let puw = PredHashcons.unwrap + +(* Constructors: Expressions *) +let eCon = fun c -> ewr (Con c) +let eMExp = fun es -> ewr (MExp es) +let eInt = fun i -> eCon (Constant.Int i) +let zero = eInt 0 +let one = eInt 1 +let bot = ewr Bot +let eMod = fun (e, m) -> ewr (Bin (e, Mod, eInt m)) +let eModExp = fun (e, m) -> ewr (Bin (e, Mod, m)) +let eVar = fun s -> ewr (Var s) +let eApp = fun (s, es) -> ewr (App (s, es)) +let eBin = fun (e1, op, e2) -> ewr (Bin (e1, op, e2)) + +let eMBin = fun (e1, ops, e2) -> ewr (MBin (e1, ops, e2)) +let eIte = fun (ip,te,ee) -> ewr (Ite(ip,te,ee)) +let eFld = fun (s,e) -> ewr (Fld (s,e)) +let eCst = fun (e,t) -> ewr (Cst (e, t)) + +let eTim = function + | (Con (Constant.Int n1), _), (Con (Constant.Int n2), _) -> + ewr (Con (Constant.Int (n1 * n2))) + | (Con (Constant.Int 1), _), e2 -> + e2 + | (Con (Constant.Int (-1)), _), e2 -> + eBin (zero, Minus, e2) + | (e1, e2) -> eBin (e1, Times, e2) + + +let rec conjuncts = function + | And ps, _ -> Misc.flap conjuncts ps + | True, _ -> [] + | p -> [p] + + +(* Constructors: Predicates *) +let pTrue = pwr True +let pFalse = pwr False +let pAtom = fun (e1, r, e2) -> pwr (Atom (e1, r, e2)) +let pMAtom = fun (e1, r, e2) -> pwr (MAtom (e1, r, e2)) +let pOr = fun ps -> pwr (Or ps) +let pNot = fun p -> pwr (Not p) +let pBexp = fun e -> pwr (Bexp e) +let pImp = fun (p1,p2) -> pwr (Imp (p1,p2)) +let pIff = fun (p1,p2) -> pwr (Iff (p1,p2)) +let pForall= fun (qs, p) -> pwr (Forall (qs, p)) +let pEqual = fun (e1,e2) -> pAtom (e1, Eq, e2) + + +let pAnd = fun ps -> match Misc.flap conjuncts ps with + | [] -> pTrue + | [p] -> p + | ps -> pwr (And (Misc.flap conjuncts ps)) + + + +module ExprHash = Hashtbl.Make(struct + type t = expr + let equal (_,x) (_,y) = (x = y) + let hash (_,x) = x +end) + +module PredHash = Hashtbl.Make(struct + type t = pred + let equal (_,x) (_,y) = (x = y) + let hash (_,x) = x +end) + +let bop_to_string = function + | Plus -> "+" + | Minus -> "-" + | Times -> "*" + | Div -> "/" + | Mod -> "mod" + +let brel_to_string = function + | Eq -> "=" + | Ne -> "!=" + | Gt -> ">" + | Ge -> ">=" + | Lt -> "<" + | Le -> "<=" + +let print_brel ppf r = + F.fprintf ppf "%s" (brel_to_string r) + +let print_binding ppf (s,t) = + F.fprintf ppf "%a:%a" Symbol.print s Sort.print t + +let bind_to_string (s,t) = + Printf.sprintf "%s:%s" (Symbol.to_string s) (Sort.to_string t) + +let rec print_expr ppf e = match euw e with + | Con c -> + F.fprintf ppf "%a" Constant.print c + | MExp es -> + F.fprintf ppf "[%a]" (Misc.pprint_many false " ; " print_expr) es + | Var s -> + F.fprintf ppf "%a" Symbol.print s + | App (s, es) -> + F.fprintf ppf "%a([%a])" + Symbol.print s + (Misc.pprint_many false "; " print_expr) es + | Bin (e1, op, e2) -> + F.fprintf ppf "(%a %s %a)" + print_expr e1 + (bop_to_string op) + print_expr e2 + | MBin (e1, ops, e2) -> + F.fprintf ppf "(%a [%s] %a)" + print_expr e1 + (ops |>: bop_to_string |> String.concat " ; ") + print_expr e2 + + | Ite(ip,te,ee) -> + F.fprintf ppf "(%a ? %a : %a)" + print_pred ip + print_expr te + print_expr ee + | Fld(s, e) -> + F.fprintf ppf "%a.%s" print_expr e s + | Cst(e,t) -> + F.fprintf ppf "(%a : %a)" + print_expr e + Sort.print t + | Bot -> + F.fprintf ppf "_|_" + +and print_pred ppf p = match puw p with + | True -> + F.fprintf ppf "true" + | False -> + F.fprintf ppf "false" + | Bexp (App (s, es), _) -> + F.fprintf ppf "%a(%a)" Symbol.print s (Misc.pprint_many false ", " print_expr) es + | Bexp e -> + F.fprintf ppf "(Bexp %a)" print_expr e + | Not p -> + F.fprintf ppf "(~ (%a))" print_pred p + | Imp (p1, p2) -> + F.fprintf ppf "(%a => %a)" print_pred p1 print_pred p2 + | Iff (p1, p2) -> + F.fprintf ppf "(%a <=> %a)" print_pred p1 print_pred p2 + | And ps -> begin match ps with [] -> F.fprintf ppf "true" | _ -> + F.fprintf ppf "&& %a" (Misc.pprint_many_brackets true print_pred) ps + end + | Or ps -> begin match ps with [] -> F.fprintf ppf "false" | _ -> + F.fprintf ppf "|| %a" (Misc.pprint_many_brackets true print_pred) ps + end + + | Atom (e1, r, e2) -> + (* F.fprintf ppf "@[(%a %s %a)@]" *) + F.fprintf ppf "(%a %s %a)" + print_expr e1 + (brel_to_string r) + print_expr e2 + | MAtom (e1, rs, e2) -> + F.fprintf ppf "(%a [%a] %a)" + (* F.fprintf ppf "@[(%a [%a] %a)@]" *) + print_expr e1 + (Misc.pprint_many false " ; " print_brel) rs + print_expr e2 + | Forall (qs, p) -> + F.fprintf ppf "forall [%a] . %a" + (Misc.pprint_many false "; " print_binding) qs + print_pred p + +let rec expr_to_string e = + match euw e with + | Con c -> + Constant.to_string c + | MExp es -> + Printf.sprintf "[%s]" (es |>: expr_to_string |> String.concat " ; ") + | Var s -> + Symbol.to_string s + | App (s, es) -> + Printf.sprintf "%s([%s])" + (Symbol.to_string s) + (es |> List.map expr_to_string |> String.concat "; ") + | Bin (e1, op, e2) -> + Printf.sprintf "(%s %s %s)" + (expr_to_string e1) (bop_to_string op) (expr_to_string e2) + | MBin (e1, ops, e2) -> + Printf.sprintf "(%s [%s] %s)" + (expr_to_string e1) + (ops |> List.map bop_to_string |> String.concat "; ") + (expr_to_string e2) + | Ite(ip,te,ee) -> + Printf.sprintf "(%s ? %s : %s)" + (pred_to_string ip) (expr_to_string te) (expr_to_string ee) + | Fld(s,e) -> + Printf.sprintf "%s.%s" (expr_to_string e) s + | Cst(e,t) -> + Printf.sprintf "(%s : %s)" (expr_to_string e) (Sort.to_string t) + | Bot -> + Printf.sprintf "_|_" + + +and pred_to_string p = + match puw p with + | True -> + "true" + | False -> + "false" + | Bexp e -> + Printf.sprintf "(Bexp %s)" (expr_to_string e) + | Not p -> + Printf.sprintf "(~ (%s))" (pred_to_string p) + | Imp (p1, p2) -> + Printf.sprintf "(%s => %s)" (pred_to_string p1) (pred_to_string p2) + | Iff (p1, p2) -> + Printf.sprintf "(%s <=> %s)" (pred_to_string p1) (pred_to_string p2) + | And ps -> + Printf.sprintf "&& [%s]" (List.map pred_to_string ps |> String.concat " ; ") + | Or ps -> + Printf.sprintf "|| [%s]" (List.map pred_to_string ps |> String.concat ";") + | Atom (e1, r, e2) -> + Printf.sprintf "(%s %s %s)" + (expr_to_string e1) (brel_to_string r) (expr_to_string e2) + | MAtom (e1, rs, e2) -> + Printf.sprintf "(%s [%s] %s)" + (expr_to_string e1) + (List.map brel_to_string rs |> String.concat " ; ") + (expr_to_string e2) + | Forall (qs,p) -> + Printf.sprintf "forall [%s] . %s" + (List.map bind_to_string qs |> String.concat "; ") (pred_to_string p) + +let rec pred_map hp he fp fe p = + let rec pm p = + try PredHash.find hp p with Not_found -> begin + let p' = + match puw p with + | True | False as p1 -> + p1 + | And ps -> + And (List.map pm ps) + | Or ps -> + Or (List.map pm ps) + | Not p -> + Not (pm p) + | Imp (p1, p2) -> + Imp (pm p1, pm p2) + | Iff (p1, p2) -> + Iff (pm p1, pm p2) + | Bexp e -> + Bexp (expr_map hp he fp fe e) + | Atom (e1, r, e2) -> + Atom (expr_map hp he fp fe e1, r, expr_map hp he fp fe e2) + | MAtom (e1, rs, e2) -> + MAtom (expr_map hp he fp fe e1, rs, expr_map hp he fp fe e2) + | Forall (qs, p) -> + Forall (qs, pm p) in + let rv = fp (pwr p') in + let _ = PredHash.add hp p rv in + rv + end in pm p + +and expr_map hp he fp fe e = + let rec em e = + try ExprHash.find he e with Not_found -> begin + let e' = + match euw e with + | Con _ | Var _ | Bot as e1 -> + e1 + | MExp es -> + MExp (List.map em es) + | App (f, es) -> + App (f, List.map em es) + | Bin (e1, op, e2) -> + Bin (em e1, op, em e2) + | MBin (e1, ops, e2) -> + MBin (em e1, ops, em e2) + | Ite (ip, te, ee) -> + Ite (pred_map hp he fp fe ip, em te, em ee) + | Fld (s, e1) -> + Fld (s, em e1) + | Cst (e1, t) -> + Cst (em e1, t) + in + let rv = fe (ewr e') in + let _ = ExprHash.add he e rv in + rv + end in em e + +let rec pred_iter fp fe pw = + begin match puw pw with + | True | False -> () + | Bexp e -> expr_iter fp fe e + | Not p -> pred_iter fp fe p + | Imp (p1, p2) -> pred_iter fp fe p1; pred_iter fp fe p2 + | Iff (p1, p2) -> pred_iter fp fe p1; pred_iter fp fe p2 + | And ps | Or ps -> List.iter (pred_iter fp fe) ps + | Atom (e1, _, e2) -> expr_iter fp fe e1; expr_iter fp fe e2 + | MAtom (e1, _, e2) -> expr_iter fp fe e1; expr_iter fp fe e2 + | Forall (_, p) -> pred_iter fp fe p (* pmr: looks wrong, but so does pred_map *) + end; + fp pw + +and expr_iter fp fe ew = + begin match puw ew with + | Con _ | Var _ | Bot -> + () + | MExp es -> + List.iter (expr_iter fp fe) es + | App (_, es) -> + List.iter (expr_iter fp fe) es + | Bin (e1, _, e2) -> + expr_iter fp fe e1; expr_iter fp fe e2 + | MBin (e1, _, e2) -> + expr_iter fp fe e1; expr_iter fp fe e2 + | Ite (ip, te, ee) -> + pred_iter fp fe ip; expr_iter fp fe te; expr_iter fp fe ee + | Fld (_, e1) | Cst (e1, _) -> + expr_iter fp fe e1 + end; + fe ew + +let esub x e = function + | (Var y), _ when x = y -> e + | _ as e1 -> e1 + +let expr_subst hp he e x e' = + expr_map hp he id (esub x e') e + +let pred_subst hp he p x e' = + pred_map hp he id (esub x e') p + +module Expression = + struct + + module Hash = ExprHash + + let to_string = expr_to_string + + (* let print = fun fmt e -> Format.pp_print_string fmt (to_string e) + *) + let print = print_expr + + let show = print Format.std_formatter + + let map fp fe e = + let hp = PredHash.create 251 in + let he = ExprHash.create 251 in + expr_map hp he fp fe e + + let iter fp fe e = + expr_iter fp fe e + + let subst e x e' = + map id (esub x e') e + + let substs e xes = + map id (fun e -> List.fold_left (esub |> Misc.uncurry |> Misc.flip) e xes) e + + let support e = + let xs = ref Symbol.SSet.empty in + iter un begin function + | (Var x), _ + | (App (x,_)),_ -> xs := Symbol.SSet.add x !xs + | _ -> () + end e; + Symbol.SSet.elements !xs |> List.sort compare + + let unwrap = euw + + let has_bot p = + let r = ref false in + iter un begin function + | Bot, _ -> r := true + | _ -> () + end p; + !r + + end + +module Predicate = struct + module Hash = PredHash + + let to_string = pred_to_string + let print = print_pred + let show = print Format.std_formatter + + let map fp fe p = + let hp = PredHash.create 251 in + let he = ExprHash.create 251 in + pred_map hp he fp fe p + + let iter fp fe p = + pred_iter fp fe p + + let subst p x e' = + map id (esub x e') p + + let substs p xes = + map id (fun e -> List.fold_left (esub |> Misc.uncurry |> Misc.flip) e xes) p + + let support p = + let xs = ref Symbol.SSet.empty in + iter un begin function + | (Var x), _ + | (App (x,_)),_ -> xs := Symbol.SSet.add x !xs; + | _ -> () + end p; + Symbol.SSet.elements !xs |> List.sort compare + + (* + let size p = + let c = ref 0 in + let f = fun _ -> incr c in + let _ = iter f f p in + !c + + let size p = + let c = ref 0 in + let _ = iter (fun _ -> incr c) p in + !c + *) + + let unwrap = puw + + let is_contra = + let t = PredHash.create 17 in + let _ = [pFalse; pNot pTrue; pAtom (zero, Eq, one); pAtom (one, Eq, zero)] + |> List.iter (fun p-> PredHash.replace t p ()) in + fun p -> PredHash.mem t p + + + let rec is_tauto = function + | Atom(e1, Eq, e2), _ -> snd e1 == snd e2 + | Imp (p1, p2), _ -> snd p1 == snd p2 + | And ps, _ -> List.for_all is_tauto ps + | Or ps, _ -> List.exists is_tauto ps + | True, _ -> true + | _ -> false + + let has_bot p = + let r = ref false in + iter un begin function + | Bot, _ -> r := true + | _ -> () + end p; + !r + + end + +let print_stats _ = + Printf.printf "Ast Stats. [none] \n" + + +(********************************************************************************) +(************************** Rationalizing Division ******************************) +(********************************************************************************) + +let expr_isdiv = function + | Bin (_, Div, _), _ -> true + | _ -> false + +let pull_divisor = function + | Bin (_, Div, (Con (Constant.Int i),_)), _ -> i + | _ -> 1 + +let calc_cm e1 e2 = + pull_divisor e1 * pull_divisor e2 + +let rec apply_mult m = function + | Bin (e, Div, (Con (Constant.Int d),_)), _ -> + let _ = assert ((m/d) * d = m) in + eTim ((eCon (Constant.Int (m/d))), e) + | Bin (e1, op, e2), _ -> + eBin (apply_mult m e1, op, apply_mult m e2) + | Con (Constant.Int i), _ -> + eCon (Constant.Int (i*m)) + | e -> + eTim (eCon (Constant.Int m), e) + +let rec pred_isdiv = function + | True,_ | False,_ -> + false + | And ps,_ | Or ps,_ -> + List.exists pred_isdiv ps + | Not p, _ | Forall (_, p), _ -> + pred_isdiv p + | Imp (p1, p2), _ -> + pred_isdiv p1 || pred_isdiv p2 + | Iff (p1, p2), _ -> + pred_isdiv p1 || pred_isdiv p2 + | Bexp e, _ -> + expr_isdiv e + | Atom (e1, _, e2), _ -> + expr_isdiv e1 || expr_isdiv e2 + | _ -> failwith "Unexpected: pred_isdiv" + +let bound m e e1 e2 = + pAnd [pAtom (apply_mult m e, Gt, apply_mult m e2); + pAtom(apply_mult m e, Le, apply_mult m e1)] + +let rec fixdiv = function + | p when not (pred_isdiv p) -> + p + | Atom ((Var _,_) as e, Eq, e1), _ | Atom ((Con _, _) as e, Eq, e1), _ -> + bound (calc_cm e e1) e e1 (eBin (e1, Minus, one)) + | And ps, _ -> + pAnd (List.map fixdiv ps) + | Or ps, _ -> + pOr (List.map fixdiv ps) + | Imp (p1, p2), _ -> + pImp (fixdiv p1, fixdiv p2) + | Iff (p1, p2), _ -> + pIff (fixdiv p1, fixdiv p2) + | Not p, _ -> + pNot (fixdiv p) + | p -> p + +(***************************************************************************) +(************* Type Checking Expressions and Predicates ********************) +(***************************************************************************) + +let sortcheck_sym f s = f s + (* try Some (f s) with _ -> None *) + +let sortcheck_loc f = function + | Sort.Loc s -> sortcheck_sym f (Symbol.of_string s) + | Sort.Lvar _ -> None + | Sort.LFun -> None + +let rec sortcheck_expr g f e = + match euw e with + | Bot -> + None + | Con _ -> + Some Sort.Int + | Var s -> + sortcheck_sym f s + | Bin (e1, op, e2) -> + sortcheck_op g f (e1, op, e2) + | Ite (p, e1, e2) -> + if sortcheck_pred g f p then + match Misc.map_pair (sortcheck_expr g f) (e1, e2) with + | (Some t1, Some t2) when t1 = t2 -> Some t1 + | _ -> None + else None + + | Cst (e1, t) -> + begin match euw e1 with + | App (uf, es) -> sortcheck_app g f (Some t) uf es + | _ -> + match sortcheck_expr g f e1 with + | Some t1 when Sort.compat t t1 -> Some t + | _ -> None + end + + | App (uf, es) -> + sortcheck_app g f None uf es + + | _ -> assertf "Ast.sortcheck_expr: unhandled expr = %s" (Expression.to_string e) + +(* TODO: OMG! 5 levels of matching!!!!! *) +and sortcheck_app_sub g f so_expected uf es = + let yikes uf = F.printf "sortcheck_app_sub: unknown sym = %s \n" (Symbol.to_string uf) in + sortcheck_sym f uf + |> function None -> (yikes uf; None) | Some t -> + Sort.func_of_t t + |> function None -> None | Some (tyArity, i_ts, o_t) -> + let _ = asserts (List.length es = List.length i_ts) + "ERROR: uf arg-arity error: uf=%s" uf in + let e_ts = es |> List.map (sortcheck_expr g f) |> Misc.map_partial id in + if List.length e_ts <> List.length i_ts then + None + else + match Sort.unify e_ts i_ts with + | None -> None + | Some s -> + let t = Sort.apply s o_t in + match so_expected with + | None -> Some (s, t) + | Some t' -> + match Sort.unifyWith s [t] [t'] with + | None -> None + | Some s' -> Some (s', Sort.apply s' t) + +and sortcheck_app g f so_expected uf es = + sortcheck_app_sub g f so_expected uf es + |> Misc.maybe_map snd + (* >> begin function + | Some t -> Format.printf "sortcheck_app: e = %s , t = %s \n" + (expr_to_string (eApp (uf, es))) (Sort.to_string t) + | None -> Format.printf "sortcheck_app: e = %s FAILS\n" + (expr_to_string (eApp (uf, es))) + end + *) + + + +and sortcheck_op g f (e1, op, e2) = + match Misc.map_pair (sortcheck_expr g f) (e1, e2) with + | (Some Sort.Int, Some Sort.Int) + -> Some Sort.Int + + (* only allow when language is Haskell *) + | (Some (Sort.Ptr l), Some (Sort.Ptr l')) + when (l = l' && sortcheck_loc f l = Some Sort.Num) + -> Some (Sort.Ptr l) + + (* only allow when language is C *) + | (Some (Sort.Ptr s), Some Sort.Int) + | (Some Sort.Int, Some (Sort.Ptr s)) + -> Some (Sort.Ptr s) + + (* only allow when language is C *) + | (Some (Sort.Ptr s), Some (Sort.Ptr s')) + when op = Minus && s = s' + -> Some Sort.Int + + | _ -> None + + +and sortcheck_rel g f (e1, r, e2) = + let t1o, t2o = (e1,e2) |> Misc.map_pair (sortcheck_expr g f) in + match r, t1o, t2o with + | _, Some (Sort.Ptr _) , Some (Sort.Ptr Sort.LFun) + | _, Some (Sort.Ptr Sort.LFun), Some (Sort.Ptr _) + -> true + | _ , Some Sort.Int, Some (Sort.Ptr l) + | _ , Some (Sort.Ptr l), Some Sort.Int + -> (sortcheck_loc f l = Some Sort.Num) + | _ , Some (Sort.Ptr l1), Some (Sort.Ptr l2) when (sortcheck_loc f l1 = Some Sort.Num) && (sortcheck_loc f l2 = Some Sort.Num) + -> true + | Eq, Some t1, Some t2 + | Ne, Some t1, Some t2 + -> t1 = t2 + | _ , Some (Sort.App (tc,_)), _ + when (g tc) (* tc is an interpreted tycon *) + -> false + | _ , Some t1, Some t2 + -> t1 = t2 && t1 != Sort.Bool + | _ -> false + +and sortcheck_pred g f p = + match puw p with + | True + | False -> + true + | Bexp e -> + sortcheck_expr g f e = Some Sort.Bool + | Not p -> + sortcheck_pred g f p + | Imp (p1, p2) | Iff (p1, p2) -> + List.for_all (sortcheck_pred g f) [p1; p2] + | And ps + | Or ps -> + List.for_all (sortcheck_pred g f) ps + + | Atom ((Con (Constant.Int(0)),_), _, e) + | Atom (e, _, (Con (Constant.Int(0)),_)) + when not (!Constants.strictsortcheck) + -> not (None = sortcheck_expr g f e) + + | Atom ((Var x, _) , Eq, (App (uf, es), _)) + | Atom ((App (uf, es), _), Eq, (Var x, _)) + -> begin match sortcheck_sym f x with + | None -> false + | Some tx -> not (None = sortcheck_app g f (Some tx) uf es) + end + + | Atom (e1, r, e2) -> + sortcheck_rel g f (e1, r, e2) + | Forall (qs,p) -> + (* let f' = fun x -> try List.assoc x qs with _ -> f x in *) + let f' = fun x -> match Misc.list_assoc_maybe x qs with None -> f x | y -> y + in sortcheck_pred g f' p + | _ -> failwith "Unexpected: sortcheck_pred" + +(* and sortcheck_pred f p = + sortcheck_pred' f p + >> (fun b -> if not b then F.eprintf "WARNING: Malformed Lhs Pred (%a)\n" Predicate.print p) + *) + +let uf_arity f uf = + match sortcheck_sym f uf with None -> None | Some t -> + match Sort.func_of_t t with None -> None | Some (i,_,_) -> + Some i + +(* API *) +let sortcheck_app g f t uf es = + match uf_arity f uf, sortcheck_app_sub g f t uf es with + | (Some n , Some (s, t)) -> + if Sort.check_arity n s then Some (s, t) else + assertf "Ast.sortcheck_app: type args not fully instantiated %s" + (expr_to_string (eApp (uf, es))) + | _ -> None + +(* +let sortcheck_pred f p = + sortcheck_pred f p + >> (fun b -> ignore <| F.printf "sortcheck_pred: p = %a, res = %b\n" + Predicate.print p b) +*) + +(***************************************************************************) +(************* Simplifying Expressions and Predicates **********************) +(***************************************************************************) + +let pred_of_bool = function true -> pTrue | false -> pFalse + +let rec remove_bot pol ((p, _) as pred) = + match p with + | Not p -> + pNot (remove_bot (not pol) p) + | Imp (p, q) -> + pImp (remove_bot (not pol) p, remove_bot pol q) + | Forall (qs, p) -> + pForall (qs, remove_bot pol p) + | And ps -> + ps |> List.map (remove_bot pol) |> pAnd + | Or ps -> + ps |> List.map (remove_bot pol) |> pOr + | Bexp e when Expression.has_bot e -> + pred_of_bool pol + | Atom (e1, _, e2) when Expression.has_bot e1 || Expression.has_bot e2 -> + pred_of_bool pol + | _ -> + pred + +let remove_bot p = + if Predicate.has_bot p + then remove_bot true p + else p + +let symm_brel = function + | Eq -> Eq + | Ne -> Ne + | Gt -> Lt + | Ge -> Le + | Lt -> Gt + | Le -> Ge + + +let neg_brel = function + | Eq -> Ne + | Ne -> Eq + | Gt -> Le + | Ge -> Lt + | Lt -> Ge + | Le -> Gt + +let rec push_neg ?(neg=false) ((p, _) as pred) = + match p with + | True -> + if neg then pFalse else pred + | False -> + if neg then pTrue else pred + | Bexp _ -> + if neg then pNot pred else pred + | Not p -> + push_neg ~neg:(not neg) p + | Imp (p, q) -> + if neg then pAnd [push_neg p; push_neg ~neg:true q] + else pImp (push_neg p, push_neg q) + | Iff (p, q) -> + if neg then pIff (p, push_neg ~neg:true q) + else pIff (push_neg p, push_neg q) + | Forall (qs, p) -> + let pred' = pForall (qs, push_neg ~neg:false p) in + if neg then pNot pred' else pred' + | And ps -> + List.map (push_neg ~neg:neg) ps + |> if neg then pOr else pAnd + | Or ps -> + List.map (push_neg ~neg:neg) ps + |> if neg then pAnd else pOr + | Atom (e1, brel, e2) -> + if neg then pAtom (e1, neg_brel brel, e2) else pred + | _ -> failwith "Unexpected: push_neg" + +(* Andrey: TODO flatten nested conjunctions/disjunctions *) +let rec simplify_pred ((p, _) as pred) = + match p with + | Not p -> pNot (simplify_pred p) + | Imp (p, q) -> pImp (simplify_pred p, simplify_pred q) + | Forall (qs, p) -> pForall (qs, simplify_pred p) + | And ps -> ps |> List.map simplify_pred + |> List.filter (not <.> Predicate.is_tauto) + |> (function | [] -> pTrue + | [p] -> p + | _ when List.exists Predicate.is_contra ps -> pFalse + | _ -> pAnd ps) + | Or ps -> ps |> List.map simplify_pred + |> List.filter (not <.> Predicate.is_contra) + |> (function [] -> pFalse + | [p] -> p + | ps when List.exists Predicate.is_tauto ps -> pTrue + | ps -> pOr ps) + | _ -> pred + +(**************************************************************************) +(*************************** Substitutions ********************************) +(**************************************************************************) + +module Subst = struct + + type t = expr Symbol.SMap.t + + let valid xes = + xes |> List.split + |> Misc.app_snd (Misc.flap Expression.support) + |> Misc.uncurry Misc.disjoint + + + let extend s (x, e) = + let s = Symbol.SMap.map (esub x e) s in + if Symbol.SMap.mem x s then + s + else + match e with + | Var x', _ when x = x' -> s + | _ -> Symbol.SMap.add x e s + + let empty = Symbol.SMap.empty + let is_empty = Symbol.SMap.is_empty + let to_list = Symbol.SMap.to_list + let apply = Misc.flip Symbol.SMap.maybe_find + let of_list = fun xes -> List.fold_left extend empty xes + let simultaneous_of_list = Symbol.SMap.of_list + let compose s t = + let s' = Symbol.SMap.fold (fun x e s -> Symbol.SMap.map (esub x e) s) t s + in Symbol.SMap.fold (fun x e s -> if Symbol.SMap.mem x s + then s else Symbol.SMap.add x e s) + t s' + let print_sub = fun ppf (x,e) -> F.fprintf ppf "[%a:=%a]" Symbol.print x Expression.print e + let print = fun ppf -> to_list <+> F.fprintf ppf "%a" (Misc.pprint_many false "" print_sub) + +(* fun s1 s2 -> Symbol.SMap.fold (fun x e s -> extend s (x, e)) s2 s1 *) +(* let apply = Misc.flip Symbol.SMap.maybe_find *) + +end + + +(**************************************************************************) +(******************* Horn Clauses: Parsing ARMC files *********************) +(**************************************************************************) + +module Horn = struct + + type pr = string * string list + type gd = C of pred | K of pr + type t = pr * gd list + + let print_pr ppf (x, xs) = + Format.fprintf ppf "%s(%s)" x (String.concat "," xs) + + let print_gd ppf = function + | C p -> Predicate.print ppf p + | K x -> print_pr ppf x + + let print ppf (hd, gds) = + Format.fprintf ppf "%a :- %a." + print_pr hd + (Misc.pprint_many false "," print_gd) gds + + let support_pr = snd + let support_gd = function K pr -> support_pr pr | C p -> p |> Predicate.support |> List.map Symbol.to_string + let support = fun (hd, gds) -> (support_pr hd) ++ (Misc.flap support_gd gds) +end + +(* API *) +let simplify_pred = remove_bot <+> simplify_pred + + +let esub_su su e = match e with + | ((Var y), _) -> Misc.maybe_default (Subst.apply su y) e + | _ -> e + +(* ORIG + let substs_pred = fun p su -> su |> Subst.to_list |> Predicate.substs p |> simplify_pred +*) + +let substs_pred p su = Predicate.map id (esub_su su) p +let substs_expr e su = Expression.map id (esub_su su) e + +(****************************************************************************) +(******************** Unification of Predicates *****************************) +(****************************************************************************) + + +exception DoesNotUnify + +let rec pUnify (p1, p2) = + let res = + match p1, p2 with + | (Atom (e1, r1, e1'), _), (Atom (e2, r2, e2'), _) when r1 = r2 -> + let s1 = eUnify (e1, e2) in + let e1', e2' = Misc.map_pair ((Misc.flip Expression.substs) s1) (e1', e2') in + let s2 = eUnify (e1', e2') in + s1 ++ s2 + | (Bexp e1, _), (Bexp e2, _) -> + eUnify (e1, e2) + | (Not p1, _), (Not p2, _) -> + pUnify (p1, p2) + | (Imp (p1, p1'), _), (Imp (p2, p2'), _) -> + psUnify ([p1; p1'], [p2; p2']) + + | (And p1s, _), (And p2s, _) + | (Or p1s, _), (Or p2s, _) + when List.length p1s = List.length p2s -> + psUnify (p1s, p2s) + | _, _ -> raise DoesNotUnify + in + let _ = if mydebug then + (Format.printf "pUnify: p1 is %a, p2 is %a, subst = %a \n" + Predicate.print p1 Predicate.print p2 Subst.print (Subst.of_list res)) in + res + +and psUnify (p1s, p2s) = + let _ = asserts (List.length p1s = List.length p2s) "psUnify" in + List.fold_left2 begin fun s p1 p2 -> + (p1, p2) + |> Misc.map_pair (fun p -> Predicate.substs p s) + |> pUnify + |> (fun s' -> s' ++ s) + end [] p1s p2s + +and eUnify = function + | (Con c1, _), (Con c2, _) when c1 = c2 -> + [] + | (Var x1, _), (Var x2, _) when x1 = x2 -> + [] + | (Bin (e1, op1, e1'),_), (Bin (e2, op2, e2'), _) when op1 = op2 -> + esUnify ([e1; e1'], [e2; e2']) + | (Ite (p1, e1, e1'),_), (Ite (p2, e2, e2'), _) -> + let s = pUnify (p1, p2) in + let [e1; e1'; e2; e2'] = List.map ((Misc.flip Expression.substs) s) [e1; e1'; e2; e2'] in + esUnify ([e1; e1'], [e2; e2']) + | (Cst (e1, t1),_), (Cst (e2, t2),_) when t1 = t2 -> + eUnify (e1, e2) + | (App (uf1, e1s), _), (App (uf2, e2s),_) when uf1 = uf2 -> + esUnify (e1s, e2s) + | e, (Var x, _) | (Var x, _), e when Symbol.is_wild x -> + [(x, e)] + | _, _ -> raise DoesNotUnify + +and esUnify (e1s, e2s) = + let _ = asserts (List.length e1s = List.length e2s) "esUnify" in + List.fold_left2 begin fun s e1 e2 -> + (e1, e2) + |> Misc.map_pair (fun e -> Expression.substs e s) + |> eUnify + |> (fun s' -> s' ++ s) + end [] e1s e2s + +(* API *) +let unify_pred p1 p2 = try pUnify (p1, p2) |> Subst.of_list |> some with DoesNotUnify -> None +let into_of_expr = function Con (Constant.Int i), _ -> Some i | _ -> None + +let symm_pred = function + | Atom (e1, r, e2), _ -> pAtom (e2, symm_brel r, e1) + | p -> p + +(* {{{ +let rec expr_subst hp he e x e' = + let rec esub e = + try ExprHash.find he e with Not_found -> begin + let rv = + match euw e with + | Var y when x = y -> + e' + | Con _ | Var _ -> + e + | App (s, es) -> + App (s, List.map esub es) |> ewr + | Bin (e1, op, e2) -> + Bin (esub e1, op, esub e2) |> ewr + | Ite (ip, te, ee) -> + Ite (pred_subst hp he ip x e', esub te, esub ee) |> ewr + | Fld (s, e1) -> + Fld (s, esub e1) |> ewr in + let _ = ExprHash.add he e rv in + rv + end in esub e + +and pred_subst hp he e x e' = + let rec s e = + try PredHash.find h e with + Not_found -> (let foo = s1 e in PredHash.add h e foo; foo) + and s1 e = + match puw e with + True -> e + | False -> e + | And plist -> pwr (And(List.map s plist)) + | Or plist -> pwr (Or(List.map s plist)) + | Not p -> pwr (Not(s p)) + | Implies (p1, p2) -> pwr (Implies (s p1, s p2)) + | Equality (x,y) -> pwr (Equality(expr_subst h he x v vv,expr_subst h he y v vv)) + | Atom (_) -> e + | Leq(x,y) -> pwr (Leq(expr_subst h he x v vv, expr_subst h he y v vv)) + in s e +}}} *) +(** {{{ + let rec support pred = + let h = Hash.create 251 in + let eh = Expression.Hash.create 251 in + let sh = Hashtbl.create 251 in + let res = ref [] in + let add s = if not(Hashtbl.mem sh s) then Hashtbl.add sh s (); res := s :: !res in + + let se exp = + let rec s exp = + try Expression.Hash.find eh exp with + Not_found -> Expression.Hash.add eh exp (); s1 exp + and s1 exp = + match euw exp with + Constant(_) -> () + | Application (func, args) -> + add func; List.iter s args + | Variable(sym) -> add sym + | Sum(args) -> List.iter s args + | Coeff(c,t) -> s t + | Ite _ -> failwith "ite not supported" + in s exp in + + let rec s exp = + try Hash.find h exp with + Not_found -> Hash.add h exp (); s1 exp + and s1 pred = + match puw pred with + True -> () + | False -> () + | And plist -> List.iter s plist + | Or plist -> List.iter s plist + | Not p -> s p + | Implies (p1, p2) -> s p1; s p2 + | Equality (x,y) -> se x; se y + | Leq (x,y) -> se x; se y + | Atom (s) -> () + in s pred; List.rev !res + + let h = PredHash.create 251 in + let rec ip p = + let _ = f p in + if not (PredHash.mem h p) then begin + let _ = PredHash.add h p () in + match puw p with + | And ps | Or ps -> + List.iter ip plist + | Not p | Forall (_,p) -> + ip p + | Imp (p1, p2) -> + ip p1; ip p2 + | _ -> () + end in + ip p + }}} *) +(* {{{ + + (* Translate predicate to a satisfiability-equivalent predicate without Ite *) + + let temp_ctr = ref 0 + let new_temp () = + let n = "$$$" ^ (string_of_int !temp_ctr) in + (temp_ctr := !temp_ctr + 1; n) + + let elim_ite sp = + let cnsts = ref [] in + let he = Expression.Hash.create 251 in + let hp = Hash.create 251 in + let rec te e = + try Expression.Hash.find he e + with Not_found -> (let foo = te1 e in Expression.Hash.add he e foo; foo) + and te1 e = + match euw e with + Constant(c) -> e + | Application (func, args) -> + ewr (Application (func, List.map te args)) + | Variable(v) -> ewr (Variable(v)) + | Sum(args) -> ewr (Sum(List.map te args)) + | Coeff(c,t) -> ewr (Coeff(c,te t)) + | Ite(si,st,se) -> + let temp = ewr (Variable(new_temp())) in + let i = tp si in + let tv = te st and ev = te se in + begin + cnsts := pwr (Or [pwr (Not i); pwr (Equality(temp,(tv)))]) :: (!cnsts); + cnsts := pwr (Or [i; pwr (Equality(temp,(ev)))]) :: (!cnsts); + temp + end + and tp p = + try Hash.find hp p + with Not_found -> (let foo = tp1 p in Hash.add hp p foo; foo) + and tp1 p = + match puw p with + True -> p + | False -> p + | And plist -> pwr (And (List.map tp plist)) + | Or plist -> pwr (Or (List.map tp plist)) + | Not p -> pwr (Not (tp p)) + | Implies (p1, p2) -> pwr (Implies((tp p1),(tp p2))) + | Equality (x,y) -> pwr(Equality((te x),(te y))) + | Leq (x,y) -> pwr(Leq((te x),(te y))) + | Atom (s) -> p + in + let foo = tp sp in + pwr (And(foo :: !cnsts)) + }}} *) diff --git a/external/fixpoint/ast.mli b/external/fixpoint/ast.mli new file mode 100644 --- /dev/null +++ b/external/fixpoint/ast.mli @@ -0,0 +1,250 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +(** + * This module implements a DAG representation for expressions and + * predicates: each sub-predicate or sub-expression is paired with + * a unique int ID, which enables constant time hashing. + * However, one must take care when using DAGS: + * (1) they can only be constructed using the appropriate functions + * (2) when destructed via pattern-matching, one must discard the ID + *) + +(*******************************************************) +(********************** Base Logic ********************) +(*******************************************************) + +module Cone : sig + type 'a t = Empty | Cone of ('a * 'a t) list + val map : ('a -> 'b) -> 'a t -> 'b t +end + +module Sort : + sig + type loc = + | Loc of string + | Lvar of int + | LFun + + type tycon + type t + type sub + + val tycon : string -> tycon + val tycon_string: tycon -> string + + val to_string : t -> string + val print : Format.formatter -> t -> unit + + val t_num : t + val t_obj : t + val t_bool : t + val t_int : t + val t_generic : int -> t + val t_ptr : loc -> t + val t_func : int -> t list -> t + val t_app : tycon -> t list -> t + (* val t_fptr : t *) + + val is_bool : t -> bool + val is_int : t -> bool + val is_func : t -> bool + val app_of_t : t -> (tycon * t list) option + val func_of_t : t -> (int * t list * t) option + val ptr_of_t : t -> loc option + + val compat : t -> t -> bool + val empty_sub : sub + val unifyWith : sub -> t list -> t list -> sub option + val unify : t list -> t list -> sub option + val apply : sub -> t -> t + val generalize : t list -> t list + val sub_args : sub -> (int * t) list + (* val check_arity : int -> sub -> bool *) + end + +module Symbol : + sig + type t + module SMap : FixMisc.EMapType with type key = t + module SSet : FixMisc.ESetType with type elt = t + val mk_wild : unit -> t + val of_string : string -> t + val to_string : t -> string + val is_wild_any : t -> bool + val is_wild_fresh : t -> bool + val is_wild : t -> bool + val print : Format.formatter -> t -> unit + val value_variable : Sort.t -> t + val is_value_variable : t -> bool + val suffix : t -> string -> t + end + +module Constant : + sig + type t = Int of int + val to_string : t -> string + val print : Format.formatter -> t -> unit + end + +type tag (* externally opaque *) + +type brel = Eq | Ne | Gt | Ge | Lt | Le + +type bop = Plus | Minus | Times | Div | Mod (* NOTE: For "Mod" 2nd expr should be a constant or a var *) + +type expr = expr_int * tag + +and expr_int = + | Con of Constant.t + | Var of Symbol.t + | App of Symbol.t * expr list + | Bin of expr * bop * expr + | Ite of pred * expr * expr + | Fld of Symbol.t * expr (* NOTE: Fld (s, e) == App ("field"^s,[e]) *) + | Cst of expr * Sort.t + | Bot + | MExp of expr list + | MBin of expr * bop list * expr + +and pred = pred_int * tag + +and pred_int = + | True + | False + | And of pred list + | Or of pred list + | Not of pred + | Imp of pred * pred + | Iff of pred * pred + | Bexp of expr + | Atom of expr * brel * expr + | MAtom of expr * brel list * expr + | Forall of ((Symbol.t * Sort.t) list) * pred + +(* Constructors : expressions *) +val eTim : expr * expr -> expr +val eInt : int -> expr +val eCon : Constant.t -> expr +val eMExp : expr list -> expr +val eMod : expr * int -> expr +val eModExp : expr * expr -> expr +val eVar : Symbol.t -> expr +val eApp : Symbol.t * expr list -> expr +val eBin : expr * bop * expr -> expr +val eMBin : expr * bop list * expr -> expr +val eIte : pred * expr * expr -> expr +val eFld : Symbol.t * expr -> expr +val eCst : expr * Sort.t -> expr +(* Constructors : predicates *) +val pTrue : pred +val pFalse : pred +val pAtom : expr * brel * expr -> pred +val pMAtom : expr * brel list * expr -> pred +val pAnd : pred list -> pred +val pOr : pred list -> pred +val pNot : pred -> pred +val pImp : (pred * pred) -> pred +val pIff : (pred * pred) -> pred +val pBexp : expr -> pred +val pForall: ((Symbol.t * Sort. t) list) * pred -> pred +val pEqual : expr * expr -> pred + +val neg_brel : brel -> brel + +module Expression : +sig + module Hash : Hashtbl.S with type key = expr + + val print : Format.formatter -> expr -> unit + val show : expr -> unit + val to_string : expr -> string + + val unwrap : expr -> expr_int + val support : expr -> Symbol.t list + val subst : expr -> Symbol.t -> expr -> expr + val map : (pred -> pred) -> (expr -> expr) -> expr -> expr + val iter : (pred -> unit) -> (expr -> unit) -> expr -> unit +end + + +module Predicate : +sig + module Hash : Hashtbl.S with type key = pred + + val print : Format.formatter -> pred -> unit + val show : pred -> unit + val to_string : pred -> string + + val unwrap : pred -> pred_int + val support : pred -> Symbol.t list + val subst : pred -> Symbol.t -> expr -> pred + val map : (pred -> pred) -> (expr -> expr) -> pred -> pred + val iter : (pred -> unit) -> (expr -> unit) -> pred -> unit + val is_contra : pred -> bool + val is_tauto : pred -> bool +end + +module Subst : + sig + type t + val empty : t + val is_empty : t -> bool + val extend : t -> (Symbol.t * expr) -> t + val compose : t -> t -> t + val of_list : (Symbol.t * expr) list -> t + val simultaneous_of_list : (Symbol.t * expr) list -> t + val to_list : t -> (Symbol.t * expr) list + val print : Format.formatter -> t -> unit + val apply : t -> Symbol.t -> expr option + end + + +module Horn : + sig + type pr = string * string list + type gd = C of pred | K of pr + type t = pr * gd list + val print: Format.formatter -> t -> unit + val support: t -> string list + end + +val print_stats : unit -> unit +val fixdiv : pred -> pred +val zero : expr +val one : expr +val bot : expr + +val symm_pred : pred -> pred +val unify_pred : pred -> pred -> Subst.t option +val substs_expr : expr -> Subst.t -> expr +val substs_pred : pred -> Subst.t -> pred +val simplify_pred : pred -> pred +val conjuncts : pred -> pred list + +val sortcheck_expr : (Sort.tycon -> bool) -> (Symbol.t -> Sort.t option) -> expr -> Sort.t option +val sortcheck_pred : (Sort.tycon -> bool) -> (Symbol.t -> Sort.t option) -> pred -> bool +val sortcheck_app : (Sort.tycon -> bool) -> (Symbol.t -> Sort.t option) -> Sort.t option -> Symbol.t -> expr list -> (Sort.sub * Sort.t) option + +val into_of_expr : expr -> int option + diff --git a/external/fixpoint/cindex.ml b/external/fixpoint/cindex.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/cindex.ml @@ -0,0 +1,411 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +(***************************************************************) +(**** This module implements constraint indexing ***************) +(***************************************************************) +module H = Hashtbl +module F = Format +module BS = BNstats +module Co = Constants +module C = FixConstraint +module Misc = FixMisc +module IM = Misc.IntMap +module IS = Misc.IntSet +module SM = Ast.Symbol.SMap +module SS = Ast.Symbol.SSet +module P = Ast.Predicate + +open Misc.Ops + +let mydebug = false + +(* TODO: Describe the SCC ordering scheme! *) + +(***********************************************************************) +(***************** Index Data Structures and Accessors *****************) +(***********************************************************************) + +type rank = { + id : C.id + ; scc : int (* SCC number with ALL dependencies *) + ; iscc : int (* SCC number without CUT dependencies *) + ; simpl : bool (* Is the RHS simple ? *) + ; cut : bool (* Is the RHS a CUT-VAR *) + ; tag : C.tag; +} + +let string_of_tag t = + Printf.sprintf "[%s]" (Misc.map_to_string string_of_int t) + +let pprint_rank ppf r = + Format.fprintf ppf "id=%d, scc=%d, iscc=%d, cut=%b, tag=%a" + r.id r.scc r.iscc r.cut C.print_tag r.tag + +module WH = + Heaps.Functional (struct + type t = int * rank + let compare (ts,r) (ts',r') = + if r.scc <> r'.scc then compare r.scc r'.scc else + if ts <> ts' then - (compare ts ts') else + if r.iscc <> r'.iscc then compare r.iscc r'.iscc else + if !Constants.ptag && r.tag <> r'.tag then compare r.tag r'.tag else + compare r.simpl r'.simpl + end) + +type wkl = WH.t + +type t = + { cnst : FixConstraint.t IM.t (* id -> refinement_constraint *) + ; rnkm : rank IM.t (* id -> dependency rank *) + ; depm : C.id list IM.t (* id -> successor ids *) + ; pend : (C.id, unit) H.t (* id -> is in wkl ? *) + ; rts : IS.t (* {rank} members are "root" sccs *) + ; ds : C.dep list (* add/del dep list *) + ; rdeps : (int * int) list (* real dependencies *) + ; kuts : Ast.Symbol.t list (* CUT KVars *) + } + +let get_ref_rank me c = + Misc.do_catch "ERROR: Cindex.get_ref_rank" (IM.find (C.id_of_t c)) me.rnkm + +let get_ref_constraint me i = + Misc.do_catch "ERROR: Cindex.get_ref_constraint" (IM.find i) me.cnst + +(***********************************************************************) +(******************** Building Real Dependencies ***********************) +(***********************************************************************) + +let refa_ko = function C.Kvar (_,k) -> Some k | _ -> None + +let reft_ks = function (_,_,ras) -> Misc.map_partial refa_ko ras + +let lhs_ks c = + c |> C.lhs_of_t + |> reft_ks + |> SM.fold (fun _ (r:C.reft) l -> (reft_ks r) ++ l) (C.env_of_t c) + +let rhs_ks c = + c |> C.rhs_of_t |> reft_ks + +let make_kread_map cm = + cm |> IM.to_list + |> Misc.flap (fun (id, c) -> lhs_ks c |>: (fun k -> (k, id))) + |> SM.of_alist +(* >> SM.iter (fun k ids -> Co.bprintf mydebug "ReadIn %a := %a\n" Ast.Symbol.print k Misc.pprint_pretty_ints ids) + *) + +let make_deps cm = + let km = make_kread_map cm in + cm |> IM.to_list + |> Misc.flap (fun (id, c) -> rhs_ks c |> Misc.flap (fun k -> SM.finds k km |>: (fun id' -> (id, id')))) + |> Misc.pad_fst IM.of_alist +(* >> (fst <+> IM.iter (fun i js -> Co.bprintf mydebug "DepsOf (id = %d) = @[%a@]\n" i Misc.pprint_pretty_ints js)) +*) + +(* IM.fold begin fun id c acc -> + List.fold_left begin fun (dm, deps) k -> + let rd_ids = SM.finds k km in + let deps' = List.map (fun rd_id -> (id, rd_id)) rd_ids in + (IM.adds id rd_ids dm, (deps' ++ deps)) + end acc (rhs_ks c) + end cm (IM.empty, []) + *) + +(***********************************************************************) +(************* Adjusting Dependencies with Provided Tag-Deps ***********) +(***********************************************************************) + +let delete_deps cm dds = + let delf = C.matches_deps dds in + let tagf = fun x -> IM.find x cm |> C.tag_of_t in + List.filter (not <.> delf <.> Misc.map_pair tagf) + +let add_deps cm ads ijs = + let tt = H.create 37 in + let _ = IM.iter (fun id c -> H.add tt (C.tag_of_t c) id) cm in + ads |> Misc.map C.tags_of_dep + |> Misc.map (Misc.map_pair (H.find_all tt)) + |> Misc.flap (Misc.uncurry Misc.cross_product) + |> (++) ijs + +let adjust_deps cm ds = + let ads, dds = List.partition C.pol_of_dep ds in + !Constants.adjdeps (add_deps cm ads <.> delete_deps cm dds) + +(***********************************************************************) +(**************************** Dependency SCCs **************************) +(***********************************************************************) + +let string_of_ints is = is |> List.map string_of_int |> String.concat ", " + +let print_rank_groups f rs = + rs |> Misc.kgroupby f + |> List.sort compare + |> List.iter begin fun (g, rs) -> + Format.printf "Group=%s size=%d ids=%s\n" + g (List.length rs) (string_of_ints (List.map (fun r -> r.id) rs)) + end + +let string_of_cid cm id = + try + IM.find id cm + |> C.tag_of_t + |> Misc.fsprintf C.print_tag + |> Printf.sprintf "%d: %s" id + with _ -> assertf "string_of_cid: impossible" + +let make_rankm cm ranks iranks = + let rm = IM.of_list ranks in + let irm = IM.of_list iranks in + IM.domain cm + |>: begin fun id -> + let c = IM.find id cm in + let r = IM.find id rm in + let (ir, cut) = IM.find id irm in + id, { id = id; scc = r; iscc = ir; cut = cut; tag = C.tag_of_t c + ; simpl = (not !Co.psimple) || (C.is_simple c) } + end + |> IM.of_list + (* >> (IM.range <+> print_rank_groups (fun r -> Printf.sprintf "(%d/%d)" r.scc r.iscc )) *) + +(* returns a predicate which is true of ids whose RHS kvar is a kut-var *) +let is_cut_cst cm kuts = + let id_cstr = fun i -> IM.find i cm in + let is_cut_kvar = let ks = SS.of_list kuts in + fun k -> SS.mem k ks + in List.exists is_cut_kvar <.> List.map snd <.> C.kvars_of_reft <.> C.rhs_of_t <.> id_cstr + +let inner_ranks cm deps irs = function + | [] -> (* if no kuts specified, use dummys *) + irs |>: (fun (i, r) -> (i, (r, false))) + | kuts -> (* else, redo the SCC computation without cut-dependencies *) + let is_eq_rank = let rm = IM.of_list irs in fun i j -> (IM.find i rm = IM.find j rm) in + let is_cut_id = is_cut_cst cm kuts in + let is_cut_dep = fun (i, j) -> is_cut_id i && is_eq_rank i j in + deps |> List.filter (not <.> is_cut_dep) + |> Fcommon.scc_rank "inner" (string_of_cid cm) (IM.domain cm) + |>: (fun (i, ir) -> (i, (ir, is_cut_id i))) + +let make_ranks cm deps kuts = + let ranks = Fcommon.scc_rank "constraint" (string_of_cid cm) (IM.domain cm) deps in + let iranks = inner_ranks cm deps ranks kuts in + make_rankm cm ranks iranks + +let make_roots rankm ijs = + let sccs = rankm |> IM.to_list |> Misc.map (fun (_,r) -> r.scc) in + let sccm = List.fold_left (fun is scc -> IS.add scc is) IS.empty sccs in + List.fold_left begin fun sccm (i,j) -> + let ir = (IM.find i rankm).scc in + let jr = (IM.find j rankm).scc in + if ir <> jr then IS.remove jr sccm else sccm + end sccm ijs + + +(* A constraint c is non-live if its rhs is a k variable that is not + * (transitively) read. + * roots := { c | (rhs_of_t c) has a concrete predicate } + * lives := Pre*(roots) where Pre* is refl-trans-clos of the depends-on relation *) + +let make_lives cm real_deps = + let dm = real_deps |>: Misc.swap |> IM.of_alist in + let js = cm |> IM.filter (fun _ -> C.is_conc_rhs) |> IM.domain |> IS.of_list in + (js, IS.empty) + |> Misc.fixpoint begin fun (js, vm) -> + let vm = IS.fold (fun j vm -> IS.add j vm) js vm in + let js = IS.fold begin fun j js -> + IM.finds j dm + |> List.filter (fun j -> not (IS.mem j vm)) + |> IS.of_list + |> IS.union js + end js IS.empty + in ((js, vm), not (IS.is_empty js)) + end + |> (fst <+> snd) + >> (IS.cardinal <+> Co.bprintf mydebug "#Live Constraints: %d \n") + +let create_raw kuts ds cm dm real_deps = + let deps = adjust_deps cm ds real_deps in + let rnkm = make_ranks cm deps kuts in + { cnst = cm; ds = ds; kuts = kuts; rdeps = real_deps; rnkm = rnkm + ; depm = dm; rts = make_roots rnkm deps ; pend = H.create 17} + + +(***********************************************************************) +(**************************** API **************************************) +(***********************************************************************) + +(* API *) +let print ppf me = + List.iter (Format.fprintf ppf "@[%a@] \n" C.print_dep) me.ds; + IM.iter (fun _ c -> Format.fprintf ppf "@[%a@] \n" (C.print_t None) c) me.cnst + +let save fname me = + Misc.with_out_file fname begin fun oc -> + let ppf = F.formatter_of_out_channel oc in + F.fprintf ppf "//Sliced Constraints@."; + F.fprintf ppf "@[%a@] \n" print me + end + +(* The "adjusted" dependencies are used to create the SCC ranks ONLY. + * For soundness, the "real" dependencies must be used to push + * "successors" into the worklist. *) + +(* API *) +let create kuts ds cs = + let cm = cs |>: (Misc.pad_fst C.id_of_t) |> IM.of_list in + let dm, real_deps = make_deps cm in + create_raw kuts ds cm dm real_deps + +(* API *) +let slice me = + let lives = make_lives me.cnst me.rdeps in + let cm = me.cnst + |> IM.filter (fun i _ -> IS.mem i lives) in + let dm = me.depm + |> IM.filter (fun i _ -> IS.mem i lives) + |> IM.map (List.filter (fun j -> IS.mem j lives)) in + let rdeps = me.rdeps + |> Misc.filter (fun (i,j) -> IS.mem i lives && IS.mem j lives) in + create_raw me.kuts me.ds cm dm rdeps + >> save !Co.save_file + +(* API *) +let slice_wf me ws = + let ks = me.cnst + |> IM.range + |> Misc.flap C.kvars_of_t + |> Misc.map snd + |> SS.of_list + in Misc.filter (C.reft_of_wf <+> C.kvars_of_reft <+> List.exists (fun (_,k) -> SS.mem k ks)) ws + + +let pp_cstr_id ppf c = F.fprintf ppf "%d" (C.id_of_t c) +let pp_cstr_ids ppf cs = F.fprintf ppf "@[%a@.@]" (Misc.pprint_many false "," pp_cstr_id) cs + +(* API *) +let deps me c = + (try IM.find (C.id_of_t c) me.depm with Not_found -> []) + |> List.map (get_ref_constraint me) + (* >> (List.map C.id_of_t <+> Co.logPrintf "Deps %d = [%a]\n" (C.id_of_t c) Misc.pprint_pretty_ints) *) + +(* API *) +let to_list me = IM.range me.cnst + +(* +(* API *) +let to_live_list me = + me.cnst |> IM.to_list + |> Misc.map_partial (fun (i,c) -> if IS.mem i me.livs then Some c else None) + +*) + +let sort_iter_ref_constraints me f = + me.rnkm |> IM.to_list + |> List.sort (fun (_,r) (_,r') -> compare r.tag r'.tag) + |> List.iter (fun (id,_) -> f (IM.find id me.cnst)) + +(* API *) +let wpush = + let timestamp = ref 0 in + fun me w cs -> + incr timestamp; + List.fold_left begin fun w c -> + let id = C.id_of_t c in + if Hashtbl.mem me.pend id then w else begin + Co.cprintf Co.ol_solve "Pushing %d at %d \n" id !timestamp; + Hashtbl.replace me.pend id (); + WH.add (!timestamp, get_ref_rank me c) w + end + end w cs + +let wstring w = + WH.fold (fun (_,r) acc -> r.id :: acc) w [] + |> List.sort compare + |> Misc.map_to_string string_of_int + +(* API *) +let wpop me w = + try + let _, r = WH.maximum w in + let _ = Hashtbl.remove me.pend r.id in + let c = get_ref_constraint me r.id in + let _ = Co.cprintf Co.ol_solve "popping (%a) " pprint_rank r in + let _ = Co.cprintf Co.ol_solve "from wkl = %s \n" (wstring w) in + (Some c, WH.remove w) + with Heaps.EmptyHeap -> (None, w) + +let roots me = + IM.fold begin fun id r sccm -> + (* if not (IM.mem r.scc me.rts) then sccm else *) + let rs = try IM.find r.scc sccm with Not_found -> [] in + IM.add r.scc (r::rs) sccm + end me.rnkm IM.empty + |> IM.map (List.hd <.> List.sort compare) + |> IM.to_list + |> Misc.map (fun (_,r) -> get_ref_constraint me r.id) + +(* API *) +let winit me = + roots me |> wpush me WH.empty + + + +(***************************************************************) +(*********** A Operations for Constraint Cones *****************) +(***************************************************************) + +let rec cone_height = function + | Ast.Cone.Empty -> + 0 + | Ast.Cone.Cone xcs -> + xcs |> List.map (snd <+> cone_height <+> (+) 1) |> Misc.list_max 0 + +let rec cone_size = function + | Ast.Cone.Empty -> + 0 + | Ast.Cone.Cone xcs -> + let ns = List.map (snd <+> cone_size) xcs in + List.fold_left (+) (List.length ns) ns + +let cone (cm, dm) = + let rec go seen cid = + if IS.mem cid seen then Ast.Cone.Empty else + let seen' = IS.add cid seen in + match IM.finds cid dm with + | [] -> Ast.Cone.Empty + | cids' -> Ast.Cone.Cone (List.map (Misc.pad_snd (go seen')) cids') + in begin fun id -> + (Ast.Cone.Cone [(id, go IS.empty id)]) + |> (Ast.Cone.map (fun i -> C.tag_of_t <| IM.safeFind i cm "Cindex.cone")) + >> (fun c -> Format.printf "CONE: %d size=%d height=%d" id (cone_size c) (cone_height c)) + end + +let data_sliced_deps cs = + let cs = FixSimplify.WeakFixpoint.simplify_ts cs in + let cm = cs |>: Misc.pad_fst C.id_of_t |> IM.of_list in + let dm = make_deps cm |> snd |>: Misc.swap |> IM.of_alist in + (cm, dm) + +(* API *) +let data_cones cs = cs |> data_sliced_deps |> cone diff --git a/external/fixpoint/cindex.mli b/external/fixpoint/cindex.mli new file mode 100644 --- /dev/null +++ b/external/fixpoint/cindex.mli @@ -0,0 +1,54 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +(***************************************************************) +(**** This module implements constraint indexing ***************) +(***************************************************************) + +type t +type wkl + +(** indexing and dependencies *) +val to_list : t -> FixConstraint.t list + +(* val to_live_list : t -> FixConstraint.t list *) +val create : Ast.Symbol.t list -> FixConstraint.dep list -> FixConstraint.t list -> t +val deps : t -> FixConstraint.t -> FixConstraint.t list +val slice : t -> t +val slice_wf : t -> FixConstraint.wf list -> FixConstraint.wf list + +(** worklist manipulation *) +val wpush : t -> wkl -> FixConstraint.t list -> wkl +val wpop : t -> wkl -> FixConstraint.t option * wkl +val winit : t -> wkl + +(** printing *) +val print : Format.formatter -> t -> unit + + +(***************************************************************) +(*********** Some Operations for Constraint Cones **************) +(***************************************************************) + +val data_cones: FixConstraint.t list -> FixConstraint.id -> FixConstraint.tag Ast.Cone.t + diff --git a/external/fixpoint/counterexample.ml b/external/fixpoint/counterexample.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/counterexample.ml @@ -0,0 +1,323 @@ +(* + * Copyright © 2009-12 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +(***************************************************************) +(* Counterexample Generation (cf. Lahiri-Vanegue, VMCAI 2011) **) +(***************************************************************) + +module F = Format +module BS = BNstats +module C = FixConstraint + +module Misc = FixMisc +module IM = Misc.IntMap +module IS = Misc.IntSet + +module A = Ast +module Sy = A.Symbol +module SM = Sy.SMap +module SS = Sy.SSet +module P = A.Predicate +module Su = A.Subst +module Q = Qualifier + +open Misc.Ops + +let mydebug = false + +(***************************************************************************) +(************** Type Aliases ***********************************************) +(***************************************************************************) + +type step = int +type kvar = Sy.t +type fact = Abs of kvar * Qualifier.t | Conc of C.id +type cause = step * C.id * ((Sy.t * fact) list) + +(* [k |-> [(i0, [q_i0_1...]),...]] + * where q_i0_1... are killed at timestep i0 for kvar k sorted by step *) +type lifespan = (step * Q.t list) list SM.t + +(* [id |-> i0,...] + * where the constraint id is selected at steps i0... by solver *) +type ctrace = step list IM.t + +(* [((x1,k1,q1), c1);...;((xn,kn,qn),cn)] + * where each k_i+1, q_i+1, c_i+1 is the "cause" for why k_i, q_i is killed *) +(* type cex = (Sy.t * fact * C.id) list *) +type cex = Cause of Sy.t * fact * C.id * cex list + +(****************************************************************************) +(******************** Printing Counterexamples ******************************) +(****************************************************************************) + +let print_fact ppf = function + | Abs (k, q) -> F.fprintf ppf "(%a/%a)" Sy.print k Q.print_args q + | Conc i -> F.fprintf ppf "(id %d)" i + +let print_step ppf (x, f, cid) = + F.fprintf ppf "%a: %a @@ %d" Sy.print x print_fact f cid + +(* +let print_cex = Misc.pprint_many_box true "" "---> " "" print_step +*) + +let rec print_cex spaces ppf (Cause (x, f, cid, cs)) = + F.fprintf ppf "%s `-> %a\n%a" + (String.concat "" (Misc.clone " " spaces)) + print_step (x, f, cid) + (Misc.pprint_many false "\n\n" (print_cex (spaces + 4))) cs + +let print_cex = print_cex 0 + +let print_fact_causes n ppf (f, xfs) = + F.fprintf ppf "fact %a killed at %d by: %a \n" + print_fact f + n + (Misc.pprint_many_brackets false (Misc.pprint_tuple Sy.print print_fact)) xfs + +(****************************************************************************) +(******************** Instance Type *****************************************) +(****************************************************************************) + +let compare_fact f1 f2 = + compare (Misc.fsprintf print_fact f1) (Misc.fsprintf print_fact f2) + +module FactMap = Misc.EMap (struct + type t = fact + let compare = compare_fact + let print = print_fact +end) + +type t = { tpc : ProverArch.prover + ; n : int (* number of solver iters *) + ; s : FixConstraint.soln + ; cm : FixConstraint.t IM.t + ; ctrace : ctrace + ; lifespan : lifespan (* builds soln at n *) + ; fsm : step FactMap.t (* fact |-> step at which killed *) + ; scm : int IM.t (* step |-> constr at step *) + } + +let scm_of_ctrace ctrace = + ctrace + |> IM.to_list + |> Misc.flap (fun (cid, is) -> List.map (fun i -> (i, cid)) is) + |> Misc.fsort fst + |> IM.of_list + +let fsm_of_lifespan lifetime = + SM.fold begin fun k sqs fsm -> + List.fold_left begin fun fsm (step, qs) -> + List.fold_left begin fun fsm q -> + FactMap.add (Abs (k, q)) step fsm + end fsm qs + end fsm sqs + end lifetime FactMap.empty + +(************************************************************************) +(*********** Helpers to Reconstitute Solutions and Candidates ***********) +(************************************************************************) + +let constrOfId me cid = + IM.safeFind cid me.cm "Cex.constrOfId" + +let solutionAt me n k = + SM.safeFind k me.lifespan "solutionAt: bad kvar" + |> List.filter (fun (m,_) -> n <= m) + |> Misc.flap snd + |> Misc.map Q.pred_of_t + |> (++) (me.s k) + +let isUnsatAt me c n = + let s = solutionAt me n in + let rhsp = A.pAnd <| C.preds_of_reft s (C.rhs_of_t c) in + let query = A.pAnd <| (A.pNot rhsp) :: (C.preds_of_lhs s c) in + not <| me.tpc#is_contra (C.senv_of_t c) query + +let prevStep_conc me c : int = + let _ = asserts (C.is_conc_rhs c) in + let no = Misc.find_first_true (isUnsatAt me c) 0 me.n in + Misc.maybe_apply (+) no (-1) + +let prevStep_abs me cid n : int = + let rec go n = function + | m1 :: _ when m1 = n -> (-1) + | m1 :: (m2 :: _ as rest) -> if n = m2 then m1 else go n rest + | _ -> assertf "prevStep with bad ctrace" + in go n (IM.safeFind cid me.ctrace "prevStep: bad cid") + +let prevStep me c n = + if C.is_conc_rhs c then + prevStep_conc me c + else + prevStep_abs me (C.id_of_t c) n + +let killstep_of_fact me f = + FactMap.safeFind f me.fsm "Cex.killstep_of_fact" + +let delta me c n k : fact list = + let _n = prevStep me c n in + SM.safeFind k me.lifespan "delta: bad kvar" + |> List.filter (fun (m,_) -> _n <= m && m < n) + |> Misc.flap snd + |> Misc.map (fun q -> Abs (k, q)) + +(************************************************************************) +(************************************************************************) +(************************************************************************) + +let killerCands me c n : (int * (((Sy.t * fact) * A.pred)) list) list = + foreach (C.kbindings_of_lhs c) begin fun (x, (vv, t, ras)) -> + foreach ras begin function C.Kvar (su, k) -> + foreach (delta me c n k) begin function (Abs (_, q) as f) -> + let su' = Su.extend su (vv, A.eVar x) in + let p' = A.substs_pred (Q.pred_of_t q) su' in + (x, f), p' + end + end |> Misc.flatten + end |> Misc.flatten + |> Misc.kgroupby (fst <+> snd <+> killstep_of_fact me) + +(************************************************************************) +(******************** Lazy Explanations *********************************) +(************************************************************************) + +let killedPred me c f = + match f, C.rhs_of_t c with + | Abs (k, q), (_,_, [C.Kvar (su, k')]) + when k = k' + -> A.substs_pred (Q.pred_of_t q) su + | Conc cid, (_,_,[C.Conc p]) + when C.id_of_t c = cid + -> p + | _ -> failwith "Counterexample.killed" + +let getKillStep me c bgp iks = + let iks = Misc.fsort fst iks in + let ps = iks |>: (snd <+> List.map snd <+> A.pAnd) in + match me.tpc#unsat_suffix (C.senv_of_t c) bgp ps with + | Some j when 0 <= j && j < List.length iks + -> List.nth iks j + | io -> let _ = F.printf + "getKillStep failure: (cid = %d) (|iks| = %d) (io = %a)\n bgp = %a\nps = %a\n" + (C.id_of_t c) + (List.length iks) + (Misc.pprint_maybe Misc.pprint_int) io + P.print bgp + (Misc.pprint_many_brackets true P.print) ps + in assertf "getKillStep" + +let killinfo me = function + | Conc cid -> me.n, cid + | f -> let n = killstep_of_fact me f in + (n, IM.safeFind n me.scm "Cex.killinfo") + +(* {{{ ORIGINAL: simply use unsat core. + +let is_bot_killer = function + | (f, p) when P.is_contra p -> Some f + | _ -> None + + +let getKillers_cands me c bgp cands = + match cands, Misc.exists_maybe is_bot_killer cands with + | [], _ -> + None + | _, Some g -> + Some g + | _, _ -> + TP.unsat_core me.tpc (C.senv_of_t c) bgp cands + |> Misc.do_catch "ERROR: empty unsat core" List.hd + |> some + +let getKillers_fact (me: t) (f: fact) = + let n, cid = killinfo me f in + let c = IM.safeFind cid me.cm "Cex.getKillers 3" in + match killerCands me c n with [] -> (cid, None) | iks -> + let bgps = C.preds_of_lhs (solutionAt me n) c + |> (++) [A.pNot (killedPred me c f)] in + let (j, cands) = getKillStep me c (A.pAnd bgps) iks in + let bgps' = iks + |> List.filter (fun (i,_) -> j < i) + |> Misc.flap (snd <+> List.map snd) in + (cid, getKillers_cands me c (A.pAnd (bgps ++ bgps')) cands) + +let maxCubeSize = 1 + +let underApproxCubes me (p:pred) (q:pred) (rs: ('a * pred) list) : 'a option = + Misc.exists_maybe begin fun (f, fp) -> + if SAT (p /\ fp) && UNSAT (p /\ fp /\ q) + then Some f + else None + end rs + +}}} *) + +let getKillers_cands me c p q rs = + let env = C.senv_of_t c in + let contra = fun p -> me.tpc#is_contra env p in + Misc.map_partial begin fun (f, fp) -> + if contra (A.pAnd [p; fp; q]) && not (contra (A.pAnd [p; fp])) + then Some f + else None + end rs + +let getKillers_fact (me: t) (f: fact) = + let n, cid = killinfo me f in + let c = IM.safeFind cid me.cm "Cex.getKillers 3" in + match killerCands me c n with [] -> (cid, []) | iks -> + let bgps = C.preds_of_lhs (solutionAt me n) c in + let killedp = A.pNot (killedPred me c f) in + let (j, cands) = getKillStep me c (A.pAnd bgps) iks in + let bgps' = iks + |> List.filter (fun (i,_) -> j < i) + |> Misc.flap (snd <+> List.map snd) in + (cid, getKillers_cands me c (A.pAnd (bgps ++ bgps')) killedp cands) + +let rec explain me f = + let cid, xfs = getKillers_fact me f in + List.map (fun (x',f') -> Cause (x', f', cid, explain me f')) xfs + +(********************************************************************) +(*********************** API ****************************************) +(********************************************************************) + +(* API *) +let create tpc s cs ctrace lifespan = + let scm = scm_of_ctrace ctrace in + { tpc = tpc + ; s = s + ; cm = cs |>: Misc.pad_fst C.id_of_t |> IM.of_list + ; n = 1 + Misc.list_max 0 (IM.domain scm) + ; ctrace = IM.map Misc.sort_and_compact ctrace + ; lifespan = lifespan + ; fsm = fsm_of_lifespan lifespan + ; scm = scm + } + +(* API *) +let explain me c = + let cid0 = C.id_of_t c in + let f0 = Conc cid0 in + Cause (Sy.of_string "ERROR", f0, cid0, explain me f0) diff --git a/external/fixpoint/counterexample.mli b/external/fixpoint/counterexample.mli new file mode 100644 --- /dev/null +++ b/external/fixpoint/counterexample.mli @@ -0,0 +1,51 @@ +(* + * Copyright © 2009-12 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +(***************************************************************) +(* Counterexample Generation (cf. Lahiri-Vanegue, VMCAI 2011) **) +(***************************************************************) + +type t + +type kvar = Ast.Symbol.t +type fact = Abs of kvar * Qualifier.t | Conc of FixConstraint.id +type step = int + +(* [k |-> [(i0, [q_i0_1...]),...]] + * where q_i0_1... are killed at timestep i0 for kvar k sorted by step *) +type lifespan = (step * Qualifier.t list) list Ast.Symbol.SMap.t + +(* [cid |-> i0,...] cid is selected at steps i0... by solver *) +type ctrace = step list FixMisc.IntMap.t + +type cex + +val create : ProverArch.prover (* tp context *) + -> FixConstraint.soln (* assumes *) + -> FixConstraint.t list (* all constraints *) + -> ctrace + -> lifespan + -> t + +val explain : t -> FixConstraint.t -> cex +val print_cex : Format.formatter -> cex -> unit diff --git a/external/fixpoint/fix.ml b/external/fixpoint/fix.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/fix.ml @@ -0,0 +1,36 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +module Ast = Ast +module Symbol = Ast.Symbol +module Constant = Ast.Constant + +module Sort = Ast.Sort +module Predicate = Ast.Sort +module Expression = Ast.Expression + +module FixConstraint = FixConstraint +module Solve = Solve + + + diff --git a/external/fixpoint/fixConfig.ml b/external/fixpoint/fixConfig.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/fixConfig.ml @@ -0,0 +1,162 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + *) + +module Sy = Ast.Symbol +module SM = Sy.SMap +module Q = Qualifier +module C = FixConstraint +module So = Ast.Sort +module Co = Constants + +module Misc = FixMisc open Misc.Ops + +exception UnmappedKvar of Ast.Symbol.t + +let mydebug = false + +type qbind = Q.t list + +type solbind = Ast.Symbol.t * ((Ast.Symbol.t * (Ast.expr list)) list) + +type deft = Srt of Ast.Sort.t + | Axm of Ast.pred + | Cst of FixConstraint.t + | Wfc of FixConstraint.wf + | Con of Ast.Symbol.t * Ast.Sort.t + | Sol of solbind + (* | Sol of Ast.Symbol.t * (Ast.pred * (Ast.Symbol.t * Ast.Subst.t)) list *) + | Qul of Q.t + | Dep of FixConstraint.dep + | Kut of Ast.Symbol.t + | IBind of int * Ast.Symbol.t * FixConstraint.reft + +type 'bind cfg = { + a : int (* Tag arity *) + ; ts : Ast.Sort.t list (* New sorts, now = [] *) + ; ps : Ast.pred list (* New axioms, now = [] *) + ; cs : FixConstraint.t list (* Implication Constraints *) + ; ws : FixConstraint.wf list (* Well-formedness Constraints *) + ; ds : FixConstraint.dep list (* Constraint Dependencies *) + ; qs : Q.t list (* Qualifiers *) + ; kuts : Ast.Symbol.t list (* "Cut"-Kvars, which break cycles *) + ; bm : 'bind SM.t (* Initial Sol Bindings *) + ; uops : Ast.Sort.t Ast.Symbol.SMap.t (* Globals: measures + distinct consts) *) + ; cons : Ast.Symbol.t list (* Distinct Constants, defined in uops *) + ; assm : FixConstraint.soln (* Seed Solution -- must be a fixpoint over constraints *) +} + +let get_arity = function + | [] -> Constants.bprintflush mydebug "WARNING: NO CONSTRAINTS!"; 0 + | c::_ -> c |> FixConstraint.tag_of_t |> fst |> List.length + +let sift_quals qs = + qs >> (fun _ -> Co.bprintflush mydebug "BEGIN: Q.normalize\n") + |> Q.normalize + (* >> (Format.printf "Normalized Quals: \n%a" (Misc.pprint_many true "\n" Q.print)) *) + >> (fun _ -> Co.bprintflush mydebug "DONE: Q.normalize\n") + |> Misc.map (Misc.pad_fst Q.name_of_t) + |> SM.of_list + +let extend f cfg = function + | Srt t -> {cfg with ts = t :: cfg.ts } + | Axm p -> {cfg with ps = p :: cfg.ps } + | Cst c -> {cfg with cs = c :: cfg.cs } + | Wfc w -> {cfg with ws = w :: cfg.ws } + | Dep d -> {cfg with ds = d :: cfg.ds } + | Kut k -> {cfg with kuts = k :: cfg.kuts } + | Qul q -> {cfg with qs = q :: cfg.qs } + | Sol (k, fess) -> {cfg with bm = SM.add k (List.map f fess) cfg.bm } + | Con (s,t) -> {cfg with cons = if So.is_func t then cfg.cons else s :: cfg.cons + ; uops = SM.add s t cfg.uops} + | IBind _ -> cfg + + +let empty = + { a = 0 + ; ts = [] + ; ps = [] + ; cs = [] + ; ws = [] + ; ds = [] + ; qs = [] + ; kuts = [] + ; bm = SM.empty + ; cons = [] + ; uops = SM.empty + ; assm = FixConstraint.empty_solution + } + +let fes2q qm (f, es) = + let q = SM.safeFind f qm "name2qual" in + q |> Q.all_params_of_t + |> List.map fst + |> Misc.flip (Misc.combine "FixConfig.fes2q") es + |> Q.inst q + +let normalize_defts ds = + let qs, ds' = Misc.either_partition begin function + | Qul q -> Left q + | d -> Right d + end ds in + let qm = sift_quals qs in + let ds'' = qm |> SM.range + |>: (fun q -> Qul q) + |> (++) ds' in + (qm, ds'') + +(* API *) +let create ds = + let qm, ds' = normalize_defts ds in + ds' |> List.fold_left (extend (fes2q qm)) empty + |> (fun cfg -> {cfg with a = get_arity cfg.cs}) + |> (fun cfg -> {cfg with ws = C.add_wf_ids cfg.ws}) + +(* API *) +let create_raw ts env ps a ds cs ws qs kuts assm = + { empty with + a = a + ; ts = ts + ; uops = env + ; ps = ps + ; ds = ds + ; cs = cs + ; ws = C.add_wf_ids ws + ; kuts = kuts + ; qs = Q.normalize qs + ; assm = assm + } + +module type SIMPLIFIER = sig + val simplify_ts: FixConstraint.t list -> FixConstraint.t list +end + + +(* type t = Ast.Qualifier.def list list cfg *) + +let print ppf me = + (* Print cs *) + Format.fprintf ppf "@[%a@] \n" (Misc.pprint_many true "\n" (C.print_t None)) me.cs; + (* Print ws *) + Format.fprintf ppf "@[%a@] \n" (Misc.pprint_many true "\n" (C.print_wf None)) me.ws; + (* Print qs *) + Format.fprintf ppf "@[%a@] \n" (Misc.pprint_many true "\n" Q.print) (Q.normalize me.qs) + diff --git a/external/fixpoint/fixConfig.mli b/external/fixpoint/fixConfig.mli new file mode 100644 --- /dev/null +++ b/external/fixpoint/fixConfig.mli @@ -0,0 +1,53 @@ +(* This module deals with top-level parsing of fq files and such *) + +(* +exception UnmappedKvar of Ast.Symbol.t +*) +type solbind = Ast.Symbol.t * ((Ast.Symbol.t * (Ast.expr list)) list) +type deft = Srt of Ast.Sort.t + | Axm of Ast.pred + | Cst of FixConstraint.t + | Wfc of FixConstraint.wf + | Con of Ast.Symbol.t * Ast.Sort.t + | Sol of solbind + | Qul of Qualifier.t + | Dep of FixConstraint.dep + | Kut of Ast.Symbol.t + | IBind of int * Ast.Symbol.t * FixConstraint.reft + +type 'bind cfg = { + a : int (* Tag arity *) + ; ts : Ast.Sort.t list (* New sorts, now = [] *) + ; ps : Ast.pred list (* New axioms, now = [] *) + ; cs : FixConstraint.t list (* Implication Constraints *) + ; ws : FixConstraint.wf list (* Well-formedness Constraints *) + ; ds : FixConstraint.dep list (* Constraint Dependencies *) + ; qs : Qualifier.t list (* Qualifiers *) + ; kuts : Ast.Symbol.t list (* "Cut"-Kvars, which break cycles *) + ; bm : 'bind Ast.Symbol.SMap.t (* Initial Sol Bindings *) + ; uops : Ast.Sort.t Ast.Symbol.SMap.t (* Globals: measures + distinct consts) *) + ; cons : Ast.Symbol.t list (* Distinct Constants, defined in uops *) + ; assm : FixConstraint.soln (* Seed Solution -- must be a fixpoint over constraints *) +} + + + + +module type SIMPLIFIER = sig + val simplify_ts: FixConstraint.t list -> FixConstraint.t list +end + +val empty : 'a cfg +val create : deft list -> (Qualifier.t list) cfg +val print : Format.formatter -> 'a cfg -> unit +val create_raw: Ast.Sort.t list + -> Ast.Sort.t Ast.Symbol.SMap.t + -> Ast.pred list + -> int + -> FixConstraint.dep list + -> FixConstraint.t list + -> FixConstraint.wf list + -> Qualifier.t list + -> Ast.Symbol.t list + -> FixConstraint.soln + -> 'a cfg diff --git a/external/fixpoint/fixConstraint.ml b/external/fixpoint/fixConstraint.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/fixConstraint.ml @@ -0,0 +1,541 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONSy. + * + *) + +(* This module implements basic datatypes and operations on constraints *) +module F = Format +module H = Hashtbl +module A = Ast +module E = A.Expression +module P = A.Predicate +module Sy = A.Symbol +module So = A.Sort +module SM = Sy.SMap +module BS = BNstats +module Su = Ast.Subst +module Co = Constants +module Misc = FixMisc +module MSM = Misc.StringMap + +open Misc.Ops + +type tag = int list * string +type id = int +type dep = Adp of tag * tag | Ddp of tag * tag | Ddp_s of tag | Ddp_t of tag + +type refa = Conc of A.pred | Kvar of Su.t * Sy.t +type reft = Sy.t * A.Sort.t * refa list (* { VV: t | [ra] } *) +type envt = reft SM.t +type wf = envt * reft * (id option) * (Qualifier.t -> bool) +type t = { full : envt; + nontriv : envt; + guard : A.pred; + iguard : A.pred; + lhs : reft; + rhs : reft; + ido : id option; + tag : tag; } + +type soln = Ast.Symbol.t -> Ast.pred list + +exception BadConstraint of (id * tag * string) + + +(* +type soln = Ast.pred list Ast.Symbol.SMap.t +type soln = { read : Ast.Symbol.t -> Ast.pred list + ; kvars : Ast.Symbol.SSet.t } +*) + +let mydebug = false + +(*************************************************************) +(************************** Misc. ***************************) +(*************************************************************) + +let is_simple_refatom = function + | Kvar (s, _) -> Ast.Subst.is_empty s + | _ -> false + +let is_tauto_refatom = function + | Conc p -> P.is_tauto p + | _ -> false + + +(* API *) +let fresh_kvar = + let tick, _ = Misc.mk_int_factory () in + tick <+> string_of_int <+> (^) "k_" <+> Sy.of_string + +(* API *) +let kvars_of_reft (_, _, rs) = + Misc.map_partial begin function + | Kvar (subs, k) -> Some (subs,k) + | _ -> None + end rs + +let meet x (v1, t1, ra1s) (v2, t2, ra2s) = + asserts (v1=v2 && t1=t2) "ERROR: FixConstraint.meet x=%s (v1=%s, t1=%s) (v2=%s, t2=%s)" + (Sy.to_string x) (Sy.to_string v1) (A.Sort.to_string t1) (Sy.to_string v2) (A.Sort.to_string t2) ; + (v1, t1, Misc.sort_and_compact (ra1s ++ ra2s)) + +let env_of_bindings_ meetb xrs = + List.fold_left begin fun env (x, r) -> + let r = if meetb && SM.mem x env then meet x r (SM.find x env) else r in + SM.add x r env + end SM.empty xrs + +(* API *) +let env_of_bindings = env_of_bindings_ true +let env_of_ordered_bindings = env_of_bindings_ false + +(* +let env_of_bindings xrs = + List.fold_left begin fun env (x, r) -> + let r = if SM.mem x env then meet x r (SM.find x env) else r in + SM.add x r env + end SM.empty xrs +*) + +let bindings_of_env = SM.to_list + +(* let bindings_of_env env = + SM.fold (fun x y bs -> (x,y)::bs) env [] +*) + +let split_ras ras = + let cras, kras = List.partition (function (Conc _) -> true | _ -> false) ras in + cras |> Misc.map_partial (function Conc p -> Some p | _ -> None) + |> (function [] -> (None, kras) | ps -> (Some (A.pAnd ps), kras)) + + +let kbindings_of_lhs {nontriv = ne; lhs = (v, t, ras)} = + let xkss = SM.to_list ne in + let _, kras = split_ras ras in + (v, (v,t,kras)) :: xkss + +let map_env = SM.mapi +let lookup_env = Misc.flip SM.maybe_find +(* let lookup_env env x = try Some (SM.find x env) with Not_found -> None *) + + + +(* API *) +let is_simple {lhs = (_,_,ra1s); rhs = (_,_,ra2s)} = + List.for_all is_simple_refatom ra1s + && List.for_all is_simple_refatom ra2s + && !Co.simple + +let is_conc_refa = function Conc p -> not (P.is_tauto p) | _ -> false + +(* API *) +let is_conc_rhs {rhs = (_,_,ras)} = + List.exists is_conc_refa ras + >> (fun rv -> if rv then (asserts (List.for_all is_conc_refa ras) "is_conc_rhs")) + + +(* API *) +let kvars_of_t {nontriv = env; lhs = lhs; rhs = rhs} = + [lhs; rhs] + |> SM.fold (fun _ r acc -> r :: acc) env + |> Misc.flap kvars_of_reft + + + + +(*************************************************************) +(*********************** Logic Embedding *********************) +(*************************************************************) + +let canon_ras ras = + match split_ras ras with + | None, kras -> kras + | Some p, kras -> Conc p :: kras + +(* +let non_trivial env = + SM.fold begin fun x r sm -> match thd3 r with + | [] -> sm + | _::_ -> SM.add x r sm + end env SM.empty +*) + +let non_trivial env = + SM.fold begin fun x (v,t,ras) ((ne, ps) as acc) -> match ras with + | [] -> acc + | _ -> let po, kras = split_ras ras in + let ne' = match kras with [] -> ne | _ -> SM.add x (v,t,kras) ne in + let ps' = match po with None -> ps | Some p -> (P.subst p v (A.eVar x)) :: ps in + ne', ps' + end env (SM.empty, []) + +(* API *) +let is_conc_refa = function + | Conc _ -> true + | _ -> false + +let soln_read s k = s k (* SM.find k s *) + +(* API *) +let preds_of_refa s = function + | Conc p -> [p] + | Kvar (su,k) -> soln_read s k |> List.map (Misc.flip A.substs_pred su) + +(* API *) +let preds_of_reft f (_,_,ras) = + Misc.flap (preds_of_refa f) ras + +(* API *) +let meet_solution s1 s2 = fun k -> s1 k ++ s2 k (* SM.extendWith (fun _ -> (++)) *) +let empty_solution = fun _ -> [] + +let apply_solution_refa f ra = + Conc (A.pAnd (preds_of_refa f ra)) + +(* API *) +let apply_solution f (v, t, ras) = + (v, t, List.map (apply_solution_refa f) ras) + +let preds_of_envt f env = + SM.fold + (fun x ((vv, t, ras) as r) ps -> + let vps = preds_of_reft f r in + let xps = List.map (fun p -> P.subst p vv (A.eVar x)) vps in + xps ++ ps) + env [] + +(* API *) +let wellformed_pred env = + A.sortcheck_pred Theories.is_interp (Misc.maybe_map snd3 <.> Misc.flip SM.maybe_find env) + +(* API *) +let preds_of_lhs_nofilter f c = + let envps = preds_of_envt f c.nontriv in + let r1ps = preds_of_reft f c.lhs in + (c.iguard :: envps) ++ r1ps + + +(* let preds_of_lhs f c = + let env = SM.add (fst3 c.lhs) c.lhs c.full in + let wfp p = wellformed_pred env p + >> (fun b -> if not b then F.eprintf "WARNING: Malformed Lhs Pred (%a)\n" P.print p) in + let ps = preds_of_lhs_nofilter f c in + let ps' = List.filter wfp ps in + if !Co.strictsortcheck && List.length ps != List.length ps' + then raise (BadConstraint (Misc.maybe c.ido, c.tag, "Malformed Lhs Pred")) + else ps +*) + +let report_wellformed env c p wf = + if not wf then + let msg = F.sprintf "WARNING: Malformed Lhs Pred (%s)\n" (P.to_string p) in + let _ = F.eprintf "%s" msg in + let _ = SM.iter (fun s (_,t,_) -> F.eprintf "@[%a :: %a@]@." Sy.print s So.print t) env in + let _ = F.eprintf "@[%a@]@.@." P.print p in + if !Co.strictsortcheck then raise (BadConstraint (Misc.maybe c.ido, c.tag, msg)) + +(* API *) +let preds_of_lhs f c = + let env = SM.add (fst3 c.lhs) c.lhs c.full in + preds_of_lhs_nofilter f c + |> List.filter (fun p -> wellformed_pred env p >> report_wellformed env c p) + +(* API *) +let vars_of_t f ({rhs = r2} as c) = + (preds_of_reft f r2) ++ (preds_of_lhs f c) + |> Misc.flap P.support + +(**************************************************************) +(********************** Pretty Printing ***********************) +(**************************************************************) + +let print_refineatom ppf = function + | Conc p -> F.fprintf ppf "%a" P.print p + | Kvar (su, k) -> F.fprintf ppf "%a%a" Sy.print k Su.print su + +(* +(* API *) +let print_ras so ppf = function + | [] -> F.fprintf ppf "true" + | ras -> begin match so with + | None -> + F.fprintf ppf "%a" (Misc.pprint_many_box false "" "; " "" print_refineatom) ras + | Some s -> let ps = Misc.flap (preds_of_refa s) ras in + (match ps with + | [] -> F.fprintf ppf "[]" + | _ -> F.fprintf ppf "%a" P.print (A.pAnd ps)) + end +*) + +(* API *) +let print_ras so ppf ras = match so with + | None -> + Misc.pprint_many_box false "[" "; " "]" print_refineatom ppf ras + | Some s -> + begin match Misc.flap (preds_of_refa s) ras with + | [] -> F.fprintf ppf "[]" + | ps -> F.fprintf ppf "[%a]" P.print (A.pAnd ps) + end + + +(* API *) +let print_reft_pred so ppf (v,t,ras) = + F.fprintf ppf "@[{%a:%a | %a}@]" + Sy.print v + Ast.Sort.print t + (print_ras so) ras + +(* +let print_reft_pred so ppf = function + | (v,_,[]) -> F.fprintf ppf "@[{%a | true }@]" Sy.print v + | (v,_,ras) -> F.fprintf ppf "@[{%a | @[%a@]}@]" Sy.print v (print_ras so) ras +*) + +(* API *) +let print_reft so ppf (v, t, ras) = + F.fprintf ppf "@[{%a : %a | %a}@]" + Sy.print v + Ast.Sort.print t + (print_ras so) ras + +(* API *) +let print_binding so ppf (x, r) = + F.fprintf ppf "@[%a:%a@]" Sy.print x (print_reft so) r + +(* API *) +let print_env so ppf env = + bindings_of_env env + |> F.fprintf ppf "@[%a@]" (Misc.pprint_many_brackets true (print_binding so)) + + +let pprint_id ppf = function + | Some id -> F.fprintf ppf "id %d" id + | None -> F.fprintf ppf "" + + +let string_of_intlist = (String.concat ";") <.> (List.map string_of_int) + +(* API *) +let print_tag ppf = function + | [],_ -> F.fprintf ppf "" + | is,s -> F.fprintf ppf "tag [%s] //%s" (string_of_intlist is) s + +(* API *) +let print_dep ppf = function + | Adp ((t,_), (t',_)) + -> F.fprintf ppf "add_dep: [%s] => [%s]" (string_of_intlist t) (string_of_intlist t') + | Ddp ((t,_), (t',_)) + -> F.fprintf ppf "del_dep: [%s] => [%s]" (string_of_intlist t) (string_of_intlist t') + | Ddp_s (t,_) + -> F.fprintf ppf "del_dep: [%s] => *" (string_of_intlist t) + | Ddp_t (t',_) + -> F.fprintf ppf "del_dep: * => [%s]" (string_of_intlist t') + +(* API *) +let print_wf so ppf (env, r, io, _) = + F.fprintf ppf "wf: env @[%a@] @\n reft %a @\n %a @\n" + (print_env so) env + (print_reft so) r + pprint_id io + +let print_t so ppf c = + let env, g = if !Co.print_nontriv then c.nontriv, c.iguard else c.full, c.guard in + F.fprintf ppf + "constraint:@. env @[%a@] @\n grd @[%a@] @\n lhs @[%a@] @\n rhs @[%a@] @\n %a %a @\n" + (print_env so) env + P.print g + (print_reft so) c.lhs + (print_reft so) c.rhs + pprint_id c.ido + print_tag c.tag + +(* API *) +let to_string = Misc.fsprintf (print_t None) +let refa_to_string = Misc.fsprintf print_refineatom +let reft_to_string = Misc.fsprintf (print_reft None) +let binding_to_string = Misc.fsprintf (print_binding None) + + + +(***************************************************************) +(*********************** Getter/Setter *************************) +(***************************************************************) + +let theta_ra (su': Su.t) = function + | Conc p -> Conc (A.substs_pred p su') + | Kvar (su, k) -> Kvar (Su.compose su su', k) + + +(* API *) +let make_reft = fun v so ras -> (v, so, List.map (theta_ra Su.empty) (canon_ras ras)) + +let vv_of_reft = fst3 +let sort_of_reft = snd3 +let ras_of_reft = thd3 +let shape_of_reft = fun (v, so, _) -> (v, so, []) +let theta = fun subs (v, so, ras) -> (v, so, Misc.map (theta_ra subs) ras) + + +(* API *) +let env_of_t = fun t -> t.full +let grd_of_t = fun t -> t.guard +let lhs_of_t = fun t -> t.lhs +let rhs_of_t = fun t -> t.rhs +let tag_of_t = fun t -> t.tag +let ido_of_t = fun t -> t.ido +let id_of_t = fun t -> match t.ido with Some i -> i | _ -> assertf "C.id_of_t" +let is_tauto = rhs_of_t <+> ras_of_reft <+> List.for_all is_tauto_refatom +let make_t = fun env p r1 r2 io is -> + let p = A.simplify_pred p in + let ne, ps = non_trivial env in + { full = env + ; nontriv = ne + ; guard = p + ; iguard = A.pAnd (p::ps) + ; lhs = r1 + ; rhs = r2 + ; ido = io + ; tag = is } + +let vv_of_t = fun t -> fst3 t.lhs +let sort_of_t = fun t -> snd3 t.lhs +let senv_of_t = fun t -> SM.map snd3 t.full + |> SM.add (vv_of_t t) (sort_of_t t) + +(* +let make_t = fun env p ((v,t,ras1) as r1) r2 io is -> + let p = A.simplify_pred p in + let po, kras = split_ras ras1 in + let ne, ps = non_trivial env in + let gps = match po with Some p' -> p' :: p :: ps | _ -> p :: ps in + { full = env + ; nontriv = ne + ; guard = p + ; iguard = A.pAnd gps + ; lhs = (v, t, kras) + ; rhs = r2 + ; ido = io + ; tag = is } +*) + +let reft_of_sort so = make_reft (Sy.value_variable so) so [] + +let add_consts_env consts env = + consts + |> List.map (Misc.app_snd reft_of_sort) + |> List.fold_left (fun env (x,r) -> SM.add x r env) env + +(* API *) +let add_consts_wf consts (env,x,y,z) = (add_consts_env consts env, x, y, z) + +(* API *) +let add_consts_t consts t = {t with full = add_consts_env consts t.full} + +(* API *) +let make_wf = fun env r io -> (env, r, io, fun _ -> true) +let make_filtered_wf = fun env r io fltr -> (env, r, io, fltr) +let env_of_wf = fst4 +let reft_of_wf = snd4 +let id_of_wf = function (_,_,Some i,_) -> i | _ -> assertf "C.id_of_wf" +let filter_of_wf = fth4 + +let intersect_maps m1 m2 = SM.filter begin fun k elt -> + SM.mem k m2 && SM.find k m2 = elt +end m1 + +let intersect_wfs (e1, r1, id1, qf1) (e2, r2, id2, qf2) = + let _ = assert (r1 = r2) in + let env = intersect_maps e1 e2 in + (env, r1, id1, fun x -> (qf1 x && qf2 x)) + +let reduce_wfs wfs = + wfs + |> Misc.groupby reft_of_wf + |>: (fun wfs -> List.fold_left intersect_wfs (List.hd wfs) (List.tl wfs)) + + +(* API *) +let matches_deps ds = + let tt = H.create 37 in + let s_tt = H.create 37 in + let t_tt = H.create 37 in + List.iter begin function + | Adp (t, t') + | Ddp (t, t') -> H.add tt (t,t') () + | Ddp_s t -> H.add s_tt t () + | Ddp_t t' -> H.add t_tt t' () + end ds; + (fun (t, t') -> H.mem tt (t, t') || H.mem s_tt t || H.mem t_tt t') + +(* API *) +let pol_of_dep = function Adp (_,_) -> true | _ -> false + +(* API *) +let tags_of_dep = function + | Adp (t, t') | Ddp (t, t') -> t,t' + | _ -> assertf "tags_of_dep" + +(* API *) +let make_dep b xo yo = + match (b, xo, yo) with + | true , Some t, Some t' -> Adp (t, t') + | false, Some t, Some t' -> Ddp (t, t') + | false, Some t, None -> Ddp_s t + | false, None , Some t' -> Ddp_t t' + | _ -> assertf "FixConstraint.make_dep: match failure" + +(* API *) +let preds_kvars_of_reft reft = + List.fold_left begin fun (ps, ks) -> function + | Conc p -> p :: ps, ks + | Kvar (xes, kvar) -> ps, (xes, kvar) :: ks + end ([], []) (ras_of_reft reft) + + +(***************************************************************) +(************* Add Distinct Ids to Constraints *****************) +(***************************************************************) + +let max_id n cs = + cs |> Misc.map_partial ido_of_t + >> (fun ids -> asserts (Misc.distinct ids) "Duplicate Ids") + |> List.fold_left max n + +let max_wf_id n ws = + ws |> Misc.map_partial (fun (_,_,ido,_) -> ido) + >> (fun ids -> asserts (Misc.distinct ids) "Duplicate WF Ids") + |> List.fold_left max n + +(* API *) +let add_wf_ids ws = + Misc.mapfold begin fun j wf -> match wf with + | (x,y,None,z) -> j+1, (x, y, Some j, z) + | _ -> j, wf + end ((max_wf_id 0 ws) + 1) ws + |> snd + +(* API *) +let add_ids n cs = + Misc.mapfold begin fun j c -> match c with + | {ido = None} -> j+1, {c with ido = Some j} + | c -> j, c + end ((max_id n cs) + 1) cs diff --git a/external/fixpoint/fixConstraint.mli b/external/fixpoint/fixConstraint.mli new file mode 100644 --- /dev/null +++ b/external/fixpoint/fixConstraint.mli @@ -0,0 +1,140 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONAst.Symbol. + * + *) + +(* This module implements basic datatypes and operations on constraints *) + + +type t (* NEVER EVER expose! *) +type wf (* NEVER EVER expose! *) +type dep (* NEVER EVER expose! dependencies between constraints *) + +type tag = int list * string (* for ordering: must have same dim, lexico-ordered *) +type id = int (* for identifying: must be unique *) + +exception BadConstraint of (id * tag * string) + +type soln = Ast.Symbol.t -> Ast.pred list +type refa = Conc of Ast.pred | Kvar of Ast.Subst.t * Ast.Symbol.t +type reft = Ast.Symbol.t * Ast.Sort.t * refa list (* { VV: t | [ra] } *) +type envt = reft Ast.Symbol.SMap.t + +val fresh_kvar : unit -> Ast.Symbol.t +val kvars_of_reft : reft -> (Ast.Subst.t * Ast.Symbol.t) list +val kvars_of_t : t -> (Ast.Subst.t * Ast.Symbol.t) list + +val is_conc_refa : refa -> bool +val is_conc_rhs : t -> bool + +val empty_solution : soln +val meet_solution : soln -> soln -> soln +val apply_solution : soln -> reft -> reft + +val wellformed_pred : envt -> Ast.pred -> bool +val preds_of_refa : soln -> refa -> Ast.pred list +val preds_of_reft : soln -> reft -> Ast.pred list +val preds_of_lhs : soln -> t -> Ast.pred list +val preds_of_lhs_nofilter : soln -> t -> Ast.pred list + +val vars_of_t : soln -> t -> Ast.Symbol.t list +val is_tauto : t -> bool + +val preds_kvars_of_reft : reft -> (Ast.pred list * (Ast.Subst.t * Ast.Symbol.t) list) +val env_of_bindings : (Ast.Symbol.t * reft) list -> envt +val env_of_ordered_bindings : (Ast.Symbol.t * reft) list -> envt + +(* TODO: Deprecate *) +val bindings_of_env : envt -> (Ast.Symbol.t * reft) list + +val kbindings_of_lhs : t -> (Ast.Symbol.t * reft) list + +val is_simple : t -> bool +val map_env : (Ast.Symbol.t -> reft -> reft) -> envt -> envt +val lookup_env : envt -> Ast.Symbol.t -> reft option + +(* to print a constraint "c" do: + Format.printf "%a" (print_t None) c + + to print an env "env" do: + Format.printf "%a" (print_env None) c + + to print a wf constraint wf do: + Format.printf "%a" (print_wf None) wf + + to convert a constraint c to a string do: + to_string c + + to print a list of constraints cs do: + Format.printf "%a" (FixMisc.pprint_many true "\n" (C.print_t None)) cs + *) + +val print_env : soln option -> Format.formatter -> envt -> unit +val print_wf : soln option -> Format.formatter -> wf -> unit +val print_t : soln option -> Format.formatter -> t -> unit +val print_ras : soln option -> Format.formatter -> refa list -> unit +val print_reft : soln option -> Format.formatter -> reft -> unit +val print_reft_pred : soln option -> Format.formatter -> reft -> unit +val print_binding : soln option -> Format.formatter -> (Ast.Symbol.t * reft) -> unit +val print_tag : Format.formatter -> tag -> unit +val print_dep : Format.formatter -> dep -> unit + +val to_string : t -> string +val refa_to_string : refa -> string +val reft_to_string : reft -> string +val binding_to_string: (Ast.Symbol.t * reft) -> string + +val make_reft : Ast.Symbol.t -> Ast.Sort.t -> refa list -> reft +val vv_of_reft : reft -> Ast.Symbol.t +val sort_of_reft : reft -> Ast.Sort.t +val ras_of_reft : reft -> refa list +val shape_of_reft : reft -> reft +val theta : Ast.Subst.t -> reft -> reft + +val add_consts_wf : (Ast.Symbol.t * Ast.Sort.t) list -> wf -> wf +val add_consts_t : (Ast.Symbol.t * Ast.Sort.t) list -> t -> t +val make_t : envt -> Ast.pred -> reft -> reft -> id option -> tag -> t + +val sort_of_t : t -> Ast.Sort.t +val vv_of_t : t -> Ast.Symbol.t +val senv_of_t : t -> Ast.Sort.t Ast.Symbol.SMap.t +val env_of_t : t -> envt +val grd_of_t : t -> Ast.pred +val lhs_of_t : t -> reft +val rhs_of_t : t -> reft +val id_of_t : t -> id +val ido_of_t : t -> id option +val tag_of_t : t -> tag +val add_ids : id -> t list -> id * t list +val add_wf_ids : wf list -> wf list +val make_wf : envt -> reft -> id option -> wf +val make_filtered_wf : envt -> reft -> id option -> (Qualifier.t -> bool) -> wf +val env_of_wf : wf -> envt +val reft_of_wf : wf -> reft +val id_of_wf : wf -> id +val filter_of_wf : wf -> (Qualifier.t -> bool) + +val reduce_wfs : wf list -> wf list + +val make_dep : bool -> tag option -> tag option -> dep +val matches_deps : dep list -> tag * tag -> bool +val tags_of_dep : dep -> tag * tag +val pol_of_dep : dep -> bool diff --git a/external/fixpoint/fixLex.mll b/external/fixpoint/fixLex.mll new file mode 100644 --- /dev/null +++ b/external/fixpoint/fixLex.mll @@ -0,0 +1,151 @@ +(* + * Copyright © 1990-2002 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * d + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +{ + module Misc = FixMisc + + open Misc.Ops + module E = Errorline + open E + open FixParse + + let lexerror msg lexbuf = + E.error (Lexing.lexeme_start lexbuf) msg + + (* + let int_of_lexbuf lb = + let str = Lexing.lexeme lb in + let len = String.length str in + let zero = Char.code '0' in + let rec accum a d = + let acc c = a + (d * ((Char.code c) - zero)) in + function 0 -> let c = str.[0] in + if c='-' then - a else (acc c) + | i -> accum (acc str.[i]) (d * 10) (i - 1) + in accum 0 1 (len-1) + *) + + let safe_int_of_string s = + try int_of_string s with ex -> + let _ = Printf.printf "safe_int_of_string crashes on: %s (error = %s)" s (Printexc.to_string ex) in + raise ex +} + +let digit = ['0'-'9' '-'] +let letdig = ['0'-'9' 'a'-'z' 'A'-'Z' '_' '@' ''' '.' '#'] +let alphlet = ['A'-'Z' 'a'-'z' '~' '_' ''' '@' ] +let capital = ['A'-'Z'] +let small = ['a'-'z' '$' '_'] +let ws = [' ' '\009' '\012'] +let pathname = ['a'-'z' 'A'-'Z' '0'-'9' '.' '/' '\\' '-'] + +rule token = parse + ['\r''\t'' '] { token lexbuf} + | '\n' { begin + E.startNewline (Lexing.lexeme_end lexbuf); + token lexbuf + end } + | "//"[^'\n']*'\n' + { begin + E.startNewline (Lexing.lexeme_end lexbuf); + token lexbuf + end + } + | '[' { LB } + | ']' { RB } + | '(' { LPAREN } + | ')' { RPAREN } + | '{' { LC } + | '}' { RC } + | '~' { NOT } + | ';' { SEMI } + | ',' { COMMA } + | ':' { COLON } + | '|' { MID } + | '+' { PLUS } + | '-' { MINUS } + | '*' { TIMES } + | '/' { DIV } + | '?' { QM } + | '.' { DOT } + | "not" { NOTWORD } + | "tag" { TAG } + | "id" { ID } + | "Bexp" { BEXP } + | "false" { FALSE } + | "true" { TRUE } + | ":=" { ASGN } + | "&&" { AND } + | "||" { OR } + | "<=>" { IFF } + | "iff" { IFFWORD } + | "=>" { IMPL } + | "!=" { NE } + | "=" { EQ } + | "<=" { LE } + | "<" { LT } + | ">=" { GE } + | ">" { GT } + | "mod" { MOD } + | "obj" { OBJ } + | "num" { NUM } + | "int" { INT } + | "ptr" { PTR } + | "" { LFUN } + (* | "fptr" { FPTR } *) + | "bool" { BOOL } + | "uit" { UNINT } + | "func" { FUNC } + | "sort" { SRT } + | "axiom" { AXM } + | "constant" { CON } + | "constraint" { CST } + | "wf" { WF } + | "solution" { SOL } + | "qualif" { QUL } + | "cut" { KUT } + | "bind" { BIND } + | "add_dep" { ADP } + | "del_dep" { DDP } + | "env" { ENV } + | "grd" { GRD } + | "lhs" { LHS } + | "rhs" { RHS } + | "reft" { REF } + | "@" { TVAR } + | (digit)+ { Num (safe_int_of_string (Lexing.lexeme lexbuf)) } + | (alphlet)letdig* { Id (Lexing.lexeme lexbuf) } + | '''[^''']*''' { let str = Lexing.lexeme lexbuf in + let len = String.length str in + Id (String.sub str 1 (len-2)) + } + + | eof { EOF } + | _ { + begin + lexerror ("Illegal Character '" ^ + (Lexing.lexeme lexbuf) ^ "'") lexbuf; + token lexbuf + end } + diff --git a/external/fixpoint/fixParse.mly b/external/fixpoint/fixParse.mly new file mode 100644 --- /dev/null +++ b/external/fixpoint/fixParse.mly @@ -0,0 +1,420 @@ + +%{ +module A = Ast +module So = A.Sort +module Sy = A.Symbol +module E = A.Expression +module P = A.Predicate +module H = A.Horn +module Su = A.Subst +module C = FixConstraint +module Co = Constants +open FixMisc.Ops + +(* + * + %token Tycon + | (capital)letdig* { Tycon (Lexing.lexeme lexbuf) } + | Tycon { So.t_app (So.tycon $1) [] } + | Tycon tyconargsne { So.t_app (So.tycon $1) $2 } + *) + (* | Id { So.t_ptr (So.Loc $1) } + +(* +pExprs: + LPAREN RPAREN { [] } + | LPAREN expr RPAREN { [$2] } + | LPAREN exprsCommaNe RPAREN { $2 } + ; + +exprsCommaNe: + expr { [$1] } + | expr COMMA exprsCommaNe { $1 :: $3 } + ; + *) + +*) +let parse_error msg = + Errorline.error (symbol_start ()) msg + +let create_qual name vv = Qualifier.create (Sy.of_string name) (Sy.of_string vv) + +let set_ibind, get_ibind = + let bindt = Hashtbl.create 37 in + ( (fun (i, x, t) -> Hashtbl.replace bindt i (x, t)) + , (fun i -> try Hashtbl.find bindt i with Not_found -> assertf "Unknown binding: %d\n" i) + ) + +let env_of_ibindings is = + is |> FixMisc.sort_and_compact + |> FixMisc.map get_ibind + |> C.env_of_ordered_bindings + +%} + +%token Id +%token Num +%token TVAR +%token TAG ID +%token BEXP +%token TRUE FALSE +%token LPAREN RPAREN LB RB LC RC +%token EQ NE GT GE LT LE +%token AND OR NOT NOTWORD IMPL IFF IFFWORD FORALL SEMI COMMA COLON MID +%token EOF +%token MOD +%token PLUS +%token MINUS +%token TIMES +%token DIV +%token QM DOT ASGN +%token OBJ INT NUM PTR LFUN BOOL UNINT FUNC +%token SRT AXM CON CST WF SOL QUL KUT BIND ADP DDP +%token ENV GRD LHS RHS REF + +%right IFF IFFWORD +%right IMPL +%left PLUS +%left MINUS +%left DIV +%left TIMES +%left DOT +%right NOT + +%start defs +%start sols +%start reft + +%type defs +%type def +%type sols +%type sorts, sortsne +%type sort +%type <(Sy.t * So.t) list> binds, bindsne +%type preds, predsne +%type pred +%type exprs, exprsne +%type expr +%type cstr +%type env +%type reft +%type refas, refasne +%type refa +%type subs + +%% +defs: + { [] } + | def defs { $1 :: $2 } + ; + + + +qual: + Id LPAREN Id COLON sort RPAREN COLON pred { create_qual $1 $3 $5 [] $8 } + | Id LPAREN Id RPAREN COLON pred { create_qual $1 $3 So.t_int [] $6 } + | Id LPAREN Id COLON sort qbindsne RPAREN COLON pred { create_qual $1 $3 $5 $6 $9 } + ; + +qbindsne: + COMMA bind { [$2] } + | COMMA bind qbindsne { $2 :: $3 } + ; + +def: + SRT COLON sort { FixConfig.Srt $3 } + | AXM COLON pred { FixConfig.Axm $3 } + | CST COLON cstr { FixConfig.Cst $3 } + | CON Id COLON sort { FixConfig.Con (Sy.of_string $2, $4) } + | WF COLON wf { FixConfig.Wfc $3 } + | sol { FixConfig.Sol $1 } + | QUL qual { FixConfig.Qul $2 } + | KUT Id { FixConfig.Kut (Sy.of_string $2) } + | dep { FixConfig.Dep $1 } + | BIND Num Id COLON reft { let (i, x, r) = ($2, Sy.of_string $3, $5) + >> set_ibind + in FixConfig.IBind (i,x,r) } + ; + + +sorts: + LB RB { [] } + | LB sortsne RB { $2 } + ; + +sortsne: + sort { [$1] } + | sort SEMI sortsne { $1 :: $3 } + ; + +tyconargsne: + | bsort { [$1] } + | bsort tyconargsne { $1 :: $2 } + ; + +sort: + | bsort { $1 } + | Id tyconargsne { So.t_app (So.tycon $1) $2 } + | LB sort RB { So.t_app (So.tycon "List") [$2] } + + ; + +bsort: + | INT { So.t_int } + | BOOL { So.t_bool } + | PTR { So.t_ptr (So.Lvar 0) } + | PTR LPAREN LFUN RPAREN { So.t_ptr (So.LFun) } + | PTR LPAREN Num RPAREN { So.t_ptr (So.Lvar $3) } + | PTR LPAREN Id RPAREN { So.t_ptr (So.Loc $3) } + | OBJ { So.t_obj } + | NUM { So.t_num } + | TVAR LPAREN Num RPAREN { So.t_generic $3 } + | FUNC LPAREN sorts RPAREN { So.t_func 0 $3 } + | FUNC LPAREN Num COMMA sorts RPAREN { So.t_func $3 $5 } + | Id { let s = $1 in + if !Co.gen_qual_sorts || FixMisc.stringIsLower s then + So.t_ptr (So.Loc s) (* tyvar *) + else + So.t_app (So.tycon s) [] (* tycon *) + } + | LPAREN sort RPAREN { $2 } + ; + + +binds: + LB RB { [] } + | LB bindsne RB { $2 } + ; + +bindsne: + bind { [$1] } + | bind SEMI bindsne { $1::$3 } + ; + + +bind: + Id COLON sort { ((Sy.of_string $1), $3) } + ; + +rels: + LB RB { [] } + | LB relsne RB { $2 } + ; + +relsne: + rel { [$1]} + | rel SEMI relsne { $1 :: $3} + ; + +rel: + EQ { A.Eq } + | NE { A.Ne } + | GT { A.Gt } + | GE { A.Ge } + | LT { A.Lt } + | LE { A.Le } + ; + + +preds: + LB RB { [] } + | LB predsne RB { $2 } + ; + +predsne: + pred { [$1] } + | pred SEMI predsne { $1 :: $3 } +; + +pred: + TRUE { A.pTrue } + | FALSE { A.pFalse } + | BEXP expr { A.pBexp $2 } + | QM expr { A.pBexp $2 } + | Id LPAREN argsne RPAREN { A.pBexp (A.eApp ((Sy.of_string $1), $3)) } + | AND preds { A.pAnd ($2) } + | OR preds { A.pOr ($2) } + | NOT pred { A.pNot ($2) } + | NOTWORD pred { A.pNot ($2) } + | LPAREN pred AND pred RPAREN { A.pAnd [$2; $4] } + | LPAREN pred OR pred RPAREN { A.pOr [$2; $4] } + | expr rel expr { A.pAtom ($1, $2, $3) } + | expr rels expr { A.pMAtom ($1, $2, $3) } + | FORALL binds DOT pred { A.pForall ($2, $4) } + | pred IMPL pred { A.pImp ($1, $3) } + | pred IFF pred { A.pIff ($1, $3) } + | pred IFFWORD pred { A.pIff ($1, $3) } + | LPAREN pred RPAREN { $2 } + ; + +argsne: + expr { [$1] } + | expr COMMA argsne { $1::$3 } + ; + + + +exprs: + LB RB { [] } + | LB exprsne RB { $2 } + ; + +exprsne: + expr { [$1] } + | expr SEMI exprsne { $1 :: $3 } + ; + +expr: + Id { A.eVar (Sy.of_string $1) } + | con { A.eCon $1 } + | exprs { A.eMExp $1 } + | LPAREN expr MOD Num RPAREN { A.eMod ($2, $4) } + | expr PLUS expr { A.eBin ($1, A.Plus, $3) } + | expr MINUS expr { A.eBin ($1, A.Minus, $3) } + | expr TIMES expr { A.eBin ($1, A.Times, $3) } + | expr DIV expr { A.eBin ($1, A.Div, $3) } + | expr ops expr { A.eMBin ($1, $2, $3) } + | Id LPAREN exprs RPAREN { A.eApp ((Sy.of_string $1), $3) } + | Id Id { A.eApp ((Sy.of_string $1), [A.eVar (Sy.of_string $2)]) } + | LPAREN pred QM expr COLON expr RPAREN { A.eIte ($2,$4,$6) } + | expr DOT Id { A.eFld ((Sy.of_string $3), $1) } + | LPAREN expr COLON sort RPAREN { A.eCst ($2, $4) } + | LPAREN expr RPAREN { $2 } + ; + +op: + | PLUS { A.Plus } + | MINUS { A.Minus } + | TIMES { A.Times } + | DIV { A.Div } + ; + +ops: + LB RB { [] } + | LB opsne RB { $2 } + ; + +opsne: + op { [$1] } + | op SEMI opsne { $1 :: $3 } + ; + + + +con: + | Num { (A.Constant.Int $1) } + | MINUS Num { (A.Constant.Int (-1 * $2)) } + ; + +cons: + LB RB { [] } + | LB consne RB { $2 } + ; + +consne: + con { [$1] } + | con SEMI consne { $1 :: $3 } + ; + +wf: + ENV env REF reft { C.make_wf $2 $4 None } + | ENV env REF reft ID Num { C.make_wf $2 $4 (Some $6) } + ; + +tagsne: + Num { [$1] } + | Num SEMI tagsne { $1 :: $3 } + ; + +tag: + | LB tagsne RB { ($2, "") } + ; + +dep: + | ADP COLON tag IMPL tag {C.make_dep true (Some $3) (Some $5) } + | DDP COLON tag IMPL tag {C.make_dep false (Some $3) (Some $5) } + | DDP COLON TIMES IMPL tag {C.make_dep false None (Some $5) } + | DDP COLON tag IMPL TIMES {C.make_dep false (Some $3) None } + ; + +info: + ID Num { ((Some $2), ([],"")) } + | TAG tag { (None , $2)} + | ID Num TAG tag { ((Some $2), $4) } + ; + +cstr: + | ENV env GRD pred LHS reft RHS reft { C.make_t $2 $4 $6 $8 None ([],"") } + | ENV env GRD pred LHS reft RHS reft info { C.make_t $2 $4 $6 $8 (fst $9) (snd $9)} + ; + +env: + LB RB { C.env_of_bindings [] } + | LB envne RB { C.env_of_bindings $2 } + | LB ienvne RB { env_of_ibindings $2 } + ; + +ienvne: + Num { [$1] } + | Num SEMI ienvne { $1 :: $3 } + ; + +envne: + rbind { [$1] } + | rbind SEMI envne { $1 :: $3 } + ; + + +rbind: + Id COLON reft { (Sy.of_string $1, $3) } + ; + +ibind: + Num Id COLON reft { ($1, Sy.of_string $2, $4) } + ; + +reft: + LC Id COLON sort MID refas RC { ((Sy.of_string $2), $4, $6) } + ; + +refas: + LB RB { [] } + | LB refasne RB { $2 } + ; + +refasne: + refa { [$1] } + | refa SEMI refasne { $1 :: $3 } + ; + +refa: + Id subs { C.Kvar ($2, (Sy.of_string $1)) } + | pred { C.Conc $1 } + ; + +subs: + { Su.empty } + | LB Id ASGN expr RB subs { Su.extend $6 ((Sy.of_string $2), $4) } + ; + +npred: + LPAREN pred COMMA Id LPAREN argsne RPAREN RPAREN { ((* $2, *) (Sy.of_string $4, $6)) } + ; + +npreds: + LB RB { [] } + | LB npredsne RB { $2 } + ; + +npredsne: + npred { [$1] } + | npred SEMI npredsne { $1 :: $3 } +; + +sol: + SOL COLON Id ASGN npreds { ((Sy.of_string $3), $5) } + +sols: + { [] } + | sol sols { $1 :: $2 } + diff --git a/external/fixpoint/fixSimplify.ml b/external/fixpoint/fixSimplify.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/fixSimplify.ml @@ -0,0 +1,455 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +module BS = BNstats +module Co = Constants +module C = FixConstraint +module P = Ast.Predicate +module E = Ast.Expression +module Sy = Ast.Symbol +module Kg = Kvgraph +module Su = Ast.Subst +module SM = Ast.Symbol.SMap +module SS = Ast.Symbol.SSet + +module Misc = FixMisc +module IM = Misc.IntMap +open Misc.Ops +open Ast + +let mydebug = false + + +(****************************************************************************) +(*********************************** Misc. **********************************) +(****************************************************************************) + +let add_cm = List.fold_left (fun cm c -> IM.add (C.id_of_t c) c cm) +let find_cm = fun cm id -> IM.find id cm +let refas_of_k = fun k -> [C.Kvar (Su.empty, k)] + +(****************************************************************************) +(************** Generic Simplification/Transformation API *******************) +(****************************************************************************) + +module type SIMPLIFIER = sig + val simplify_ts: FixConstraint.t list -> FixConstraint.t list +end + +(****************************************************************************) +(******************* Syntactic Simplification *******************************) +(****************************************************************************) + +module Syntactic : SIMPLIFIER = struct + +let defs_of_pred = + let rec dofp (em, pm) p = match p with + | Atom ((Var v, _), Eq, e), _ + when not (P.is_tauto p) -> + Sy.SMap.add v e em, pm + | And [Imp ((Bexp (Var v1, _), _), p1), _; + Imp (p2, (Bexp (Var v2, _), _)), _], _ + when v1 = v2 && p1 = p2 && not(P.is_tauto p) -> + em, Sy.SMap.add v1 p1 pm + | And ps, _ -> + List.fold_left dofp (em, pm) ps + | _ -> em, pm + in dofp (Sy.SMap.empty, Sy.SMap.empty) + +let rec expr_apply_defs em pm expr = + let ef = expr_apply_defs em pm in + let pf = pred_apply_defs em pm in + match expr with + | Var v, _ when Sy.SMap.mem v em -> + Sy.SMap.find v em, true + | Var _, _ | Con _, _ | Bot, _ -> + expr, false + | App (v, es), _ -> + let _ = asserts (not (Sy.SMap.mem v em)) "binding for UF" in + es |> List.map ef + |> List.split + |> (fun (es', bs') -> (eApp (v, es'), List.fold_left (||) false bs')) + | Bin (e1, op, e2), _ -> + let e1', b1' = ef e1 in + let e2', b2' = ef e2 in + eBin (e1', op, e2'), (b1' || b2') + | Ite (p, e1, e2), _ -> + let p', b' = pf p in + let e1', b1' = ef e1 in + let e2', b2' = ef e2 in + eIte (p', e1', e2'), (b' || b1' || b2') + | Fld (v, e), _ -> + let e', b' = ef e in + eFld (v, e'), b' + | Cst (e, t), _ -> + let e', b' = ef e in + eCst (e', t), b' + | _ -> failwith "Pattern: expr_apply_defs" + +and pred_apply_defs em pm pred = + let ef = expr_apply_defs em pm in + let pf = pred_apply_defs em pm in + match pred with + | And ps, _ -> + ps |> List.map pf + |> List.split + |> (fun (ps', bs') -> pAnd ps', List.exists id bs') + | Or ps, _ -> + ps |> List.map pf + |> List.split + |> (fun (ps', bs') -> pOr ps', List.exists id bs') + | Not p, _ -> + p |> pf + |> Misc.app_fst pNot + | Imp (p1, p2), _ -> + let p1', b1' = pf p1 in + let p2', b2' = pf p2 in + pImp (p1', p2'), b1' || b2' + | Bexp (Var v, _), _ when Sy.SMap.mem v pm -> + Sy.SMap.find v pm, true + | Bexp e, _ -> + e |> ef |> Misc.app_fst pBexp + | Atom (e1, brel, e2), _ -> + let e1', b1' = ef e1 in + let e2', b2' = ef e2 in + pAtom (e1', brel, e2'), b1' || b2' + | Forall (qs, p), _ -> + assertf "Forall in Simplify!" + | _ -> + pred, false + +(* Why does this fixpointing terminate? + * close em, pm under substitution so that + for all x in dom(em), support(em(x)) \cap dom(em) = empty *) + +(* Assume: em is well-formed, + * i.e. exists an ordering on vars of dom(em) + * x1 < x2 < ... < xn s.t. if xj \in em(xi) then xj < xi *) + +let expr_apply_defs em fm e = + e |> Misc.fixpoint (expr_apply_defs em fm) + |> fst + +let pred_apply_defs em fm p = + p |> Misc.fixpoint (pred_apply_defs em fm) + |> fst + |> simplify_pred + +let subs_apply_defs em pm xes = List.map (Misc.app_snd (expr_apply_defs em pm)) xes + + +let print_em_pm t (em, pm) = + let id = t |> C.id_of_t in + let vv = t |> C.lhs_of_t |> C.vv_of_reft in + let vve = try Sy.SMap.find vv em with Not_found -> bot in + let vve' = expr_apply_defs em pm vve in + Co.bprintf mydebug "\nbodyp em map for %d\n" id ; + Sy.SMap.iter (fun x e -> Co.bprintf mydebug "%a -> %a\n" Sy.print x E.print e) em; + Co.bprintf mydebug "\nbodyp pm map for %d\n" id ; + Sy.SMap.iter (fun x p -> Co.bprintf mydebug "%a -> %a\n" Sy.print x P.print p) pm; + Co.bprintf mydebug "edef for vv %a = %a (simplified %a)\n" Sy.print vv E.print vve E.print vve' + +let preds_kvars_of_env env = + Sy.SMap.fold begin fun x r (ps, env) -> + let vv = C.vv_of_reft r in + let xe = Ast.eVar x in + let t = C.sort_of_reft r in + let rps, rks = C.preds_kvars_of_reft r in + let ps' = List.map (fun p -> P.subst p vv xe) rps ++ ps in + let env' = (* match rks with [] -> env | _ -> *) Sy.SMap.add x (vv, t, rks) env in + ps', env' + end env ([], Sy.SMap.empty) + +let simplify_kvar em pm (su, sym) = + su |> Su.to_list + |> subs_apply_defs em pm + |> Su.of_list + |> (fun su -> C.Kvar (su, sym)) + +let simplify_env em pm ks_env = + Sy.SMap.map begin fun (vv, t, ks) -> + ks |> List.map (simplify_kvar em pm) |> C.make_reft vv t + end ks_env + +let simplify_grd em pm vv t p = + let _ = Co.bprintf mydebug "simplify_grd [1]: %a \n" P.print p in + let p = pred_apply_defs em pm p in + let _ = Co.bprintf mydebug "simplify_grd [2]: %a \n" P.print p in + begin try + Sy.SMap.find vv em + |> expr_apply_defs em pm + |> (fun vve -> pAnd [p; pAtom (eVar vv, Eq, vve)]) + with Not_found -> p end + >> Co.bprintf mydebug "simplify_grd [3]: %a \n" P.print + +let simplify_refa em pm = function + | C.Conc p -> C.Conc (pred_apply_defs em pm p) + | C.Kvar (xes, sym) -> simplify_kvar em pm (xes, sym) + +(* API *) +let simplify_t c = + let id = c |> C.id_of_t in + let _ = Co.bprintf mydebug "============== Simplifying %d ============== \n"id in + let env_ps, ks_env = c |> C.env_of_t |> preds_kvars_of_env in + let l_ps, l_ks = c |> C.lhs_of_t |> C.preds_kvars_of_reft in + let vv, t = c |> C.lhs_of_t |> Misc.tmap2 (C.vv_of_reft, C.sort_of_reft) in + let bodyp = Ast.pAnd ([C.grd_of_t c] ++ l_ps ++ env_ps) + >> Co.bprintf mydebug "body_pred: %a \n" P.print in + let em, pm = defs_of_pred bodyp + >> print_em_pm c in + + let senv = simplify_env em pm ks_env in + let sgrd = simplify_grd em pm vv t bodyp in + let slhs = l_ks |> List.map (simplify_kvar em pm) |> C.make_reft vv t in + let srhs = c |> C.rhs_of_t |> C.ras_of_reft |> List.map (simplify_refa em pm) |> C.make_reft vv t in + + C.make_t senv sgrd slhs srhs (C.ido_of_t c) (C.tag_of_t c) + +(* API *) +let simplify_ts cs = + cs |> List.map simplify_t + (* |> List.filter (not <.> C.is_tauto) *) +end + +(****************************************************************************) +(*** Cone-of-Influence: Remove Constraints that don't reach constant-pred ***) +(****************************************************************************) + +module Cone : SIMPLIFIER = struct + let simplify_ts cs = + let cm = add_cm IM.empty cs in + cs |> Kg.add Kg.empty + >> Kg.print_stats + |> Kg.cone_ids + |> List.map (find_cm cm) +end + +(**************************************************************************) +(*** Direct-Dependencies: Remove non-data-dependent binders****************) +(*************************************************************************) + +module WeakFixpoint : SIMPLIFIER = struct + + let weaken_env c e = + C.make_t e + (C.grd_of_t c) (C.lhs_of_t c) (C.rhs_of_t c) + (C.ido_of_t c) (C.tag_of_t c) + + let support_of_refa = function + | C.Conc p -> P.support p + | _ -> [] + + let support_of_reft = + Misc.flap support_of_refa <.> thd3 + + let rec data_cone env m n xs = match xs with + | _::_ -> let m' = List.fold_left (fun m' x -> Sy.SMap.add x n m') m xs in + xs |> Misc.map_partial (C.lookup_env env) + |> Misc.flap support_of_reft + |> Misc.filter (fun x -> not (Sy.SMap.mem x m)) + |> data_cone env m' (n+1) + | [] -> m + + let data_cone c = + (P.support (C.grd_of_t c)) + |> (++) (support_of_reft (C.lhs_of_t c)) + |> data_cone (C.env_of_t c) Sy.SMap.empty 0 + + let project_cone m x ((v,t,ras) as r) = + if Sy.SMap.mem x m then r else (v, t, List.filter C.is_conc_refa ras) + + let simplify_t c = + c |> data_cone |> project_cone |> C.map_env + |> (fun f -> f (C.env_of_t c)) + |> weaken_env c + + let simplify_ts = Misc.map simplify_t +end + +(****************************************************************************) +(***** Merge Write and Read of Kvar: A |- k and B, k |- C iff A,B |- C ****) +(****************************************************************************) + +module EliminateK : SIMPLIFIER = struct + + type t = { g : Kg.t; + cm : FixConstraint.t IM.t; + id : int; } + + let print_k ppf k = + Format.fprintf ppf "%s" (C.refa_to_string k) + + let empty = + { g = Kg.empty; + cm = IM.empty; + id = 0; } + + let add me cs = + let n, cs = C.add_ids me.id cs in + { g = Kg.add me.g cs; + cm = add_cm me.cm cs; + id = n+1 } + + let remove me (k, cs) = + { g = Kg.remove me.g [k]; + cm = List.map C.id_of_t cs |> List.fold_left (Misc.flip IM.remove) me.cm; + id = me.id; } + + let of_ts = add empty + let to_ts = fun me -> me.cm |> IM.to_list |> List.map snd + let cs_of_k = fun f me k -> f me.g [k] |> List.map (find_cm me.cm) + + (* Assume that k is written in (1) and read once in (2) + + (1) env1, g1, k_v:l1 |- k[xi := ai] + (2) env2, g2, y:k[xi := bi] |- r2 + + Now, (1) equiv (1') and (2) equiv (2') + + (1') env1, g1, #i:{v=ai}, k_v:l1 |- k[xi := #i] + (2') env2, g2, #i:{v=bi}, y:k2[xi := #i] |- r2 + + Next, we can merge (1') and (2') + + (1'+2') env1 ++ env2, g1 && g2, #i:{v=ai}, #i:{v=bi}, y:l1 |- r2 + + Which simplifies to: + + (1'+2') env1 ++ env2, g1 && g2 && {ai = bi}, y:l1 |- r2 + *) + + let meet_env env1 env2 xrs = + [env1; env2] + |> Misc.flap C.bindings_of_env + |> (++) xrs + |> C.env_of_bindings + + let meet_sub su1 su2 = + [su1; su2] + |> Misc.flap Su.to_list + |> Misc.groupby fst + |> List.map (function [(x,e)] -> pEqual (eVar x, e)| [(_,e1);(_,e2)] -> pEqual (e1,e2)) + |> pAnd + + let merge_one me k (wc, rc) = + let env1, env2 = Misc.map_pair C.env_of_t (wc, rc) in + let g1, g2 = Misc.map_pair C.grd_of_t (wc, rc) in + let l1 = C.lhs_of_t wc in + let [C.Kvar(su1, k)] = C.rhs_of_t wc |> thd3 in + let su2, yr', l' = match Kg.k_reads me.g (C.id_of_t rc) (C.Kvar (Su.empty, k)) with + | [Kg.Bnd (y, su2)] -> su2, [(y,l1)], (C.lhs_of_t rc) + | [Kg.Lhs su2] -> su2, [], l1 + | _ -> assertf "EliminateK.merge_one (k=%s, id=%d)" (Sy.to_string k) (C.id_of_t rc) in + let env' = meet_env env1 env2 yr' in + let g' = pAnd [g1; g2; meet_sub su1 su2] in + let r' = C.rhs_of_t rc in + C.make_t env' g' l' r' None (C.tag_of_t rc) + + let eliminate me (k, wcs, rcs) = + me >> (fun _ -> Format.printf "EliminateK.eliminate %s \n" (C.refa_to_string k)) + |> Misc.flip add (Misc.cross_product wcs rcs |> List.map (merge_one me k)) + |> Misc.flip remove (k, wcs ++ rcs) + + let select_ks me = + me.g + |> Kg.filter_kvars (Kg.is_single_wr me.g) + |> List.filter (Kg.is_single_rd me.g) + |> List.map (fun k -> (k, cs_of_k Kg.writes me k, cs_of_k Kg.reads me k)) + |> List.filter (fun (_,wcs, rcs) -> Misc.disjoint wcs rcs) + >> (List.map fst3 <+> Format.printf "EliminateK.select_ks [OUT]: %a \n" + (Misc.pprint_many false "," print_k)) + + let simplify_ts cs = + let me = of_ts cs in + me |> select_ks + |> List.fold_left eliminate me + |> to_ts +end + + +(****************************************************************************) +(***** Copy Propagation *****************************************************) +(****************************************************************************) + +module CopyProp : SIMPLIFIER = struct + + let subst_theta = + List.map <.> Misc.app_snd <.> (fun (x, e) e' -> E.subst e' x e) + + let subst_bind su x y ((v, t, ras) as r) = + if x = y then (v, t, []) else C.theta su r + + let subst_cstr (x, e) c = + let su = Su.of_list [(x, e)] in + let env' = C.env_of_t c |> C.map_env (subst_bind su x) in + let grd' = C.grd_of_t c |> (fun p -> P.subst p x e) in + let lhs' = C.lhs_of_t c |> C.theta su in + let rhs' = C.rhs_of_t c |> C.theta su in + C.make_t env' grd' lhs' rhs' (C.ido_of_t c) (C.tag_of_t c) + + let rec eliminate c = function + | (x, e) :: theta' when List.mem x (E.support e) + -> eliminate c theta' + | xe :: theta' (* x not in e *) + -> eliminate (subst_cstr xe c) (subst_theta xe theta') + | [] -> c + + let rigid_vars c = + c |> C.kvars_of_t + |> List.map fst + |> Misc.flap Su.to_list + |> List.map fst + |> SS.of_list + + let equalities_of_binding = function + | (x, (v, _, [C.Conc ( Atom ((Var v', _), Eq, e), _ )])) + when v = v' -> Some (x, e) + | (x, (v, _, [C.Conc ( Atom (e, Eq, (Var v', _)), _ )])) + when v = v' -> Some (x, e) + | _ -> None + + let equalities_of_t c = + c |> C.env_of_t + |> (fun _ -> failwith "CopyProp.equalities_of_t") (* C.bindings_of_env *) + |> Misc.map_partial equalities_of_binding + + let simplify_t c = + let ys = rigid_vars c in + c |> equalities_of_t + |> List.filter (fun (x,_) -> not (SS.mem x ys)) + |> eliminate c + + let simplify_ts = Misc.map simplify_t +end + +(* API *) +let simplify_ts cs = + cs + |> Misc.filter (not <.> C.is_tauto) + |> ((not !Co.lfp) BS.time "simplify 0" WeakFixpoint.simplify_ts) + |> BS.time "add ids 1" (C.add_ids 0) + |> snd + (* |> (!Co.copyprop BS.time "simplify CP" CopyProp.simplify_ts) *) + |> (!Co.simplify_t BS.time "simplify 1" Syntactic.simplify_ts) (* termination bug, tickled by C benchmarks *) + |> (!Co.simplify_t BS.time "simplify 2" Cone.simplify_ts) + |> (!Co.simplify_t BS.time "simplify 3" EliminateK.simplify_ts) diff --git a/external/fixpoint/fixSimplify.mli b/external/fixpoint/fixSimplify.mli new file mode 100644 --- /dev/null +++ b/external/fixpoint/fixSimplify.mli @@ -0,0 +1,28 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + + +module WeakFixpoint : FixConfig.SIMPLIFIER +include FixConfig.SIMPLIFIER + +(* val simplify_ts : FixConstraint.t list -> FixConstraint.t list *) diff --git a/external/fixpoint/fixpoint.ml b/external/fixpoint/fixpoint.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/fixpoint.ml @@ -0,0 +1,148 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + + +(** read a set of constraints, solve, and dump out the solution *) + +module CX = Counterexample +module BS = BNstats +module SM = Ast.Symbol.SMap +module Co = Constants +module C = FixConstraint +module F = Format +module T = Toplevel +module PA = PredAbs +module SPA = Solve.Make (PA) +module Cg = FixConfig + +module Misc = FixMisc open Misc.Ops + +let mydebug = false + +(*****************************************************************) +(********************* Hooking into Solver ***********************) +(*****************************************************************) + +let print_raw_cs ppf = function + | [] -> F.fprintf ppf "SAT \n \n \n" + | cs -> F.fprintf ppf "UNSAT [%s] \n \n \n" (Misc.map_to_string (C.id_of_t <+> string_of_int) cs) + +let save_raw fname cs s = + Misc.with_out_formatter fname begin fun ppf -> + F.fprintf ppf "%a \n" print_raw_cs cs; + F.fprintf ppf "%a \n" PA.print s; + F.fprintf ppf "@."; + F.print_flush () + end + +let save_crash fname (id, tag, msg) = + Misc.with_out_formatter fname begin fun ppf -> + F.fprintf ppf "CRASH %d (%s)\n" id msg; + F.fprintf ppf "//%a\n" C.print_tag tag; + F.fprintf ppf "@."; + F.print_flush () + end + +let solve ac = + let _ = Co.bprintflush mydebug "Fixpoint: Creating CI\n" in + let ctx, s = BS.time "create" SPA.create ac None in + let _ = Co.bprintflush mydebug "Fixpoint: Solving \n" in + let s, cs',_ = BS.time "solve" (SPA.solve ctx) s in + + let _ = Co.bprintflush mydebug "Fixpoint: Saving Result \n" in + let _ = BS.time "save" (save_raw !Co.out_file cs') s in + let _ = Co.bprintflush mydebug "Fixpoint: Saving Result DONE \n" in + cs' + +let dump_solve ac = + try + let cs' = solve { ac with Cg.bm = SM.map PA.mkbind ac.Cg.bm } in + let _ = if Co.ck_olev 1 then BNstats.print stdout "Fixpoint Solver Time \n" in + match cs' with + | [] -> (F.printf "\nSAT\n" ; exit 0) + | _ -> (F.printf "\nUNSAT\n" ; exit 1) + with (C.BadConstraint (id, tag, msg)) -> begin + Format.printf "Fixpoint: Bad Constraint! id = %d (%s) tag = %a \n" + id msg C.print_tag tag; + save_crash !Co.out_file (id, tag, msg); + end + +(*****************************************************************) +(********************* Generate Imp Program **********************) +(*****************************************************************) + +let dump_imp a = + (List.map (fun c -> Cg.Cst c) a.Cg.cs ++ List.map (fun c -> Cg.Wfc c) a.Cg.ws) + |> ToImp.render F.std_formatter + |> fun _ -> exit 1 + +(*****************************************************************) +(***************** Generate Simplified Constraints ***************) +(*****************************************************************) + +let hook_simplify_ts = function + | "andrey" -> List.map Simplification.simplify_t + <+> List.filter (not <.> Simplification.is_tauto_t) + <+> Simplification.simplify_ts + | "jhala" -> FixSimplify.simplify_ts + (* put other transforms here *) + | _ -> id + +let simplify_ts cs = hook_simplify_ts !Co.dump_simp cs + +let dump_simp ac = + let ac = {ac with Cg.cs = simplify_ts ac.Cg.cs; Cg.bm = SM.empty} in + Misc.with_out_formatter !Co.save_file (fun ppf -> Cg.print ppf ac) + +(* +let dump_simp ac = + (* let ac = {ac with Cg.cs = simplify_ts ac.Cg.cs; Cg.bm = SM.empty; Cg.qs = []} in *) + let ac = {ac with Cg.cs = simplify_ts ac.Cg.cs; Cg.bm = SM.empty} in + Misc.with_out_formatter !Co.save_file (fun ppf -> Cg.print ppf ac) + + let ctx,_ = BS.time "create" SPA.create ac None in + let s0 = PA.empty (* PA.create ac None *) in + let _ = BS.time "save" (SPA.save !Co.save_file ctx) s0 in + exit 1 +*) + +(*****************************************************************) +(*********************** Main ************************************) +(*****************************************************************) + +let usage = "Usage: fixpoint.native [source-files]\noptions are:" + +let main () = + let cfg = usage |> Toplevel.read_inputs |> snd in + if !Co.dump_imp then + dump_imp cfg + else if !Co.dump_smtlib then + ToSmtLib.dump_smtlib cfg + else if !Co.dump_simp <> "" then + dump_simp cfg + else + dump_solve cfg + + + +let _ = main () diff --git a/external/fixpoint/fixtop.ml b/external/fixpoint/fixtop.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/fixtop.ml @@ -0,0 +1,123 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + + +(** read a set of constraints, solve, and dump out the solution *) + +module SM = Ast.Symbol.SMap +module Co = Constants +module C = FixConstraint +module F = Format +(*module Si = Simplification *) +module Misc = FixMisc +open Misc.Ops + +let _ = FixLex.token (Lexing.from_string "int");; + +let parse_string f = f FixLex.token <.> Lexing.from_string + + +let dump cs ws = + Format.printf "Printing Out Parsed Constraints \n \n \n" ; + Format.printf "%a" (Misc.pprint_many true "\n" (FixConstraint.print_t None)) cs; + Format.printf "\n \n"; + Format.printf "%a" (Misc.pprint_many true "\n" (FixConstraint.print_wf None)) ws; + Format.printf "\n \n" + +let usage = "Usage: fixtop [source-files]\noptions are:" + +let main () = print_string "Hello World \n" + +(* +let main () = + let fs, config = Toplevel.read_inputs usage in + let cs = config.C.cs in + let ws = config.C.ws in + let cs = + if !Co.simplify_t then + Misc.map_partial begin fun t -> + let st = Si.simplify_t t in + if Si.is_tauto_t st then None else Some st + end cs |> Si.simplify_ts + else cs in + begin + match !Co.latex_file with + | Some f -> + let out = open_out f in + ToLatex.to_latex out cs ws; + close_out out + | None -> () + end; + (* + begin + match !Co.armc_file with + | Some f -> + let out = open_out f in + Printf.fprintf out "%% %s\n" (String.concat ", " fs); + ToHC.to_dataflow_armc out cs ws sol; + close_out out + | None -> () + end; + *) + (* + begin + match !Co.horn_file with + | Some f -> + let out = open_out f in + Printf.fprintf out "%% %s\n" (String.concat ", " fs); + ToHC.to_horn out cs ws sol; + close_out out + | None -> () + end; + *) + begin + match !Co.q_armc_file with + | Some f -> + let out = open_out f in + Printf.fprintf out "%% %s\n" (String.concat ", " fs); + ToQARMC.to_qarmc out cs ws; + close_out out + | None -> () + end; +(* + begin + match !Co.raw_horn_file with + | Some f -> + let out = open_out f in + Printf.fprintf out "%% %s\n" (String.concat ", " fs); + ToRawHorn.to_raw_horn out cs ws sol; + close_out out + | None -> () + end; +*) + begin + match !Co.dot_file with + | Some f -> + let oc = open_out f in + ToDot.to_dot oc cs; + close_out oc + | None -> () + end +*) + +let _ = main () diff --git a/external/fixpoint/hornLex.mll b/external/fixpoint/hornLex.mll new file mode 100644 --- /dev/null +++ b/external/fixpoint/hornLex.mll @@ -0,0 +1,99 @@ +(* + * Copyright © 1990-2002 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * d + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +{ + module E = Errorline + open E + open HornParse + + let lexerror msg lexbuf = + E.error (Lexing.lexeme_start lexbuf) msg + +} + +let letdig = ['0'-'9' 'a'-'z' 'A'-'Z' '_' '@' ''' '.' '#'] +let small = ['a'-'z'] +let digit = ['0'-'9'] + +rule token = parse + ['\r''\t'' '] { token lexbuf} + | '\n' { begin + E.startNewline (Lexing.lexeme_end lexbuf); + token lexbuf + end } + | "//"[^'\n']*'\n' + { begin + E.startNewline (Lexing.lexeme_end lexbuf); + token lexbuf + end } + | '[' { LB } + | ']' { RB } + | '(' { LPAREN } + | ')' { RPAREN } + | '{' { LC } + | '}' { RC } + | '~' { NOT } + | ';' { SEMI } + | ',' { COMMA } + | ':' { COLON } + | '+' { PLUS } + | '-' { MINUS } + | '*' { TIMES } + | '/' { DIV } + | '.' { DOT } + | "hc" { HC } + | "Bexp" { BEXP } + | "false" { FALSE } + | "true" { TRUE } + | "&&" { AND } + | "||" { OR } + | "!=" { NE } + | "=" { EQ } + | "=<" { LE } + | "<" { LT } + | ">=" { GE } + | ">" { GT } + | "->" { IMPL } + | (digit)+ { let str = Lexing.lexeme lexbuf in + let len = String.length str in + let zero = Char.code '0' in + let rec accum a d = + let acc c = a + (d * ((Char.code c) - zero)) in + function + 0 -> let c = str.[0] in + if c='-' then - a else (acc c) + | i -> accum (acc str.[i]) (d * 10) (i - 1) + in + Num (accum 0 1 (len-1)) } + + | '_'(digit)+ { Id (Lexing.lexeme lexbuf) } + | (small)letdig+ { Var (Lexing.lexeme lexbuf) } + | eof { EOF } + | _ { + begin + lexerror ("Illegal Character '" ^ + (Lexing.lexeme lexbuf) ^ "'") lexbuf; + token lexbuf + end } + diff --git a/external/fixpoint/hornParse.mly b/external/fixpoint/hornParse.mly new file mode 100644 --- /dev/null +++ b/external/fixpoint/hornParse.mly @@ -0,0 +1,147 @@ + +%{ +module A = Ast +module So = A.Sort +module Sy = A.Symbol +module E = A.Expression +module P = A.Predicate +module H = A.Horn +module Su = A.Subst +module C = FixConstraint + +let parse_error msg = + Errorline.error (symbol_start ()) msg + +%} + +%token Var +%token Id +%token Num +%token BEXP +%token TRUE FALSE +%token LPAREN RPAREN LB RB LC RC +%token EQ NE GT GE LT LE +%token AND OR NOT IMPL FORALL SEMI COMMA COLON DOT +%token EOF +%token PLUS +%token MINUS +%token TIMES +%token DIV +%token HC + +%right PLUS +%right MINUS +%right TIMES +%right DIV + + +%start horns + +%type preds, predsne +%type pred +%type exprs, exprsne +%type expr +%type brel +%type bop + +%type pr +%type guard +%type guards, guardsne +%type hc +%type horns + +%% +preds: + LB RB { [] } + | LB predsne RB { $2 } + ; + +predsne: + pred { [$1] } + | pred SEMI predsne { $1 :: $3 } +; + +pred: + TRUE { A.pTrue } + | FALSE { A.pFalse } + | BEXP expr { A.pBexp $2 } + | AND preds { A.pAnd ($2) } + | OR preds { A.pOr ($2) } + | NOT pred { A.pNot ($2) } + | pred IMPL pred { A.pImp ($1, $3) } + | expr brel expr { A.pAtom ($1, $2, $3) } + | LPAREN pred RPAREN { $2 } + ; + +exprs: + LB RB { [] } + | LB exprsne RB { $2 } + ; + +exprsne: + expr { [$1] } + | expr SEMI exprsne { $1 :: $3 } + ; + +expr: + Id { A.eVar (Sy.of_string $1) } + | Num { A.eCon (A.Constant.Int $1) } + | MINUS Num { A.eCon (A.Constant.Int (-1 * $2)) } + | MINUS LPAREN expr RPAREN { A.eBin (A.zero, A.Minus, $3) } + | expr bop expr { A.eBin ($1, $2, $3) } + | Id LPAREN exprs RPAREN { A.eApp ((Sy.of_string $1), $3) } + | LPAREN expr RPAREN { $2 } + ; + +brel: + EQ { A.Eq } + | NE { A.Ne } + | GT { A.Gt } + | GE { A.Ge } + | LT { A.Lt } + | LE { A.Le } + ; + +bop: + PLUS { A.Plus } + | MINUS { A.Minus } + | TIMES { A.Times } + | DIV { A.Div } + ; + + +idsne: + Id { [$1] } + | Id COMMA idsne { $1 :: $3 } + ; + +pr: + Var LPAREN RPAREN { ($1, []) } + | Var LPAREN idsne RPAREN { ($1, $3) } + | Var { ($1, []) } + ; + +guard: + pr { H.K ($1) } + | pred { H.C ($1) } + ; + +guards: + LB RB { [] } + | LB guardsne RB { $2 } + ; + +guardsne: + guard { [$1] } + | guard COMMA guardsne { $1 :: $3 } + ; + +hc: + HC LPAREN pr COMMA guards RPAREN DOT {($3, $5)} + ; + + +horns: + { [] } + | hc horns { $1 :: $2 } + diff --git a/external/fixpoint/hornToInterproc.ml b/external/fixpoint/hornToInterproc.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/hornToInterproc.ml @@ -0,0 +1,154 @@ + +module F = Format +module BS = BNstats +module Co = Constants +module SM = Misc.StringMap +module H = Ast.Horn +module Misc = FixMisc open Misc.Ops + + +let tmpname1 = "tmp" + +(***************************************************************************) +(************************* Parse Horn Clauses ******************************) +(***************************************************************************) + +let clean f = + Misc.map_lines_of_file f tmpname1 begin fun s -> + if String.length s > 3 && String.sub s 0 3 = "hc(" then + let ss = Misc.chop s ", " in + match ss with + | [s1; s2; _] -> Printf.sprintf "%s, %s).\n\n" s1 s2 + | ss -> assertf "bad string: %s" (String.concat "####" ss) + else "" + end; + tmpname1 + +let parse f : H.t list = + let ic = f |> clean >> Errorline.startFile |> open_in in + let rv = Lexing.from_channel ic |> HornParse.horns HornLex.token in + let _ = close_in ic in + rv + +(****************************************************************************) +(******************* Preprocess HC to get global information ****************) +(****************************************************************************) + +type t = { + aritym : int SM.t; (* k -> arity *) + bindm : string list SM.t; (* k -> local bindings *) + argn : int; (* max-fun-args across all ks *) + cm : H.t list SM.t; (* k -> cs *) +} + +let create (cs: H.t list) : t = + let cm = cs |> Misc.kgroupby (fun ((k,_),_) -> k) + |> List.fold_left (fun cm (k,cs) -> SM.add k cs cm) SM.empty in + let aritym = SM.map (function ((k, xs),_)::_ -> + let n = List.length xs in + (* let _ = Printf.printf "Arity(%s) using %s is %d \n" k + (String.concat "," xs) n in *) + n) cm in + let bindm = SM.map ((Misc.flap H.support) <+> Misc.sort_and_compact) cm in + let argn = SM.fold (fun _ a n -> max a n) aritym 0 in + { aritym = aritym; bindm = bindm; argn = argn; cm = cm } + +(****************************************************************************) +(**************************** Generic Sequencers ****************************) +(****************************************************************************) + +let gen f sep xs = + xs |> Misc.map f |> String.concat sep + +let geni f sep xs = + xs |> Misc.mapi f |> String.concat sep + +let defn x n = + geni (fun i _ -> Printf.sprintf "%s%d : int" x i) ", " (Misc.range 0 n) + +(****************************************************************************) +(********************************* Translation ******************************) +(****************************************************************************) + +let tx_gd = function + | H.C p -> Printf.sprintf " assume %s;" (Misc.fsprintf Ast.Predicate.print p) + | H.K (k, xs) -> Printf.sprintf "%s\n () = %s(%s);" + (geni (Printf.sprintf " a%d = %s;") "\n" xs) + k + (geni (fun i _ -> Printf.sprintf "a%d" i) "," xs) + +let tx_hd = function + | "error", _ -> " fail;" + | _, xs -> Printf.sprintf " assume %s;" + (geni (fun i x -> Printf.sprintf " z%d == %s " i x) " and " xs) + +let tx_t k (head, guards) : string = + Printf.sprintf " if brandom then\n%s\n%s\n else" (gen tx_gd "\n" guards) (tx_hd head) + +let tx_def me = function + | "error" -> + "" + | k -> + let n = try SM.find k me.aritym with Not_found -> assertf "ERROR:no arity for %s" k in + let _ = Printf.printf "Arity(%s) := %d \n" k n in + Printf.sprintf "proc %s(%s) returns ()" k (defn "z" n) + +let tx_k me (k, cs) = + Printf.sprintf +" +%s +var %s, %s; +begin +%s + halt; + %s +end +" +(tx_def me k) +(defn "a" me.argn) +(gen (Printf.sprintf "%s : int") ", " (SM.find k me.bindm)) +(gen (tx_t me) "\n" cs) +(gen (fun _ -> "endif;") " " cs) + +let rewrite_eq s = + if Misc.is_substring s "assume" then + Misc.replace_substring " = " " == " s + else s + +let tx cs = + let me = create cs in + me.cm + |> Misc.sm_to_list + |> List.map (tx_k me) + |> String.concat "\n\n" + |> Misc.flip Misc.chop "\n" + |> List.map rewrite_eq + |> String.concat "\n" + +(***************************************************************************) +(***************************** Output Clauses ******************************) +(***************************************************************************) + +let dump f cs = + cs >> Format.printf "*************Horn Clauses************\n\n%a\n\n\n" (Misc.pprint_many true "\n" H.print) + |> tx + >> Format.printf "***********Interproc Program*********\n\n%s\n\n\n" + |> Misc.write_to_file (f^".ipc") + +let usage = "hornToInterproc.native [filename.pl]" + +let main usage = + print_now "\n \n \n \n \n"; + print_now "========================================================\n"; + print_now "© Copyright 2009 Regents of the University of California.\n"; + print_now "All Rights Reserved.\n"; + print_now "========================================================\n"; + print_now (Sys.argv |> Array.to_list |> String.concat " "); + print_now "\n========================================================\n"; + let fs = ref [] in + let _ = Arg.parse Co.arg_spec (fun s -> fs := s::!fs) usage in + match !fs with + | [f] -> parse f |> dump f + | _ -> assertf "I choke on too many/few files!" + +let _ = main usage diff --git a/external/fixpoint/kvgraph.ml b/external/fixpoint/kvgraph.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/kvgraph.ml @@ -0,0 +1,211 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + *) + +module Sy = Ast.Symbol +module P = Ast.Predicate +module Su = Ast.Subst +module C = FixConstraint +module Misc = FixMisc open Misc.Ops + +type rd = Bnd of Sy.t * Su.t | Lhs of Su.t | Grd | Junk + +let print_rd ppf = function + | Bnd (x, su) -> Format.fprintf ppf "Bnd (%a, %a)" Sy.print x Su.print su + | Lhs su -> Format.fprintf ppf "Lhs (%a)" Su.print su + | Grd -> Format.fprintf ppf "Grd" + | Junk -> Format.fprintf ppf "Junk" + +(************************************************************************) +(********************* Build Graph of Kvar Dependencies *****************) +(************************************************************************) + +module V : Graph.Sig.COMPARABLE with type t = C.refa = struct + type t = C.refa + let hash = C.refa_to_string <+> Hashtbl.hash + let compare = fun x y -> compare (C.refa_to_string x) (C.refa_to_string y) + let equal = fun x y -> C.refa_to_string x = C.refa_to_string y +end + +module Id : Graph.Sig.ORDERED_TYPE_DFT with type t = int * rd = struct + type t = int * rd + let default = 0, Junk + let compare = compare +end + +module G = Graph.Persistent.Digraph.ConcreteLabeled(V)(Id) +module VS = Set.Make(V) + +type t = G.t + +(************************************************************************) +(*************************** Dumping to Dot *****************************) +(************************************************************************) + +module DotGraph = struct + type t = G.t + module V = G.V + module E = G.E + let iter_vertex = G.iter_vertex + let iter_edges_e = G.iter_edges_e + let graph_attributes = fun _ -> [`Size (11.0, 8.5); `Ratio (`Float 1.29)] + let default_vertex_attributes = fun _ -> [`Shape `Box] + let vertex_name = function C.Kvar (_,k) -> Sy.to_string k | ra -> "C"^(string_of_int (V.hash ra)) + let vertex_attributes = fun ra -> [`Label (C.refa_to_string ra)] + let default_edge_attributes = fun _ -> [] + let edge_attributes = fun (_,(i,r),_) -> [`Label (Printf.sprintf "%d:%s" i (Misc.fsprintf print_rd r))] + let get_subgraph = fun _ -> None +end + +module Dot = Graph.Graphviz.Dot(DotGraph) + +let dump_graph s g = + s |> open_out + >> (fun oc -> Dot.output_graph oc g) + |> close_out + +(************************************************************************) +(********************* Constraints-to-Graph *****************************) +(************************************************************************) + +let xkvars_of_env env = + Sy.SMap.fold begin fun x r acc -> + r |> C.kvars_of_reft + |> List.map (fun z -> x,z) + |> (fun xks -> xks ++ acc) + end env [] + +let dsts_of_t c = + c |> C.rhs_of_t + |> C.ras_of_reft + |> List.map (function C.Kvar (_,k) -> C.Kvar (Su.empty, k) | ra -> ra) + +let edges_of_t c = + let eks = c |> C.env_of_t + |> xkvars_of_env + |> List.map (fun (x, (su, k)) -> (C.Kvar (Su.empty, k)), Bnd (x, su)) in + let gps = c |> C.grd_of_t + |> (fun p -> if P.is_tauto p then [] else [(C.Conc p, Grd)]) in + let lks = c |> C.lhs_of_t + |> C.ras_of_reft + |> List.map (function C.Kvar (su, k) -> (C.Kvar (Su.empty, k), Lhs su) | ra -> (ra, Grd)) in + c |> dsts_of_t + |> Misc.cross_product (lks ++ gps ++ eks) + |> List.map (fun ((ra, l), ra') -> (ra, (C.id_of_t c, l), ra')) + +(************************************************************************) +(*************************** Misc. Accessors ****************************) +(************************************************************************) + +let vertices_of_graph = fun g -> G.fold_vertex (fun v acc -> v::acc) g [] + +(* API *) +let filter_kvars f g = + g |> vertices_of_graph + |> List.filter (not <.> C.is_conc_refa) + |> List.filter f + |> Misc.sort_and_compact + +let get_edges f g vs = + vs |> Misc.flap (f g) + |> List.map (fun (_,(i,_),_) -> i) + |> Misc.sort_and_compact + +(* APU *) +let writes = get_edges G.pred_e +let reads = get_edges G.succ_e + +(* API *) +let k_reads g i k = + k >> (C.refa_to_string <+> Format.printf "Kvgraph.k_reads [IN] id=%d, k=%s\n" i) + |> G.succ_e g + |> Misc.map_partial (function (_,(j,x),_) when i=j -> Some x | _ -> None) + >> (Format.printf "Kvgraph.k_reads [OUT] %a \n" (Misc.pprint_many false "," print_rd)) + +(************************************************************************) +(********************* (Backwards) Reachability *************************) +(************************************************************************) + +let vset_of_list vs = List.fold_left (fun s v -> VS.add v s) VS.empty vs +let pre_star g vs = + (vs, VS.empty) + |> Misc.fixpoint begin function + | [], r -> ([], r), false + | ws, r -> ws |> List.filter (fun v -> not (VS.mem v r)) + |> Misc.tmap2 (Misc.flap (G.pred g), vset_of_list <+> VS.union r) + |> (fun x -> x, true) + end + |> fst |> snd + |> VS.elements + +(************************************************************************) +(****************************** Predicates ******************************) +(************************************************************************) + +let is_num_write g f v = + [v] |> writes g + |> List.length + |> f + +let undef_ks = fun g -> filter_kvars (is_num_write g ((=) 0)) g +let multi_wr_ks = fun g -> filter_kvars (is_num_write g ((<) 1)) g +let single_wr_ks = fun g -> filter_kvars (is_num_write g ((=) 1)) g + +let cone_nodes g = + g |> vertices_of_graph + |> List.filter C.is_conc_refa + |> pre_star g + +(*************************************************************************) +(******************************* API *************************************) +(*************************************************************************) + +let print_ks s ks = + ks |> Misc.map_partial (function C.Kvar (_,k) -> Some k | _ -> None) + |> Format.printf "[KVG] %s %a \n" s (Misc.pprint_many false "," Sy.print) + +(* API *) +let is_single_wr = fun g -> is_num_write g ((=) 1) +let is_single_rd = fun g -> G.succ_e g <+> Misc.groupby (snd3 <+> fst) <+> List.for_all (function [_] -> true | _ -> false) + +(* API *) +let empty = G.empty +let add = List.fold_left (fun g -> List.fold_left G.add_edge_e g <.> edges_of_t) +let remove = List.fold_left G.remove_vertex + +(* API *) +let cone_ks g = + g |> cone_nodes + |> List.filter (not <.> C.is_conc_refa) + +(* API *) +let cone_ids g = + g |> cone_nodes + |> writes g + +(* API *) +let print_stats g = + g >> dump_graph (!Constants.save_file^".dot") + >> (single_wr_ks <+> print_ks "single write kvs:") + >> (multi_wr_ks <+> print_ks "multi write kvs:") + >> (undef_ks <+> print_ks "undefined kvs:") + >> (cone_ks <+> print_ks "cone kvs:") + |> ignore diff --git a/external/fixpoint/kvgraph.mli b/external/fixpoint/kvgraph.mli new file mode 100644 --- /dev/null +++ b/external/fixpoint/kvgraph.mli @@ -0,0 +1,37 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + *) + +type t + +type rd = Bnd of Ast.Symbol.t * Ast.Subst.t | Lhs of Ast.Subst.t | Grd | Junk + +val empty : t +val remove : t -> FixConstraint.refa list -> t +val add : t -> FixConstraint.t list -> t +val print_stats : t -> unit +val cone_ids : t -> FixConstraint.id list +val writes : t -> FixConstraint.refa list -> FixConstraint.id list +val reads : t -> FixConstraint.refa list -> FixConstraint.id list +val k_reads : t -> FixConstraint.id -> FixConstraint.refa -> rd list +val filter_kvars : (FixConstraint.refa -> bool) -> t -> FixConstraint.refa list +val is_single_wr : t -> FixConstraint.refa -> bool +val is_single_rd : t -> FixConstraint.refa -> bool diff --git a/external/fixpoint/predAbs.ml b/external/fixpoint/predAbs.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/predAbs.ml @@ -0,0 +1,839 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + *) + + +(*************************************************************) +(******************** Solution Management ********************) +(*************************************************************) + +module F = Format +module A = Ast +module E = A.Expression +module P = A.Predicate + +module Q = Qualifier +module QS = Q.QSet +module Sy = A.Symbol +module Su = A.Subst +module SM = Sy.SMap +module SS = Sy.SSet +module C = FixConstraint + +module BS = BNstats +module Co = Constants +module Cg = FixConfig +module H = Hashtbl +module PH = A.Predicate.Hash + +module CX = Counterexample +module Misc = FixMisc +module IM = Misc.IntMap +open Misc.Ops + +let mydebug = false + +module Q2S = Misc.ESet (struct + type t = Sy.t * Sy.t + let compare x y = compare x y +end) + +module V : Graph.Sig.COMPARABLE with type t = Sy.t = struct + type t = Sy.t + let hash = Sy.to_string <+> H.hash + let compare = compare + let equal = (=) +end + + + +(* +let tag_of_qual2 = Misc.map_pair tag_of_qual + +module Q2S = Misc.ESet (struct + type t = Q.t * Q.t + let compare x y = compare (tag_of_qual2 x) (tag_of_qual2 y) +end) + +module V : Graph.Sig.COMPARABLE with type t = Q.t = struct + type t = Q.t + let hash = tag_of_qual <+> H.hash + let compare = fun q1 q2 -> compare (tag_of_qual q1) (tag_of_qual q2) + let equal = fun q1 q2 -> tag_of_qual q1 = tag_of_qual q2 +end + +*) + +module Id : Graph.Sig.ORDERED_TYPE_DFT with type t = unit = struct + type t = unit + let default = () + let compare = compare +end + +module G = Graph.Persistent.Digraph.ConcreteLabeled(V)(Id) +module SCC = Graph.Components.Make(G) + +type bind = Q.t list + +type t = + { tpc : ProverArch.prover + ; m : bind SM.t + ; assm : FixConstraint.soln (* invariant assumption for K, + must be a fixpoint wrt constraints *) + ; qm : Q.t SM.t (* map from names to qualifiers *) + ; qleqs: Q2S.t (* (q1,q2) \in qleqs implies q1 => q2 *) + + (* counterexamples *) + ; step : CX.step (* which iteration *) + ; ctrace : CX.ctrace + ; lifespan : CX.lifespan + + (* stats *) + ; stat_simple_refines : int ref + ; stat_tp_refines : int ref + ; stat_imp_queries : int ref + ; stat_valid_queries : int ref + ; stat_matches : int ref + ; stat_umatches : int ref + ; stat_unsatLHS : int ref + ; stat_emptyRHS : int ref +} + +let pprint_ps = + Misc.pprint_many false ";" P.print + + +let pprint_dep ppf q = + F.fprintf ppf "(%a, %a)" P.print (Q.pred_of_t q) Q.print_args q + +let pprint_ds = + Misc.pprint_many false ";" pprint_dep + +let pprint_qs ppf = + F.fprintf ppf "[%a]" (Misc.pprint_many false ";" Q.print) + +let pprint_qs' ppf = + List.map (fst <+> snd <+> snd <+> fst) <+> pprint_qs ppf + +(*************************************************************) +(************* Breadcrumbs for Cex Generation ****************) +(*************************************************************) + +let cx_iter c me = + { me with step = me.step + 1 } + +let cx_ctrace b c me = + let _ = if mydebug then F.printf "\nPredAbs.refine iter = %d cid = %d b = %b\n" + me.step (C.id_of_t c) b in + if b then { me with ctrace = IM.adds (C.id_of_t c) [me.step] me.ctrace } else me + +let cx_update ks kqsm' me : t = + List.fold_left begin fun me k -> + let qs = QS.of_list (SM.finds k me.m) in + let qs' = QS.of_list (SM.finds k kqsm') in + let kills = QS.elements (QS.diff qs qs') in + if Misc.nonnull kills + then {me with lifespan = SM.adds k [(me.step, kills)] me.lifespan} + else me + end me ks + +(*************************************************************) +(************* Constructing Initial Solution *****************) +(*************************************************************) + +(* + +let def_of_pred_qual (p, q) = + let qp = Q.pred_of_t q in + match A.unify_pred qp p with + | Some su -> (p, q, su) + | None -> assertf "ERROR: unify q=%s p=%s" (P.to_string qp) (P.to_string p) + +let map_of_bindings bs = + List.fold_left begin fun s (k, ds) -> + ds |> List.map Misc.single + |> Misc.flip (SM.add k) s + end SM.empty bs +*) + +let quals_of_bindings bm = + bm |> SM.range + |> Misc.flatten + (* |> Misc.map (snd <+> fst) *) + |> Misc.sort_and_compact + >> (fun qs -> Co.bprintf mydebug "Quals of Bindings: \n%a" (Misc.pprint_many true "\n" Q.print) qs; flush stdout) + +(************************************************************************) +(*************************** Dumping to Dot *****************************) +(************************************************************************) + + +module DotGraph = struct + type t = G.t + module V = G.V + module E = G.E + let iter_vertex = G.iter_vertex + let iter_edges_e = G.iter_edges_e + let graph_attributes = fun _ -> [`Size (11.0, 8.5); `Ratio (`Fill (* Float 1.29*))] + let default_vertex_attributes = fun _ -> [`Shape `Box] + let vertex_name = Sy.to_string + let vertex_attributes = fun q -> [`Label (Sy.to_string q)] + let default_edge_attributes = fun _ -> [] + let edge_attributes = fun (_,(),_) -> [] + let get_subgraph = fun _ -> None +end + +module Dot = Graph.Graphviz.Dot(DotGraph) + +let dump_graph s g = + s |> open_out + >> (fun oc -> Dot.output_graph oc g) + |> close_out + +let p_read s k = + let _ = asserts (SM.mem k s.m) "ERROR: p_read : unknown kvar %s\n" (Sy.to_string k) in + SM.find k s.m |>: (fun q -> ((k, q), Q.pred_of_t q)) + +(* INV: qs' \subseteq qs *) +let update m k ds' = + let ds = SM.finds k m in + let n = List.length ds in + let n' = List.length ds' in + let _ = asserts (n = 0 || n' <= n) "PredAbs.update: Non-monotone k = %s |ds| = %d |ds'| = %d \n" (Sy.to_string k) n n' in + ((n != n'), SM.add k ds' m) + (* >> begin fun _ -> + if n' > n && n > 0 then + Co.bprintflush mydebug <| Printf.sprintf "OMFG: update k = %s |ds| = %d |ds'| = %d \n" + (Sy.to_string k) n n' + end + *) + +(* We must ensure there are NO duplicate k-q pairs in the update list. + * If there are duplicate KVars in the ks then the kqs must be grouped: + * a "k-q" binding is ONLY preserved IF #bindings = #copies-of-k + * If there are NO duplicate KVars there SHOULD BE no duplicate k-q pairs. *) + +let group_ks_kqs ks kqs = + if (Misc.cardinality ks = List.length ks) then + kqs (* no duplicate kvars *) + else + let km = SM.frequency ks in + kqs |> Misc.frequency + |> Misc.filter (fun ((k, _), n) -> n = SM.find_default 0 k km) + |> Misc.map fst + +let p_update me ks kqs = + (* let _ = Co.bprintflush mydebug (Printf.sprintf "p_update A: |kqs| = %d \n" (List.length kqs)) in *) + let kqs = group_ks_kqs ks kqs in + (* let _ = Co.bprintflush mydebug (Printf.sprintf "p_update B: |kqs| = %d \n" (List.length kqs)) in *) + let kqsm = SM.of_alist kqs in + let me = me |> (!Co.cex BS.time "cx_update" (cx_update ks) kqsm) in + List.fold_left begin fun (b, m) k -> + SM.finds k kqsm + |> update m k + |> Misc.app_fst ((||) b) + end (false, me.m) ks + |> Misc.app_snd (fun m -> { me with m = m }) + + +(* API *) +let top s ks = + ks (* |> List.partition (fun k -> SM.mem k s.m) + >> (fun (_, badks) -> Co.bprintf mydebug "WARNING: Trueing Unbound KVars = %s \n" (Misc.fsprintf (Misc.pprint_many false "," Sy.print) badks)) + |> fst *) + |> Misc.flip (p_update s) [] + |> snd + +(***************************************************************) +(************************** Refinement *************************) +(***************************************************************) + +let rhs_cands s = function + | C.Kvar (su, k) -> k (* >> (fun k -> Co.bprintflush mydebug ("rhs_cands: k = "^(Sy.to_string k)^"\n")) *) + |> p_read s + (* >> (fun xs -> Co.bprintflush mydebug ("rhs_cands: size="^(string_of_int (List.length xs))^" BEGIN \n")) *) + |>: (Misc.app_snd (Misc.flip A.substs_pred su)) + (* >> (fun xs -> Co.bprintflush mydebug ("rhs_cands: size="^(string_of_int (List.length xs))^" DONE\n")) *) + | _ -> [] + +let check_tp me env vv t lps = function [] -> [] | rcs -> + (* let rv = TP.set_filter me.tpc env vv lps rcs in + let _ = ignore(me.stat_tp_refines += 1) + ; ignore(me.stat_imp_queries += (List.length rcs)) + ; ignore(me.stat_valid_queries += (List.length rv)) + in rv *) + me.tpc#set_filter env vv lps rcs + >> (fun _ -> me.stat_tp_refines += 1) + >> (fun _ -> me.stat_imp_queries += List.length rcs) + >> (fun rv -> me.stat_valid_queries += List.length rv) + + + + +(* API *) +let read me k = (me.assm k) ++ (if SM.mem k me.m then p_read me k |>: snd else []) + +(* API *) +let read_bind s k = failwith "PredAbs.read_bind" + +let refine me c = + let (_,_,ra2s) as r2 = C.rhs_of_t c in + let k2s = r2 |> C.kvars_of_reft |> List.map snd in + let rcs = BS.time "rhs_cands" (Misc.flap (rhs_cands me)) ra2s in + if rcs = [] then + let _ = me.stat_emptyRHS += 1 in + (false, me) + else + let lps = BS.time "preds_of_lhs" (C.preds_of_lhs (read me)) c in + if BS.time "lhs_contra" (List.exists P.is_contra) lps then + let _ = me.stat_unsatLHS += 1 in + let _ = me.stat_umatches += List.length rcs in + (false, me) + else + let rcs = List.filter (fun (_,p) -> not (P.is_contra p)) rcs in + let lt = PH.create 17 in + let _ = List.iter (fun p -> PH.add lt p ()) lps in + let (x1,x2) = List.partition (fun (_,p) -> PH.mem lt p) rcs in + let _ = me.stat_matches += (List.length x1) in + let kqs1 = List.map fst x1 in + (if C.is_simple c + then (ignore(me.stat_simple_refines += 1); kqs1) + else let senv = C.senv_of_t c in + let vv = C.vv_of_t c in + let t = C.sort_of_t c in + kqs1 ++ (BS.time "check tp" (check_tp me senv vv t lps) x2)) + |> p_update me k2s + +let refine me c = + let me = me |> (!Co.cex cx_iter c) in + let (b, me) = refine me c in + let me = me |> (!Co.cex cx_ctrace b c) in + (b, me) + + +(***************************************************************) +(****************** Sort Check Based Refinement ****************) +(***************************************************************) + +let refts_of_c c = + [ C.lhs_of_t c ; C.rhs_of_t c] ++ (C.env_of_t c |> C.bindings_of_env |>: snd) + +let refine_sort_reft env me ((vv, so, ras) as r) = + let env' = SM.add vv r env in + let ks = r |> C.kvars_of_reft |>: snd in + (* let _ = let s = String.concat ", " (List.map Sy.to_string ks) in Co.bprintflush mydebug ("\n refine_sort_reft ks = "^s^"\n") in *) + ras + |> Misc.flap (rhs_cands me) (* OMFG blowup due to FLAP if kv appears multiple times...*) + |> Misc.filter (fun (_, p) -> C.wellformed_pred env' p) + |> List.rev_map fst +(* |> (fun xs -> Co.bprintflush mydebug (Printf.sprintf "refine_sort_reft map: size = %d\n" (List.length xs)); + List.rev_map fst xs) + >> (fun _ -> Co.bprintflush mydebug "\n refine_sort_reft TICK 4 \n") + *) + |> p_update me ks + |> snd + +let refine_sort me c = + let env = C.env_of_t c in + c (* >> (fun _ -> Co.bprintflush mydebug ("\n refine_sort TICK 0 id = "^(string_of_int (C.id_of_t c))^"\n")) *) + |> refts_of_c + |> List.fold_left (refine_sort_reft env) me + (* >> (fun _ -> Co.bprintflush mydebug "\n refine_sort TICK 2 \n") *) + +(***************************************************************) +(************************* Satisfaction ************************) +(***************************************************************) + +let unsat me c = + let s = read me in + let (vv,t,_) = C.lhs_of_t c in + let lps = C.preds_of_lhs s c in + let rhsp = c |> C.rhs_of_t |> C.preds_of_reft s |> A.pAnd in + let k = Sy.of_string "k" in + let kq = (k, Q.create k k Ast.Sort.t_int [] A.pTrue) in + not ((check_tp me (C.senv_of_t c) vv t lps [(kq, rhsp)]) = [kq]) + +(****************************************************************) +(************* Minimization: For Prettier Output ****************) +(****************************************************************) + +(* +let canonize_subs = + Su.to_list <+> List.sort (fun (x,_) (y,_) -> compare x y) + +let subst_leq = + Misc.map_pair canonize_subs <+> Misc.isPrefix +*) + +let args_leq q1 q2 = + let xe1s, xe2s = (Q.args_of_t q1, Q.args_of_t q2) in + let xe1e2s = Misc.join fst xe1s xe2s in + List.for_all (fun ((_,e1),(_,e2)) -> e1 = e2) xe1e2s + +(* P(v,x,y,z) => Q(v,x) if P => Q held and _intersection_ of args match. *) +let def_leq s q1 q2 = + Q2S.mem (Q.name_of_t q1, Q.name_of_t q2) s.qleqs && args_leq q1 q2 + +let pred_of_bind_name q = + let name = q |> Q.name_of_t in + let args = q |> Q.args_of_t |> List.map snd in + A.pBexp (A.eApp (name, args)) + +let pred_of_bind_raw = Q.pred_of_t + +let pred_of_bind q = + if !Co.shortannots + then pred_of_bind_name q + else pred_of_bind_raw q + +let min_binds_bot ds = + match Misc.list_find_maybe (P.is_contra <.> pred_of_bind_raw) ds with + | None -> ds + | Some d -> [d] + +(* API *) +let min_binds s ds = ds |> min_binds_bot |> Misc.rootsBy (def_leq s) +let min_read s k = SM.finds k s.m |> min_binds s |>: pred_of_bind +let min_read s k = if !Co.minquals then min_read s k else read s k +let min_read s k = BS.time "min_read" (min_read s) k + +let close_env qs sm = + qs |> Misc.flap (Q.pred_of_t <+> P.support) + |> Misc.filter (not <.> Misc.flip SM.mem sm) + |> Misc.map (fun x -> (x, Ast.Sort.t_int)) + |> SM.of_list + |> SM.extend sm + +let rename_vv q q' = + List.combine (Q.all_params_of_t q |>: fst) (Q.all_params_of_t q' |>: fst) + |> List.filter (fun (x, y) -> not (x = y)) + |> List.map (fun (x, y) -> (y, A.eVar x)) + |> Su.of_list + |> A.substs_pred (Q.pred_of_t q') + |> (fun p' -> (q', p')) + +let sm_of_qual sm q = + q |> Q.all_params_of_t + |> SM.of_list + |> SM.extend sm + +(* check_leq tp sm q qs = [q' | q' <- qs, Z3 |- q => q'] *) +let check_leq (tp : ProverArch.prover) sm (q : Q.t) (qs : Q.t list) : Q.t list = + let vv = Q.vv_of_t q in + let lps = [Q.pred_of_t q] in + let sm = q |> sm_of_qual sm |> close_env qs in + qs |> List.map (rename_vv q) (* (fun q -> (q, Q.pred_of_t q)) *) + (* >> (List.map fst <+> F.printf "CHECK_TP: %a IN %a \n" Q.print q pprint_qs) *) + |> tp#set_filter sm vv lps + (* >> F.printf "CHECK_TP: %a OUT %a \n" Q.print q pprint_qs *) + +let qimps_of_partition tp sm qs = + foreach qs begin fun q -> + let qs' = check_leq tp sm q qs in + foreach qs' begin fun q' -> + (q, q') + end + end + +let wellformed_qual sm q = + let sm = sm_of_qual sm q in + A.sortcheck_pred Theories.is_interp (fun x -> SM.maybe_find x sm) (Q.pred_of_t q) + +let qleqs_of_qs ts sm cs ps qs = + let tp = TpNull.create ts sm cs ps in + qs |> Misc.filter (wellformed_qual sm) + |> Misc.groupby (List.map snd <.> Q.all_params_of_t) (* Q.sort_of_t *) + |> Misc.flap (qimps_of_partition tp sm) + |> Misc.flatten + |> Misc.map (Misc.map_pair Q.name_of_t) + |> Q2S.of_list + +(***************************************************************) +(******************** Qualifier Instantiation ******************) +(***************************************************************) + +type qual_binding = (Sy.t * Sy.t) list + +(* DEBUG ONLY *) +let print_param ppf (x, t) = + F.fprintf ppf "%a:%a" Sy.print x Ast.Sort.print t +let print_params ppf args = + F.fprintf ppf "%a" (Misc.pprint_many false ", " print_param) args +let print_valid_binding ppf (x,y) = + F.fprintf ppf "[%a := %a]" Sy.print x Sy.print y +let print_valid_bindings ppf xys = + F.printf "[%a]" (Misc.pprint_many false "" print_valid_binding) xys + +(* +let dupfree_binding xys : bool = + let ys = List.map snd xys in + let ys' = Misc.sort_and_compact ys in + List.length ys = List.length ys' +*) + +let varmatch_ctr = ref 0 + +let varmatch (x, y) = + let _ = varmatch_ctr += 1 in + let (x,y) = Misc.map_pair Sy.to_string (x,y) in + if x.[0] = '@' then + let x' = Misc.suffix_of_string x 1 in + Misc.is_prefix x' y + else true + +let sort_compat t1 t2 = A.Sort.unify [t1] [t2] <> None + +(* {{{ DONT DELETE FOR NOW let valid_bindings_sort env (x, t) = + let _ = failwith "valid_bindings_sort: slow AND incorrect. suppressed!" in + env |> SM.to_list + |> Misc.filter (snd <+> C.sort_of_reft <+> (sort_compat t)) + |> Misc.map (fun (y,_) -> (x, y)) + |> Misc.filter varmatch + +let valid_bindings env ys (x, t) = + if !Co.sorted_quals + then valid_bindings_sort env (x, t) + else valid_bindings ys x +}}} *) + +let wellformed_qual wf f q = + q |> Q.pred_of_t + |> A.sortcheck_pred Theories.is_interp f + (* >> (F.printf "\nwellformed: id = %d q = @[%a@] result %b\n" (C.id_of_wf wf) Q.print q) *) + (* NEVER uncomment out the above. *) + +(********************************************************************************) +(****** Brute Force (Post-Selection based) Qualifier Instantiation **************) +(********************************************************************************) + +let is_valid_binding (xys : qual_binding) : bool = + List.for_all varmatch xys + +let valid_bindings ys (x,_) = + ys |> List.map (fun y -> (x, y)) + |> List.filter varmatch + +let inst_qual env ys evv (q : Q.t) : Q.t list = + let vve = (Q.vv_of_t q, evv) in + match Q.params_of_t q with + | [] -> + [(Q.inst q [vve])] + | xts -> + xts + (* >> F.printf "\n\ninst_qual: params q = %a: %a" Q.print q print_params *) + |> List.map (valid_bindings ys) (* candidate bindings *) + |> Misc.product (* generate combinations *) + (* >> (List.iter (F.printf "\ninst_qual: pre-binds = %a\n" print_valid_bindings)) *) + |> List.filter is_valid_binding (* remove bogus bindings *) + (* >> (List.iter (F.printf "\ninst_qual: post-binds = %a\n" print_valid_bindings)) *) + |> List.rev_map (List.map (Misc.app_snd A.eVar)) (* instantiations *) + |> List.rev_map (fun xes -> Q.inst q (vve::xes)) (* quals *) + (* >> (F.printf "\n\ninst_qual: result q = %a:\n%a DONE\n" Q.print q (Misc.pprint_many true "" Q.print)) *) + +let inst_vars env = + env |> Sy.SMap.to_list + |> List.filter (fun (_, (_,so,_)) -> not (A.Sort.is_func so)) + |> List.map fst + +let inst_ext qs wf = + let _ = Misc.display_tick () in + let r = C.reft_of_wf wf in + let ks = C.kvars_of_reft r |> List.map snd in + let env = C.env_of_wf wf in + let vv = fst3 r in + let t = snd3 r in + let ys = inst_vars env in + let env' = Misc.maybe_map C.sort_of_reft <.> C.lookup_env (SM.add vv r env) in + qs |> List.filter (Q.sort_of_t <+> sort_compat t) + |> Misc.flap (inst_qual env ys (A.eVar vv)) + |> Misc.filter (wellformed_qual wf env' <&&> C.filter_of_wf wf) + |> Misc.cross_product ks + +(********************************************************************************) +(****** Sort Based Qualifier Instantiation **************************************) +(********************************************************************************) + +let inst_binds env = + env |> SM.to_list + |> Misc.map (Misc.app_snd snd3) + |> Misc.filter (not <.> A.Sort.is_func <.> snd) + +(* [ (su', (x,y) : xys) | (su, xys) <- wkl + , (y, ty) <- yts + , varmatch (x, y) + , Some su' <- unifyWith su [tx] [ty] ] *) + +let ext_bindings yts wkl (x, tx) = + let yts = List.filter (fun (y,_) -> varmatch (x, y)) yts in + Misc.tr_rev_flap (fun (su, xys) -> + Misc.map_partial (fun (y, ty) -> + match A.Sort.unifyWith su [tx] [ty] with + | None -> None + | Some su' -> Some (su', (x,y) :: xys) + ) yts + ) wkl + +let inst_qual_sorted yts vv t q = + let (qvv0, t0) :: xts = Q.all_params_of_t q in + match A.Sort.unify [t0] [t] with + | Some su0 -> + xts |> List.fold_left (ext_bindings yts) [(su0, [(qvv0, vv)])] (* generate subs-bindings *) + |> List.rev_map (List.rev <.> snd) (* extract sorted bindings *) + |> List.rev_map (List.map (Misc.app_snd A.eVar)) (* instantiations *) + |> List.rev_map (Q.inst q) (* quals *) + | None -> [] + +let inst_ext_sorted qs wf = + let _ = Misc.display_tick () in + let r = C.reft_of_wf wf in + let ks = List.map snd <| C.kvars_of_reft r in + let env = C.env_of_wf wf in + let vv = fst3 r in + let t = snd3 r in + let yts = inst_binds env in + qs |> Misc.flap (inst_qual_sorted yts vv t) + |> Misc.cross_product ks + +(*************************************************************************************) + +let inst_ext qs wf = + if !Co.sorted_quals + then inst_ext_sorted qs wf + else inst_ext qs wf + +let inst_ext qs wf = + if mydebug then + let msg = Printf.sprintf "inst_ext wf id = %d" (C.id_of_wf wf) in + Misc.trace msg (inst_ext qs) wf + >> (List.length <+> F.printf "\n\ninst_ext wfid = %d: size = %d\n" (C.id_of_wf wf)) + else inst_ext qs wf + +(* API *) +let inst ws qs = + Misc.flap (inst_ext qs) ws + |> Misc.kgroupby fst + |> Misc.map (Misc.app_snd (List.map snd)) + + + +(*************************************************************************) +(*************************** Creation ************************************) +(*************************************************************************) + +let create_qleqs ts sm ps consts qs = + if !Co.minquals + then BS.time "Annots: make qleqs" (qleqs_of_qs ts sm consts ps) qs + else Q2S.empty + +let create ts sm ps consts assm qs bm = + { m = bm + ; assm = assm + ; qm = qs |>: Misc.pad_fst Q.name_of_t |> SM.of_list + ; qleqs = Misc.with_ref_at Constants.strictsortcheck false + (fun () -> create_qleqs ts sm consts ps qs) + ; tpc = TpNull.create ts sm ps consts + + (* Counterexamples *) + ; step = 0 + ; ctrace = IM.empty + ; lifespan = SM.empty + + (* Stats *) + ; stat_simple_refines = ref 0 + ; stat_tp_refines = ref 0; stat_imp_queries = ref 0 + ; stat_valid_queries = ref 0; stat_matches = ref 0 + ; stat_umatches = ref 0; stat_unsatLHS = ref 0 + ; stat_emptyRHS = ref 0 + } + +(* RJ: DO NOT DELETE! *) +let ppBinding (k, zs) = + F.printf "ppBind %a := %a \n" + Sy.print k + (Misc.pprint_many false "," Q.print) zs + +(* Take in a solution of things that are known to be true, kf. Using + this, we can prune qualifiers whose negations are implied by + information in kf *) +let update_pruned ks me fqm = + List.fold_left begin fun m k -> + if not (SM.mem k fqm) then m else + let false_qs = SM.safeFind k fqm "update_pruned 1" in + let qs = SM.safeFind k m "update_pruned 2" + |> List.filter (fun q -> (not (List.mem (k,q) false_qs))) + in SM.add k qs m + end me.m ks + +let apply_facts_c kf me c = + let env = C.senv_of_t c in + let (vv, t, lras) = C.lhs_of_t c in + let (_,_,ras) as rhs = C.rhs_of_t c in + let ks = rhs |> C.kvars_of_reft |> List.map snd in + let lps = C.preds_of_lhs kf c in (* Use the known facts here *) + let rcs = (Misc.flap (rhs_cands me)) ras in + if rcs = [] then (* Nothing on the right hand side *) + me + else if check_tp me env vv t lps [(0, A.pFalse)] = [0] then + me + else + let rcs = List.filter (fun (_,p) -> not (P.is_contra p)) rcs + |> List.map (fun (x,p) -> (x, A.pNot p)) in + (* can we prove anything on lhs implies something on rhs is false? *) + let fqs = BS.time "apply_facts tp" (check_tp me env vv t lps) rcs in + let fqm = fqs |> Misc.kgroupby fst |> SM.of_list in + {me with m = BS.time "update pruned" (update_pruned ks me) fqm} + +let apply_facts cs kf me = + let numqs = me.m |> Ast.Symbol.SMap.to_list + |> List.map snd |> List.concat |> List.length in + let sol = List.fold_left (apply_facts_c kf) me cs in + let numqs' = sol.m |> Ast.Symbol.SMap.to_list + |> List.map snd |> List.concat |> List.length in + let _ = Printf.printf "Started with %d, proved %d false\n" numqs (numqs-numqs') in + sol + +let binds_of_quals ws qs = + qs + (* |> Q.normalize *) + >> (fun qs -> Co.bprintf mydebug "Using Quals: \n%a" (Misc.pprint_many true "\n" Q.print) qs) + >> (fun _ -> Co.bprintflush mydebug "\nBEGIN: Qualifier Instantiation\n") + |> BS.time "Qual Inst" (inst ws) + >> (fun _ -> Co.bprintflush mydebug "\nDONE: Qualifier Instantiation\n") + (* >> List.iter ppBinding *) + |> SM.of_list + >> (fun _ -> Co.bprintflush mydebug "\nDONE: Qualifier Instantiation: Built Map \n") + + +let binds_of_quals ws qs = + match !Constants.dump_simp with + | "" -> binds_of_quals ws qs (* regular solving mode *) + | _ -> SM.empty (* constraint simplification mode *) + + +(* API *) +let create c facts = + binds_of_quals c.Cg.ws c.Cg.qs + |> SM.extendWith (fun _ -> (++)) c.Cg.bm + |> create c.Cg.ts c.Cg.uops c.Cg.ps c.Cg.cons c.Cg.assm c.Cg.qs + >> (fun _ -> Co.bprintflush mydebug "\nBEGIN: refine_sort\n") + |> ((!Constants.refine_sort) Misc.flip (List.fold_left refine_sort) c.Cg.cs) + >> (fun _ -> Co.bprintflush mydebug "\nEND: refine_sort\n") + |> Misc.maybe_apply (apply_facts c.Cg.cs) facts + + + + +(* API *) +let empty = create Cg.empty None + +(* API *) +let meet me you = {me with m = SM.extendWith (fun _ -> (++)) me.m you.m} + +(****************************************************************) +(************* Simplify Solution Using min_read *****************) +(****************************************************************) + +(* let minb s bs = min_binds s bs + >> Printf.printf "minBinds: [%a] \n\n" pprint_ds + *) + +let simplify s = {s with m = SM.map (min_binds s) s.m} + +(************************************************************************) +(****************** Counterexample Generation ***************************) +(************************************************************************) + + +let ctr_examples me cs ucs = + let cx = CX.create me.tpc (read me) cs me.ctrace me.lifespan in + List.map (CX.explain cx) ucs + + +(*******************************************************************************) +(******************************** Profile/Stats ********************************) +(*******************************************************************************) + +let print_m ppf s = + SM.iter begin fun k ds -> + ds |> () (!Co.minquals) (min_binds s) + |> F.fprintf ppf "solution: %a := [%a] \n\n" Sy.print k pprint_ds + end s.m + +let print_qs ppf s = + SM.range s.qm + >> (fun _ -> F.fprintf ppf "//QUALIFIERS \n\n") + |> F.fprintf ppf "%a" (Misc.pprint_many true "\n" Q.print) +(* |> List.iter (F.fprintf ppf "%a" Q.print) + *) |> ignore + +(* API *) +let print ppf s = s >> print_m ppf >> print_qs ppf |> ignore + + +let botInt qs = if List.exists (Q.pred_of_t <+> P.is_contra) qs then 1 else 0 + +(* API *) +let print_stats ppf me = + let (sum, max, min, bot) = + (SM.fold (fun _ qs x -> (+) x (List.length qs)) me.m 0, + SM.fold (fun _ qs x -> max x (List.length qs)) me.m min_int, + SM.fold (fun _ qs x -> min x (List.length qs)) me.m max_int, + SM.fold (fun _ qs x -> x + botInt qs) me.m 0) in + let n = SM.length me.m in + let avg = (float_of_int sum) /. (float_of_int n) in + F.fprintf ppf "# Vars: (Total=%d, False=%d) Quals: (Total=%d, Avg=%f, Max=%d, Min=%d)\n" + n bot sum avg max min; + F.fprintf ppf "#Iteration Profile = (si=%d tp=%d unsatLHS=%d emptyRHS=%d) \n" + !(me.stat_simple_refines) !(me.stat_tp_refines) + !(me.stat_unsatLHS) !(me.stat_emptyRHS); + F.fprintf ppf "#Queries: umatch=%d, match=%d, ask=%d, valid=%d\n" + !(me.stat_umatches) !(me.stat_matches) !(me.stat_imp_queries) + !(me.stat_valid_queries); + me.tpc#print_stats ppf + +(* API *) +let save fname s = + let oc = open_out fname in + let ppf = F.formatter_of_out_channel oc in + F.fprintf ppf "@[%a@] \n" print s; + close_out oc + +let key_of_quals qs = + qs |> List.map P.to_string + |> List.sort compare + |> String.concat "," + +(* API *) +let mkbind = id (* Misc.flatten <+> Misc.sort_and_compact *) + +(* API *) +let dump s = + s.m + |> SM.to_list + |> List.map (snd <+> List.map Q.pred_of_t) + |> Misc.groupby key_of_quals + |> List.map begin function + | [] -> assertf "impossible" + | (ps::_ as pss) -> Co.bprintf mydebug "SolnCluster: preds %d = size %d \n" (List.length ps) (List.length pss) + end + |> ignore + + diff --git a/external/fixpoint/predAbs.mli b/external/fixpoint/predAbs.mli new file mode 100644 --- /dev/null +++ b/external/fixpoint/predAbs.mli @@ -0,0 +1,16 @@ +(* + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +include SolverArch.DOMAIN diff --git a/external/fixpoint/prepass.ml b/external/fixpoint/prepass.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/prepass.ml @@ -0,0 +1,238 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + *) + + +(** This module implements various constraint validation and simplification + * prepasses *) + +module BS = BNstats +module F = Format +module A = Ast +module Co = Constants +module P = A.Predicate +module E = A.Expression +module So = A.Sort +module Q = Qualifier +module PH = A.Predicate.Hash +module Sy = A.Symbol +module SM = Sy.SMap +module C = FixConstraint + +module Misc = FixMisc +module IM = Misc.IntMap + +open Misc.Ops +let mydebug = false + +(***************************************************************) +(*********** Input Constraint & Solution Validation ************) +(***************************************************************) + + +(* 3a. check that lhs/rhs have same sort *) +let phase3a = + List.iter begin fun c -> + let (vv1,t1,_) = C.lhs_of_t c in + let (vv2,t2,_) = C.rhs_of_t c in + if not (vv1 = vv2 && t1 = t2) then + let msg = "Invalid Constraints 3a (LHS/RHS sort mismatch)" in + let _ = Format.printf "%s in \n %a " msg (C.print_t None) c in + raise (C.BadConstraint (C.id_of_t c, C.tag_of_t c, msg)) + end + +(* 3b. check that sorts are consistent across constraints. + * DEPRECATED, due to the following counterexample. + * Suppose you have a function: + + concatMap :: forall a, t. (a -> [t]) -> [a] -> [t] + concatMap f [] = [] + concatMap f (y:ys) = (f y) ++ (concatMap f ys) + + * Now, "f" gets a template + + (y:a) -> [t] + + * And inside the body of concatMap, the recursive call + * creates a function subtyping on "f" + + ... |- (y:a) -> [t] <: (y:a) -> t + + * which after splitting gives a constraint + + ...,(y:a) |- t <: t (1) + + * Now, suppose you have a call to concatMap + + baz = concatMap (\x -> [x]) + + * Here, concatMap is actually "instantiated" with a + * different type variable, so at this instance, + + concatMap :: ((y:b) -> [b]) -> [b] -> [b] + + * That is, a, t are instantiated with b, b. Now, the + * application creates another function subtyping, and + * this time you end up with + + ...,(y:b) |- b <: b (2) + +let phase3b cs = + let memo = Hashtbl.create 17 in + List.iter begin fun c -> + let env = C.env_of_t c in + let id = C.id_of_t c in + SM.iter begin fun x (_,t,_) -> + if Hashtbl.mem memo x then + let xt = Hashtbl.find memo x in + asserts (t = xt) "Invalid Constraints 3b: %d (%s is %s and %s)" + id (Sy.to_string x) (So.to_string t) (So.to_string xt) + else + Hashtbl.replace memo x t + end env + end cs +*) + +(* 4. check that each tag has the same arity [a] *) +let phase4 a = + List.iter begin fun c -> + if (a = List.length (fst (C.tag_of_t c))) then () else + raise (C.BadConstraint (C.id_of_t c, C.tag_of_t c, "Tag Arity Error")) + end + +(* 5. check that all refinements are well-formed *) +let validate_vars env msg vs = + List.iter begin fun v -> + if not (SM.mem v env) then + let _ = F.printf "ERROR: out_of_scope variable %a (%s)" Sy.print v (Lazy.force msg) in + failwith ("Out_of_scope: "^(Sy.to_string v)) + end vs + +let validate_pred env msg p = + P.support p + |> BS.time "validate_vars" (validate_vars env msg) + +let validate_reft s env msg ((vv,t,_) as r) = + let env = SM.add vv t env in + r |> BS.time "preds_of_reft" (C.preds_of_reft s) + |> List.iter (validate_pred env msg) + +let phase5 s cs = + Misc.filter begin fun c -> + try + let msg = C.to_string c in + let env = C.senv_of_t c in + let rhs = C.rhs_of_t c in + List.iter (validate_pred env (lazy (msg^" BAD LHS"))) (C.preds_of_lhs s c); + BS.time "valid rhs" (validate_reft s env (lazy (msg^"\n BAD RHS"))) rhs; + true + with ex -> begin + let id = C.id_of_t c in + let tag = C.tag_of_t c in + let msg = Printexc.to_string ex in + Format.printf "Phase5: exn = %s on constraint: %a \n" msg (C.print_t None) c; + raise (C.BadConstraint (id, tag, msg)) + end + end cs + + +(* API *) +let validate a s cs = + cs >> phase3a + (* >> phase3b : RJ: this invariant need not hold! *) + >> phase4 a + |> phase5 s + |> (fun cs' -> asserts (List.length cs = List.length cs') "Validation") + +(******************************************************************************) +(******************* Validating Well-Formedness Constraints *******************) +(******************************************************************************) + +let validate_wf wfvs = + C.reft_of_wf + <+> C.kvars_of_reft + <+> List.fold_left (fun wfvars (_, k) -> Sy.SSet.add k wfvars) wfvs + (* if Sy.SSet.mem k wfvars then + let _ = F.printf "ERROR: variable %a is checked for WF twice\n" Sy.print k in + assert false + else *) + +(* API *) +let validate_wfs ws = + ws |> List.fold_left begin fun (ws, wfvars) wf -> + (wf :: ws, validate_wf wfvars wf) + end ([], Sy.SSet.empty) + |> fst + + +(***************************************************************) +(*********************** Constraint Profiling *****************) +(***************************************************************) + +let profile_cstr im c = + SM.fold begin fun _ (_,_,rs) ((a, b, c, d) as pfl) -> + match rs with [] -> (a+1, b, c, d+1) | _::_ -> begin + List.fold_left begin fun (sz, csz, ksz, esz) r -> match r with + | C.Conc _ -> (sz+1, csz+1, ksz, esz) + | _ -> (sz+1, csz, ksz+1, esz) + end pfl rs + end + end (C.env_of_t c) (0,0,0,0) + |> fun pfl -> IM.add (C.id_of_t c) pfl im + +let dump_profile im = + let (tsz, tcsz, tksz, tesz) = + IM.fold begin fun i (sz, csz, ksz, esz) (tsz, tcsz, tksz, tesz) -> + Co.bprintf mydebug + "ctag %d: binds=%d, cbinds=%d, kbinds=%d, ebinds=%d \n" + i sz csz ksz esz; + (tsz + sz, tcsz + csz, tksz + ksz, tesz + esz) + end im (0,0,0,0) in + Co.bprintf mydebug + "Total binds=%d, cbinds=%d, kbinds=%d, ebinds=%d \n" + tsz tcsz tksz tesz + +let profile1 sri = + sri |> Cindex.to_list + |> List.fold_left profile_cstr IM.empty + |> dump_profile + +let key_of_cstr c = + c |> C.env_of_t + |> C.bindings_of_env + |> List.map fst + |> List.map Sy.to_string + |> List.sort compare + |> String.concat "," + +let profile2 sri = + sri |> Cindex.to_list + |> Misc.groupby key_of_cstr + |> List.length + |> fun n -> Co.bprintf mydebug "Constraint Clusters = %d \n" n + +(* API *) +let profile sri = + sri + >> profile1 + >> profile2 + |> ignore + diff --git a/external/fixpoint/prepass.mli b/external/fixpoint/prepass.mli new file mode 100644 --- /dev/null +++ b/external/fixpoint/prepass.mli @@ -0,0 +1,31 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + *) + + +(** This module implements various constraint validation and simplification + * prepasses *) + +val validate : int -> FixConstraint.soln -> FixConstraint.t list -> unit +val validate_wfs : FixConstraint.wf list -> FixConstraint.wf list +(* val true_unconstrained : FixSolution.t -> Cindex.t -> FixSolution.t +*) +val profile : Cindex.t -> unit diff --git a/external/fixpoint/proverArch.ml b/external/fixpoint/proverArch.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/proverArch.ml @@ -0,0 +1,196 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + *) + +(* Theories API *) + +module type THEORY = sig + type context + type sort + type ast + type appDef + type sortDef + + val sym_sort : appDef -> Ast.Sort.t + val sym_name : appDef -> Ast.Symbol.t + val sort_name : sortDef -> Ast.Sort.tycon + val mk_thy_sort : sortDef -> context -> sort list -> sort + val mk_thy_app : appDef -> context -> sort list -> ast list -> ast + val theories : sortDef list * appDef list +end + +module type SMTSOLVER = sig + + (* Types *) + type context + type symbol + type ast + type sort + type fun_decl + + (* Expression *) + val mkAll : context -> sort array -> symbol array -> ast -> ast + val mkApp : context -> fun_decl -> ast list -> ast + val mkMul : context -> ast -> ast -> ast + val mkAdd : context -> ast -> ast -> ast + val mkSub : context -> ast -> ast -> ast + val mkMod : context -> ast -> ast -> ast + + (* Predicates *) + val mkIte : context -> ast -> ast -> ast -> ast + val mkInt : context -> int -> sort -> ast + val mkTrue : context -> ast + val mkFalse : context -> ast + val mkNot : context -> ast -> ast + val mkAnd : context -> ast list -> ast + val mkOr : context -> ast list -> ast + val mkImp : context -> ast -> ast -> ast + val mkIff : context -> ast -> ast -> ast + val mkRel : context -> Ast.brel -> ast -> ast -> ast + + (* Conversions *) + val astString : context -> ast -> string + + (* Set Theory Operations *) + val mkSetSort : context -> sort -> sort + val mkEmptySet : context -> sort -> ast + val mkSetAdd : context -> ast -> ast -> ast + val mkSetMem : context -> ast -> ast -> ast + val mkSetCup : context -> ast -> ast -> ast + val mkSetCap : context -> ast -> ast -> ast + val mkSetDif : context -> ast -> ast -> ast + val mkSetSub : context -> ast -> ast -> ast + + (* Constructors *) + val mkContext : (string * string) array -> context + val mkIntSort : context -> sort + val mkBoolSort : context -> sort + val var : context -> symbol -> sort -> ast + val boundVar : context -> int -> sort -> ast + val stringSymbol : context -> string -> symbol + val funcDecl : context -> symbol -> sort array -> sort -> fun_decl + val isBool : context -> ast -> bool + + (* Queries *) + val bracket : context -> (unit -> 'a) -> 'a + val assertAxiom : context -> ast -> unit + val assertPreds : context -> ast list -> unit + val assertDistinct : context -> ast list -> unit + val unsat : context -> bool + + (* Stats *) + val print_stats : Format.formatter -> unit -> unit +end + +class type prover = + object + (* AST/TC Interface *) + method interp_syms : (Ast.Symbol.t * Ast.Sort.t) list + + (* Query Interface *) + method set_filter : 'a . Ast.Sort.t Ast.Symbol.SMap.t + -> Ast.Symbol.t + -> Ast.pred list + -> ('a * Ast.pred) list + -> 'a list + + + (* method set_filter : Ast.Sort.t Ast.Symbol.SMap.t + -> Ast.Symbol.t + -> Ast.pred list + -> ((Ast.Symbol.t * Qualifier.t) * Ast.pred) list + -> (Ast.Symbol.t * Qualifier.t) list + *) + + method print_stats : Format.formatter -> unit + + (* Counterexample Interface *) + method is_contra : Ast.Sort.t Ast.Symbol.SMap.t + -> Ast.pred + -> bool + + + method unsat_suffix : Ast.Sort.t Ast.Symbol.SMap.t + -> Ast.pred (* background predicate *) + -> Ast.pred list (* [p0,...,pn] *) + -> int option (* max j st. p /\i=j..n pi unsat *) + + (* method unsat_core : Ast.Sort.t Ast.Symbol.SMap.t + -> Ast.pred (* background predicate *) + -> ('a * Ast.pred) list (* [(index, killer-fact)] *) + -> 'a list (* [unsat-core-index] *) + *) +end + +module type PROVER = sig + + val mkProver : Ast.Sort.t list (* sorts *) + -> Ast.Sort.t Ast.Symbol.SMap.t (* environment *) + -> Ast.pred list (* axioms *) + -> Ast.Symbol.t list (* distinct constants, sorts in env *) + -> prover + +(* {{{ + type t + + (* theory interface *) + val is_interp : Ast.Sort.tycon -> bool + val interp_syms : unit -> (Ast.Symbol.t * Ast.Sort.t) list + + (* constraint solving interface *) + val create : Ast.Sort.t list (* sorts *) + -> Ast.Sort.t Ast.Symbol.SMap.t (* environment *) + -> Ast.pred list (* axioms *) + -> Ast.Symbol.t list (* distinct constants, sorts in env *) + -> t + + val set_filter : t + -> Ast.Sort.t Ast.Symbol.SMap.t + -> Ast.Symbol.t + -> Ast.pred list + -> ('a * Ast.pred) list + -> 'a list + + val print_stats : Format.formatter -> t -> unit + + (* Counterexample Interface *) + + val is_contra : t + -> Ast.Sort.t Ast.Symbol.SMap.t + -> Ast.pred + -> bool + + val unsat_core : t + -> Ast.Sort.t Ast.Symbol.SMap.t + -> Ast.pred (* background predicate *) + -> ('a * Ast.pred) list (* [(index, killer-fact)] *) + -> 'a list (* [unsat-core-index] *) + + val unsat_suffix : t + -> Ast.Sort.t Ast.Symbol.SMap.t + -> Ast.pred (* background predicate *) + -> Ast.pred list (* [p0,...,pn] *) + -> int option (* max j st. p /\i=j..n pi unsat *) +}}} *) + +end + + diff --git a/external/fixpoint/qualifier.ml b/external/fixpoint/qualifier.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/qualifier.ml @@ -0,0 +1,366 @@ +(* + * Copyright © 2009-11 The Regents of the University of California. + * All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +(** + * This module implements a module for representing and manipulating Qualifiers. + * *) +module Co = Constants + +module F = Format + +module P = Ast.Predicate +module E = Ast.Expression +module Sy = Ast.Symbol +module So = Ast.Sort +module Su = Ast.Subst +module SM = Sy.SMap +module SS = Sy.SSet + +module Misc = FixMisc open Misc.Ops +module IM = Misc.IntMap +open Ast + +let mydebug = false + +(**************************************************************************) +(***************************** Qualifiers *********************************) +(**************************************************************************) + +type q = { name : Sy.t + ; vvar : Sy.t + ; vsort : So.t + ; params : (Sy.t * So.t) list + ; pred : pred + ; args : expr list option + (* when args = Some es, es = vv'::[e1;...;en] + where vv' is the applied vv and e1...en are the args applied to ~A1,...,~An *) + } + + +type t = q (* to appease the functor gods. *) + +let rename = fun n -> fun q -> {q with name = n} +let name_of_t = fun q -> q.name +let vv_of_t = fun q -> q.vvar +let sort_of_t = fun q -> q.vsort +let pred_of_t = fun q -> q.pred +let params_of_t = fun q -> q.params +let all_params_of_t = fun q -> (q.vvar, q.vsort) :: q.params + +let args_of_t q = + let xs = all_params_of_t q |> List.map fst in + let es = match q.args with + | Some es -> es + | None -> List.map eVar xs + in Misc.combine "Qualifier.args_of_t" xs es + +let print_param ppf (x, t) = + F.fprintf ppf "%a:%a" Sy.print x So.print t + +let print_params ppf args = + F.fprintf ppf "%a" (Misc.pprint_many false ", " print_param) args + +let print_args ppf q = + q |> args_of_t |> List.map snd + |> F.fprintf ppf "%a(%a)" Sy.print q.name (Misc.pprint_many false ", " E.print) + +(* API *) +let print ppf q = + F.fprintf ppf "qualif %a(%a):%a" + Sy.print q.name + print_params (all_params_of_t q) + P.print q.pred + + +(**********************************************************************) +(****************** Canonizing Wildcards (e.g. _ ---> ~A) *************) +(**********************************************************************) + +let is_free params x = Misc.list_assoc_maybe x params |> Misc.maybe_bool |> not + +let canonizer params = + let fresh = Misc.mk_string_factory "~AA" |> fst |> (fun f -> f <+> Sy.of_string <+> eVar) in + let memo = Hashtbl.create 7 in + function + | (Var x, _) when is_free params x && Hashtbl.mem memo x -> + Hashtbl.find memo x + | (Var x, _) when is_free params x && Sy.is_wild_fresh x -> + fresh () + | (Var x, _) when is_free params x && Sy.is_wild_any x -> + fresh () >> Hashtbl.replace memo x + | e -> e + +(**************************************************************************) +(*************** Expanding Away Sets of Ops and Rels **********************) +(**************************************************************************) + +let expand_with_list f g = + List.map f <+> Misc.cross_flatten <+> Misc.map g + +let expand_with_pair f g = + Misc.map_pair f <+> Misc.uncurry Misc.cross_product <+> Misc.map g + +let crunchExpr f e1s xs e2s = + List.map begin fun e1 -> + List.map begin fun e2 -> + List.map begin fun x -> + f (e1, x, e2) + end xs + end e2s + end e1s + |> List.flatten |> List.flatten + +let rec expand_p ((p,_) as pred) = match p with + | And ps -> expand_ps pAnd ps + | Or ps -> expand_ps pOr ps + | Not p -> expand_p p |> List.map pNot + | Imp (p1,p2) -> expand_pp pImp (p1, p2) + | Iff (p1,p2) -> expand_pp pIff (p1, p2) + | Forall(qs, p) -> expand_p p |> List.map (fun p -> pForall (qs, p)) + | Bexp e -> expand_e e |> List.map pBexp + | MAtom (e1, rs, e2) -> let (e1s, e2s) = Misc.map_pair expand_e (e1,e2) in + crunchExpr pAtom e1s rs e2s + | Atom (e1, r, e2) -> let (e1s, e2s) = Misc.map_pair expand_e (e1,e2) in + crunchExpr pAtom e1s [r] e2s + | _ -> [pred] + +and expand_e ((e,_) as expr) = match e with + | MExp es -> Misc.flap expand_e es + | App (f, es) -> expand_es (fun es -> eApp (f, es)) es + | Bin (e1, op, e2) -> expand_ep (fun (e1,e2) -> eBin (e1, op, e2)) (e1, e2) + | MBin (e1, ops, e2) -> let e1s, e2s = Misc.map_pair expand_e (e1, e2) in + crunchExpr eBin e1s ops e2s + | Fld (s, e) -> expand_e e |> List.map (fun e -> eFld (s,e)) + | Cst (e, t) -> expand_e e |> List.map (fun e -> eCst (e,t)) + | Ite (p,e1,e2) -> let e1s, e2s = Misc.map_pair expand_e (e1, e2) in + let ps = expand_p p in + List.map begin fun e1 -> + List.map begin fun e2 -> + List.map begin fun p -> + eIte (p, e1, e2) + end ps + end e2s + end e1s + |> List.flatten |> List.flatten + | _ -> [expr] + +and expand_ps x = expand_with_list expand_p x +and expand_pp x = expand_with_pair expand_p x +and expand_es x = expand_with_list expand_e x +and expand_ep x = expand_with_pair expand_e x + +(* API *) +let expand_qual q = + expand_p q.pred + |> List.map (fun p -> {q with pred = p}) + +(**************************************************************************) +(*************** Expanding Away Sets of Ops and Rels **********************) +(**************************************************************************) + +let make_def_deps qnames q = + let res = ref [] in + let p' : pred = P.map begin function + | Bexp (App (f, args),_), _ + when SS.mem f qnames -> res := (f, args) :: !res; pTrue + | p -> p + end id q.pred + in (q.name, !res) +(* >> (fun (n, xs) -> F.printf "qdep %a = %a \n" Sy.print n (Misc.pprint_many false ", " Sy.print) (List.map fst xs) ) + *) + +let check_def_deps qm = + List.iter begin fun (n, fargs) -> + List.iter begin fun (f, args) -> + match SM.finds f qm with + | [q] -> asserts (List.length args = 1 + List.length q.params) + "Malformed Qualifier: %s with incorrect application of %s" + (Sy.to_string n) (Sy.to_string f) + | _::_::_ -> assertf "Malformed Qualifier: %s refers to multiply defined %s" + (Sy.to_string n) (Sy.to_string f) + | _ -> () +(* | [] -> assertf "Malformed Qualifier: %s refers to unknown %s" + (Sy.to_string n) (Sy.to_string f) *) + + end fargs + end + +let order_by_defs qm qs = + let is = Misc.range 0 (List.length qs) in + let qis = List.combine qs is in + let i2q = qis |>: Misc.swap |> IM.of_list |> Misc.flip IM.find in + let i2s = i2q <+> name_of_t <+> Sy.to_string in + let n2i = qis |>: Misc.app_fst name_of_t |> SM.of_list + |> (fun m n -> SM.safeFind n m "order_by_defs") in + + let qnams= qs |>: name_of_t |> SS.of_list in + let deps = qs |>: make_def_deps qnams >> check_def_deps qm in + let ijs = deps |> Misc.flap (fun (n, fargs) -> fargs |>: (fun (f,_) -> (n, f))) + |> List.map (Misc.map_pair n2i) in + let irs = Fcommon.scc_rank "qualifier-deps" i2s is ijs in + Misc.fsort snd irs + |>: (fst <+> i2q) +(* >> (F.printf "ORDERED QUALS:\n%a\n" (Misc.pprint_many true "\n" print)) *) + +let expand_def qm p = match p with + | Bexp (App (f, args),_), _ -> begin + match SM.finds f qm with + | _::_::_ -> assertf "Ambiguous Qualifier: %s" (Sy.to_string f) + | [q] -> q |> all_params_of_t + |> List.map fst + |> Misc.flip (Misc.combine ("Q.expand_def "^ (P.to_string p))) args + |> Su.of_list + |> substs_pred q.pred + | [] -> p (* assertf "Unknown Qualifier: %s" (Sy.to_string f) *) + end + | _ -> p + +(* this MUST precede any renaming as renaming can screw up name resolution *) +let compile_definitions qs = + let qm = List.fold_left (fun qm q -> SM.adds q.name [q] qm) SM.empty qs in + let qs' = order_by_defs qm qs in + List.fold_left begin fun qm q -> + let q' = {q with pred = P.map (expand_def qm) id q.pred } in + SM.adds q.name [q'] qm + end SM.empty qs' + |> SM.range |> Misc.flatten + +(**************************************************************************) +(************************* Normalize Qualifier Sets ***********************) +(**************************************************************************) + +let remove_duplicates qs = + qs |> Misc.kgroupby (all_params_of_t <*> pred_of_t) + |> List.map (fun (_,x::_) -> x) + +let rename_qual q i = + {q with name = Sy.suffix q.name (string_of_int i)} + +let uniquely_rename qs = + Misc.mapfold begin fun m q -> + if SM.mem q.name m then + let i = SM.safeFind q.name m "uniquelyRename" in + (SM.add q.name (i+1) m, rename_qual q i) + else + (SM.add q.name 0 m, q) + end SM.empty qs + |> snd + + +let check_dup t q = + try + let q' = Hashtbl.find t q.name in + if (pred_of_t q' = pred_of_t q) then () else + Format.printf "WARNING: duplicate qualifiers after normalization! (q = %a) (q' = %a)" + print q + print q' + with Not_found -> () + +let qualifMap_set, qualifMap_get = + let t = Hashtbl.create 37 in + ( (fun qs -> Hashtbl.clear t; List.iter (fun q -> check_dup t q; Hashtbl.replace t q.name q) qs) + , (fun n -> try Some (Hashtbl.find t n) + with Not_found -> (Format.printf "qualifMap_get fails on %a" Sy.print n; assert false) + ) + ) + +let ticker = ref 0 + +(* API *) +let normalize qs = + qs |> Misc.flap expand_qual + |> compile_definitions + |> remove_duplicates + |> uniquely_rename + >> qualifMap_set +(* >> (fun qs -> ticker += 1; Co.logPrintf "normalize (%d):\n%a" (!ticker) + (Misc.pprint_many true "\n" print) qs; flush stdout) *) + +(* API *) +let expandPred n es = + n |> qualifMap_get + |> Misc.maybe_map begin fun q -> + let xs = List.map fst <| args_of_t q in + Misc.combine "expandPred" xs es + |> Ast.Subst.of_list + |> Ast.substs_pred (pred_of_t q) + end + +(*********************************************************************) +(***************************** Create ********************************) +(*********************************************************************) + +let generalize_sorts vts = + let vs, ts = List.split vts in + let ts' = So.generalize ts in + List.combine vs ts' + +(* let generalize_sorts z = if !Co.gen_qual_sorts then generalize_sorts z else z *) + +let close_params vts p = + p |> P.support + |> List.filter (Sy.is_wild <&&> is_free vts) + |> List.map (fun x -> (x, So.t_int (* t_generic 0 causes blowup? *))) + |> (@) vts (* Sy.SMap.of_list *) + +(* API *) +let create n v t vts p = + let p = P.map id (canonizer vts) p in + let vts = close_params vts p in + let (v,t)::vts = generalize_sorts ((v,t)::vts) in + let _ = asserts (Misc.distinct vts) "Error: Q.create duplicate params %s \n" (Sy.to_string n) + in { name = n + ; vvar = v + ; vsort = t + ; pred = p + ; params = vts + ; args = None } + +(* DEBUG ONLY *) +let printb ppf (x, e) = + F.fprintf ppf "%a:%a" Sy.print x E.print e +let printbs ppf args = + F.fprintf ppf "%a" (Misc.pprint_many false ", " printb) args + +(* API *) +let inst q args = + let _ = if mydebug then F.printf "\nQ.inst with <<%a>>\n" printbs args in + let xes = try q |> all_params_of_t |> List.map (fun (x,_) -> (x, List.assoc x args)) + with Not_found -> + let _ = F.printf "Error: Q.inst with bad args %a <<%a>>" print q printbs args + in assertf "Error: Q.inst with bad args \n" + in + let v = match xes with (_, (Var v, _)) :: _ -> v | _ -> assertf "Error: Q.inst with non-vvar arg" in + let p = xes |> Su.of_list |> Ast.substs_pred q.pred in + { q with vvar = v; pred = p; args = Some (List.map snd xes)} + + +module QSet = Misc.ESet (struct + type t = q + let compare q1 q2 = + if (q1.name = q2.name) + then compare q1.args q2.args + else compare q1.name q2.name +end) + diff --git a/external/fixpoint/qualifier.mli b/external/fixpoint/qualifier.mli new file mode 100644 --- /dev/null +++ b/external/fixpoint/qualifier.mli @@ -0,0 +1,53 @@ +(* + * Copyright © 2009-11 The Regents of the University of California. + * All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +(** + * This module implements a module for representing and manipulating Qualifiers. + * *) + +type t +module QSet : FixMisc.ESetType with type elt = t + +val create : Ast.Symbol.t + -> Ast.Symbol.t + -> Ast.Sort.t + -> (Ast.Symbol.t * Ast.Sort.t) list + -> Ast.pred + -> t + +val name_of_t : t -> Ast.Symbol.t +val vv_of_t : t -> Ast.Symbol.t +val pred_of_t : t -> Ast.pred +val sort_of_t : t -> Ast.Sort.t +val params_of_t : t -> (Ast.Symbol.t * Ast.Sort.t) list (* Ast.Sort.t Ast.Symbol.SMap.t *) +val all_params_of_t : t -> (Ast.Symbol.t * Ast.Sort.t) list +val vv_of_t : t -> Ast.Symbol.t +val args_of_t : t -> (Ast.Symbol.t * Ast.expr) list +val normalize : t list -> t list +val inst : t -> (Ast.Symbol.t * Ast.expr) list -> t +val print : Format.formatter -> t -> unit +val print_args : Format.formatter -> t -> unit +val expandPred : Ast.Symbol.t -> Ast.expr list -> Ast.pred option + + diff --git a/external/fixpoint/smtLIB2.ml b/external/fixpoint/smtLIB2.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/smtLIB2.ml @@ -0,0 +1,419 @@ +(* + * Copyright © 2008 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + *) + +(********************************************************************************) +(*********** This module implements the binary interface with SMTLIB2 *********) +(*********** http://www.smt-lib.org/ *********) +(*********** http://www.grammatech.com/resource/smt/SMTLIBTutorial.pdf *********) +(********************************************************************************) + + +module H = Hashtbl +module F = Format +module Co = Constants +module BS = BNstats +module A = Ast +module Sy = A.Symbol +module So = A.Sort +module SM = Sy.SMap +module P = A.Predicate +module E = A.Expression +module Misc = FixMisc open Misc.Ops +module SSM = Misc.StringMap +module Th = Theories + +module SMTLib2 : ProverArch.SMTSOLVER = struct + +let spr = Printf.sprintf + +let mydebug = false + +let nb_unsat = ref 0 +let nb_pop = ref 0 +let nb_push = ref 0 + +(***************************************************************) +(********************** Types **********************************) +(***************************************************************) + +type symbol = string (* Sy.t *) +type sort = string (* So.t *) +type ast = string (* E of A.expr | P of A.pred *) +type fun_decl = symbol + +type cmd = Push + | Pop + | CheckSat + | Declare of symbol * sort list * sort + | AssertCnstr of ast + | Distinct of ast list (* {v: ast list | (len v) >= 2} *) + +type resp = Ok + | Sat + | Unsat + | Unknown + | Error of string + +type solver = Z3 | Mathsat | Cvc4 + +type context = { cin : in_channel + ; cout : out_channel + ; clog : out_channel } + +let respString = function + | Ok -> "Ok" + | Sat -> "Sat" + | Unsat -> "Unsat" + | Unknown -> "Unknown" + | Error s -> "Error " ^ s + +let solverString = function + | Z3 -> "z3" + | Mathsat -> "mathsat" + | Cvc4 -> "cvc4" + +(*******************************************************************) +(*********************** Set Theory ********************************) +(*******************************************************************) + +let elt = "Elt" +let set = "Set" +let emp = "smt_set_emp" +let add = "smt_set_add" +let cup = "smt_set_cup" +let cap = "smt_set_cap" +let mem = "smt_set_mem" +let dif = "smt_set_dif" +let sub = "smt_set_sub" +let com = "smt_set_com" + +(* + (define-fun smt_set_emp () Set ((as const Set) false)) + (define-fun smt_set_mem ((x Elt) (s Set)) Bool (select s x)) + (define-fun smt_set_add ((s Set) (x Elt)) Set (store s x true)) + (define-fun smt_set_cap ((s1 Set) (s2 Set)) Set ((_ map and) s1 s2)) + (define-fun smt_set_cup ((s1 Set) (s2 Set)) Set ((_ map or) s1 s2)) + (define-fun smt_set_com ((s Set)) Set ((_ map not) s)) + (define-fun smt_set_dif ((s1 Set) (s2 Set)) Set (smt_set_cap s1 (smt_set_com s2))) + (define-fun smt_set_sub ((s1 Set) (s2 Set)) Bool (= smt_set_emp (smt_set_dif s1 s2))) +*) + +(* z3 specific *) +let z3_preamble + = [ spr "(define-sort %s () Int)" + elt + ; spr "(define-sort %s () (Array %s Bool))" + set elt + ; spr "(define-fun %s () %s ((as const %s) false))" + emp set set + ; spr "(define-fun %s ((x %s) (s %s)) Bool (select s x))" + mem elt set + ; spr "(define-fun %s ((s %s) (x %s)) %s (store s x true))" + add set elt set + ; spr "(define-fun %s ((s1 %s) (s2 %s)) %s ((_ map or) s1 s2))" + cup set set set + ; spr "(define-fun %s ((s1 %s) (s2 %s)) %s ((_ map and) s1 s2))" + cap set set set + ; spr "(define-fun %s ((s %s)) %s ((_ map not) s))" + com set set + ; spr "(define-fun %s ((s1 %s) (s2 %s)) %s (%s s1 (%s s2)))" + dif set set set cap com + ; spr "(define-fun %s ((s1 %s) (s2 %s)) Bool (= %s (%s s1 s2)))" + sub set set emp dif + ] + +let smtlib_preamble + = [ spr "(set-logic QF_UFLIA)" + ; spr "(define-sort %s () Int)" elt + ; spr "(define-sort %s () Int)" set + ; spr "(declare-fun %s () %s)" emp set + ; spr "(declare-fun %s (%s %s) %s)" add set elt set + ; spr "(declare-fun %s (%s %s) %s)" cup set set set + ; spr "(declare-fun %s (%s %s) %s)" cap set set set + ; spr "(declare-fun %s (%s %s) %s)" dif set set set + ; spr "(declare-fun %s (%s %s) Bool)" sub set set + ; spr "(declare-fun %s (%s %s) Bool)" mem elt set + + (* HIDE? + ; spr "(assert (forall ((x %s)) (not (%s x %s))))" + elt mem emp + ; spr "(assert (forall ((x %s) (s1 %s) (s2 %s)) + (= (%s x (%s s1 s2)) (or (%s x s1) (%s x s2)))))" + elt set set mem cup mem mem + ; spr "(assert (forall ((x %s) (s1 %s) (s2 %s)) + (= (%s x (%s s1 s2)) (and (%s x s1) (%s x s2)))))" + elt set set mem cap mem mem + ; spr "(assert (forall ((x %s) (s1 %s) (s2 %s)) + (= (%s x (%s s1 s2)) (and (%s x s1) (not (%s x s2))))))" + elt set set mem dif mem mem + ; spr "(assert (forall ((x %s) (s %s) (y %s)) + (= (%s x (%s s y)) (or (%s x s) (= x y)))))" + elt set elt mem add mem + *) + ] + + +let mkSetSort _ _ = set +let mkEmptySet _ _ = emp +let mkSetAdd _ s x = spr "(%s %s %s)" add s x +let mkSetMem _ x s = spr "(%s %s %s)" mem x s +let mkSetCup _ s t = spr "(%s %s %s)" cup s t +let mkSetCap _ s t = spr "(%s %s %s)" cap s t +let mkSetDif _ s t = spr "(%s %s %s)" dif s t +let mkSetSub _ s t = spr "(%s %s %s)" sub s t + +(******************************************************************) +(**************** SMT IO ******************************************) +(** https://raw.github.com/ravichugh/djs/master/src/zzz.ml ********) +(******************************************************************) + +(* "z3 -smt2 -in" *) +(* "z3 -smtc SOFT_TIMEOUT=1000 -in" *) +(* "z3 -smtc -in MBQI=false" *) + +let smt_cmd = function + | Z3 -> "z3 -smt2 -in MODEL=false MODEL.PARTIAL=true smt.mbqi=false auto-config=false" + | Mathsat -> "mathsat -input=smt2" + | Cvc4 -> "cvc4 --incremental -L smtlib2" + +let smt_preamble = function + | Z3 -> z3_preamble + | _ -> smtlib_preamble + + +let smt_file = fun () -> !Co.out_file ^ ".smt2" + +let smt_write_raw me s = + output_now me.clog s; + output_now me.cout s + +let smt_read_raw me = + input_line me.cin + +let smt_write me ?nl:(nl=true) ?tab:(tab=false) s = + let pre = if tab then " " else "" in + let suf = if nl then "\n" else "" in + smt_write_raw me (pre^s^suf) + +let rec smt_read me + = match smt_read_raw me with + | "sat" -> Sat + | "unsat" -> Unsat + | "success" -> smt_read me + | "unknown" -> Unknown + | s -> Error s + + +(* val interact : context -> cmd -> resp *) +let interact me = function + | Declare (x, ts, t) -> + let _ = smt_write me <| spr "(declare-fun %s (%s) %s)" x (String.concat " " ts) t in + Ok + | Push -> + let _ = smt_write me <| "(push 1)" in + Ok + | Pop -> + let _ = smt_write me <| "(pop 1)" in + Ok + | CheckSat -> + let _ = smt_write me <| "(check-sat)" in + smt_read me + | AssertCnstr a -> + let _ = smt_write me <| spr "(assert %s)" a in + Ok + | Distinct az -> + let _ = smt_write me <| spr "(assert (distinct %s))" (String.concat " " az) in + Ok + + +(* API *) +let smt_decl me x ts t + = match interact me (Declare (x, ts, t)) with + | Ok -> () + | _ -> assertf "crash: SMTLIB2 smt_decl" + +(* API *) +let smt_push me + = match interact me Push with + | Ok -> incr nb_push; () + | _ -> assertf "crash: SMTLIB2 smt_push" + +(* API *) +let smt_pop me + = match interact me Pop with + | Ok -> incr nb_pop; () + | _ -> assertf "crash: SMTLIB2 smt_pop" + +(* API *) +let smt_check_unsat me + = match interact me CheckSat with + | Unsat -> true + | Sat -> false + | Unknown -> false + | e -> assertf "crash: SMTLIB2 smt_check_unsat %s" (respString e) + +(* API *) +let smt_assert_cnstr me p + = match interact me (AssertCnstr p) with + | Ok -> () + | _ -> assertf "crash: SMTLIB2 smt_assert_cnstr" + +(* API *) +let smt_assert_distinct me az + = match interact me (Distinct az) with + | Ok -> () + | _ -> assertf "crash: SMTLIB2 smt_assert_distinct" + +let solver () = + match !Co.smt_solver with + | Some "z3" -> Z3 + | Some "mathsat" -> Mathsat + | Some "cvc4" -> Cvc4 + | Some str -> assertf "ERROR: fixpoint does not yet support SMTSOLVER: %s" str + | None -> assertf "ERROR: undefined solver for smtLIB2" + +let mkContext _ = + let s = solver () in + let ci, co = Unix.open_process <| smt_cmd s in + let cl = smt_file () |> open_out in + let pre = smt_preamble s in + let ctx = { cin = ci; cout = co; clog = cl } in + let _ = List.iter (smt_write ctx) pre in + ctx + +(***********************************************************************) +(*********************** AST Constructors ******************************) +(***********************************************************************) + +let stringSymbol _ s = s +let astString _ a = a +let isBool c a = failwith "TODO:SMTLib2.isBool" +let boundVar me i t = failwith "TODO:SMTLib2.boundVar" + +let var me x t = + let _ = smt_decl me x [] t in + x + +let funcDecl me s ta t = + let _ = smt_decl me s (Array.to_list ta) t in + s + +let mkIntSort _ = "Int" +let mkBoolSort _ = "Bool" + +let mkInt _ i _ = string_of_int i +let mkTrue _ = "true" +let mkFalse _ = "false" + +let mkAll _ _ _ _ = failwith "TODO:SMTLib2.mkAll" + +let mkRel _ r a1 a2 + = match r with + | A.Eq -> spr "(= %s %s)" a1 a2 + | A.Ne -> spr "(not (= %s %s))" a1 a2 + | A.Gt -> spr "(> %s %s)" a1 a2 + | A.Ge -> spr "(>= %s %s)" a1 a2 + | A.Lt -> spr "(< %s %s)" a1 a2 + | A.Le -> spr "(<= %s %s)" a1 a2 + + + +let mkApp _ f = function + | [] -> f + | az -> spr "(%s %s)" f (String.concat " " az) + +let opStr = function + | A.Plus -> "+" + | A.Minus -> "-" + | A.Times -> "*" + | A.Div -> "/" + | A.Mod -> "mod" + +let mkOp op a1 a2 + = spr "(%s %s %s)" (opStr op) a1 a2 + +let mkMul _ = mkOp A.Times +let mkAdd _ = mkOp A.Plus +let mkSub _ = mkOp A.Minus +let mkMod _ = mkOp A.Mod + +let mkIte _ a1 a2 a3 + = spr "(ite %s %s %s)" a1 a2 a3 + +let mkNot _ a + = spr "(not %s)" a + +let mkAnd _ az + = spr "(and %s)" (String.concat " " az) + +let mkOr _ az + = spr "(or %s)" (String.concat " " az) + +let mkImp _ a1 a2 + = spr "(=> %s %s)" a1 a2 + +let mkIff _ a1 a2 + = spr "(= %s %s)" a1 a2 + +(*******************************************************************) +(*********************** Queries ***********************************) +(*******************************************************************) + +let us_ref = ref 0 + +(* API *) +let unsat me = + let _ = if mydebug then begin + Printf.printf "[%d] UNSAT 1 " (us_ref += 1); + flush stdout + end + in + let rv = BS.time "SMT.check_unsat" smt_check_unsat me in + let _ = if mydebug then (Printf.printf "UNSAT 2 \n"; flush stdout) in + let _ = if rv then ignore (nb_unsat += 1) in + rv + +(* API *) +let assertAxiom me p + = (* Co.bprintf mydebug "@[Pushing axiom %s@]@." (astString me p); *) + BS.time "assertAxiom" (smt_assert_cnstr me) p; + asserts (not (unsat me)) "ERROR: Axiom makes background theory inconsistent!" + +(* API *) +let assertDistinct me = function + | ((x1::x2::_) as az) -> smt_assert_distinct me az + | _ -> () + +(* API *) +let bracket me f + = Misc.bracket (fun _ -> smt_push me) (fun _ -> smt_pop me) f + +(* API *) +let assertPreds me ps + = List.iter (fun p -> BS.time "assertPreds" (smt_assert_cnstr me) p) ps + +(* API *) +let print_stats ppf () = + F.fprintf ppf "SMT stats: pushes=%d, pops=%d, unsats=%d \n" + !nb_push !nb_pop !nb_unsat + +end diff --git a/external/fixpoint/smtZ3.mem.ml b/external/fixpoint/smtZ3.mem.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/smtZ3.mem.ml @@ -0,0 +1,169 @@ +(* + * Copyright © 2008 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + *) + +(* This file is part of the LiquidC Project *) + +module H = Hashtbl +module F = Format +module Co = Constants +module BS = BNstats +module A = Ast +module Sy = A.Symbol +module So = A.Sort +module SM = Sy.SMap +module P = A.Predicate +module E = A.Expression +module Misc = FixMisc open Misc.Ops +module SSM = Misc.StringMap +module Th = Theories + +module SMTZ3 : ProverArch.SMTSOLVER = struct + +let mydebug = false + +(********************************************************************************) +(************ SMT INTERFACE *****************************************************) +(********************************************************************************) + +let nb_unsat = ref 0 +let nb_pop = ref 0 +let nb_push = ref 0 + +type context = Z3.context +type symbol = Z3.symbol +type sort = Z3.sort +type ast = Z3.ast +type fun_decl = Z3.func_decl + +let var = Z3.mk_const +let boundVar = Z3.mk_bound +let stringSymbol = Z3.mk_string_symbol +let funcDecl = Z3.mk_func_decl + +let isBool c a = + a |> Z3.get_sort c + |> Z3.sort_to_string c + |> (=) "bool" + +let isInt me a = + a |> Z3.get_sort me + |> Z3.sort_to_string me + |> (=) "int" + +let mkAll me = Z3.mk_forall me 0 [||] + +let mkRel c r a1 a2 + = match r with + | A.Eq -> Z3.mk_eq c a1 a2 + | A.Ne -> Z3.mk_distinct c [| a1; a2 |] + | A.Gt -> Z3.mk_gt c a1 a2 + | A.Ge -> Z3.mk_ge c a1 a2 + | A.Lt -> Z3.mk_lt c a1 a2 + | A.Le -> Z3.mk_le c a1 a2 + +let mkApp c f az = Z3.mk_app c f (Array.of_list az) +let mkMul c a1 a2 = Z3.mk_mul c [| a1; a2|] +let mkAdd c a1 a2 = Z3.mk_add c [| a1; a2|] +let mkSub c a1 a2 = Z3.mk_sub c [| a1; a2|] +let mkMod = Z3.mk_mod +let mkIte = Z3.mk_ite + +let mkInt = Z3.mk_int +let mkTrue = Z3.mk_true +let mkFalse = Z3.mk_false +let mkNot = Z3.mk_not +let mkAnd c az = Z3.mk_and c (Array.of_list az) +let mkOr c az = Z3.mk_or c (Array.of_list az) +let mkImp = Z3.mk_implies +let mkIff = Z3.mk_iff +let astString = Z3.ast_to_string +let mkIntSort = Z3.mk_int_sort +let mkBoolSort = Z3.mk_bool_sort +let mkSetSort = Z3.mk_set_sort +let mkEmptySet = Z3.mk_empty_set +let mkSetAdd = Z3.mk_set_add +let mkSetMem = Z3.mk_set_member +let mkSetCup = fun me s1 s2 -> Z3.mk_set_union me [| s1; s2 |] +let mkSetCap = fun me s1 s2 -> Z3.mk_set_intersect me [| s1; s2 |] +let mkSetDif = Z3.mk_set_difference +let mkSetSub = Z3.mk_set_subset +let mkContext = Z3.mk_context_x + +(*********************************************************) + +let z3push me = + let _ = nb_push += 1 in + let _ = BS.time "Z3.push" Z3.push me in + () + +let z3pop me = + let _ = incr nb_pop in + BS.time "Z3.pop" (Z3.pop me) 1 + + +(* Z3 API *) +let unsat = + let us_ref = ref 0 in + fun me -> + let _ = if mydebug then (Printf.printf "[%d] UNSAT 1 " (us_ref += 1); flush stdout) in + let rv = (BS.time "Z3.check" Z3.check me) = Z3.L_FALSE in + let _ = if mydebug then (Printf.printf "UNSAT 2 \n"; flush stdout) in + let _ = if rv then ignore (nb_unsat += 1) in + rv + +(* API *) +let assertAxiom me p = + Co.bprintf mydebug "@[Pushing axiom %s@]@." (astString me p); + BS.time "Z3 assert axiom" (Z3.assert_cnstr me) p; + asserts (not (unsat me)) "ERROR: Axiom makes background theory inconsistent!" + +(* API *) +let assertDistinct me xs = + xs |> Array.of_list |> Z3.mk_distinct me |> assertAxiom me + +(* Z3 API *) +let bracket me f = Misc.bracket (fun _ -> z3push me) (fun _ -> z3pop me) f + +(* Z3 API *) +let assertPreds me ps = List.iter (fun p -> BS.time "Z3.ass_cst" (Z3.assert_cnstr me) p) ps + +(* Z3 API *) +let valid me p = + bracket me begin fun _ -> + assertPreds me [Z3.mk_not me p]; + BS.time "unsat" unsat me + end + +(* Z3 API *) +let contra me p = + bracket me begin fun _ -> + assertPreds me [p]; + BS.time "unsat" unsat me + end + +(* API *) +let print_stats ppf () = + F.fprintf ppf + "SMT stats: pushes=%d, pops=%d, unsats=%d \n" + !nb_push !nb_pop !nb_unsat + +end diff --git a/external/fixpoint/smtZ3.ml b/external/fixpoint/smtZ3.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/smtZ3.ml @@ -0,0 +1,169 @@ +(* + * Copyright © 2008 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + *) + +(* This file is part of the LiquidC Project *) + +module H = Hashtbl +module F = Format +module Co = Constants +module BS = BNstats +module A = Ast +module Sy = A.Symbol +module So = A.Sort +module SM = Sy.SMap +module P = A.Predicate +module E = A.Expression +module Misc = FixMisc open Misc.Ops +module SSM = Misc.StringMap +module Th = Theories + +module SMTZ3 : ProverArch.SMTSOLVER = struct + +let mydebug = false + +(********************************************************************************) +(************ SMT INTERFACE *****************************************************) +(********************************************************************************) + +let nb_unsat = ref 0 +let nb_pop = ref 0 +let nb_push = ref 0 + +type context = Z3.context +type symbol = Z3.symbol +type sort = Z3.sort +type ast = Z3.ast +type fun_decl = Z3.func_decl + +let var = Z3.mk_const +let boundVar = Z3.mk_bound +let stringSymbol = Z3.mk_string_symbol +let funcDecl = Z3.mk_func_decl + +let isBool c a = + a |> Z3.get_sort c + |> Z3.sort_to_string c + |> (=) "bool" + +let isInt me a = + a |> Z3.get_sort me + |> Z3.sort_to_string me + |> (=) "int" + +let mkAll me = Z3.mk_forall me 0 [||] + +let mkRel c r a1 a2 + = match r with + | A.Eq -> Z3.mk_eq c a1 a2 + | A.Ne -> Z3.mk_distinct c [| a1; a2 |] + | A.Gt -> Z3.mk_gt c a1 a2 + | A.Ge -> Z3.mk_ge c a1 a2 + | A.Lt -> Z3.mk_lt c a1 a2 + | A.Le -> Z3.mk_le c a1 a2 + +let mkApp c f az = Z3.mk_app c f (Array.of_list az) +let mkMul c a1 a2 = Z3.mk_mul c [| a1; a2|] +let mkAdd c a1 a2 = Z3.mk_add c [| a1; a2|] +let mkSub c a1 a2 = Z3.mk_sub c [| a1; a2|] +let mkMod = Z3.mk_mod +let mkIte = Z3.mk_ite + +let mkInt = Z3.mk_int +let mkTrue = Z3.mk_true +let mkFalse = Z3.mk_false +let mkNot = Z3.mk_not +let mkAnd c az = Z3.mk_and c (Array.of_list az) +let mkOr c az = Z3.mk_or c (Array.of_list az) +let mkImp = Z3.mk_implies +let mkIff = Z3.mk_iff +let astString = Z3.ast_to_string +let mkIntSort = Z3.mk_int_sort +let mkBoolSort = Z3.mk_bool_sort +let mkSetSort = Z3.mk_set_sort +let mkEmptySet = Z3.mk_empty_set +let mkSetAdd = Z3.mk_set_add +let mkSetMem = Z3.mk_set_member +let mkSetCup = fun me s1 s2 -> Z3.mk_set_union me [| s1; s2 |] +let mkSetCap = fun me s1 s2 -> Z3.mk_set_intersect me [| s1; s2 |] +let mkSetDif = Z3.mk_set_difference +let mkSetSub = Z3.mk_set_subset +let mkContext = Z3.mk_context_x + +(*********************************************************) + +let z3push me = + let _ = nb_push += 1 in + let _ = BS.time "Z3.push" Z3.push me in + () + +let z3pop me = + let _ = incr nb_pop in + BS.time "Z3.pop" (Z3.pop me) 1 + + +(* Z3 API *) +let unsat = + let us_ref = ref 0 in + fun me -> + let _ = if mydebug then (Printf.printf "[%d] UNSAT 1 " (us_ref += 1); flush stdout) in + let rv = (BS.time "Z3.check" Z3.check me) = Z3.L_FALSE in + let _ = if mydebug then (Printf.printf "UNSAT 2 \n"; flush stdout) in + let _ = if rv then ignore (nb_unsat += 1) in + rv + +(* API *) +let assertAxiom me p = + Co.bprintf mydebug "@[Pushing axiom %s@]@." (astString me p); + BS.time "Z3 assert axiom" (Z3.assert_cnstr me) p; + asserts (not (unsat me)) "ERROR: Axiom makes background theory inconsistent!" + +(* API *) +let assertDistinct me xs = + xs |> Array.of_list |> Z3.mk_distinct me |> assertAxiom me + +(* Z3 API *) +let bracket me f = Misc.bracket (fun _ -> z3push me) (fun _ -> z3pop me) f + +(* Z3 API *) +let assertPreds me ps = List.iter (fun p -> BS.time "Z3.ass_cst" (Z3.assert_cnstr me) p) ps + +(* Z3 API *) +let valid me p = + bracket me begin fun _ -> + assertPreds me [Z3.mk_not me p]; + BS.time "unsat" unsat me + end + +(* Z3 API *) +let contra me p = + bracket me begin fun _ -> + assertPreds me [p]; + BS.time "unsat" unsat me + end + +(* API *) +let print_stats ppf () = + F.fprintf ppf + "SMT stats: pushes=%d, pops=%d, unsats=%d \n" + !nb_push !nb_pop !nb_unsat + +end diff --git a/external/fixpoint/smtZ3.nomem.ml b/external/fixpoint/smtZ3.nomem.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/smtZ3.nomem.ml @@ -0,0 +1,81 @@ +(* + * Copyright © 2008 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + *) + +(********************************************************************************) +(** DUMMY SMT-Z3 Solver (for non Z3MEM builds) **********************************) +(********************************************************************************) + +let assertf = FixMisc.Ops.assertf +let msg = "This build is NOT linked against Z3. Please rebuild with Z3MEM=true. Only possible on linux" + +module SMTZ3 : ProverArch.SMTSOLVER = struct + +type context = () +type symbol = () +type sort = () +type ast = () +type fun_decl = () + +let var _ = failwith msg +let boundVar _ = failwith msg +let stringSymbol _ = failwith msg +let funcDecl _ = failwith msg +let isBool _ = failwith msg +let isInt _ = failwith msg +let mkAll _ = failwith msg +let mkRel _ = failwith msg +let mkApp _ = failwith msg +let mkMul _ = failwith msg +let mkAdd _ = failwith msg +let mkSub _ = failwith msg +let mkMod _ = failwith msg +let mkIte _ = failwith msg +let mkInt _ = failwith msg +let mkTrue _ = failwith msg +let mkFalse _ = failwith msg +let mkNot _ = failwith msg +let mkAnd _ = failwith msg +let mkOr _ = failwith msg +let mkImp _ = failwith msg +let mkIff _ = failwith msg +let astString _ = failwith msg +let mkIntSort _ = failwith msg +let mkBoolSort _ = failwith msg +let mkSetSort _ = failwith msg +let mkEmptySet _ = failwith msg +let mkSetAdd _ = failwith msg +let mkSetMem _ = failwith msg +let mkSetCup _ = failwith msg +let mkSetCap _ = failwith msg +let mkSetDif _ = failwith msg +let mkSetSub _ = failwith msg +let mkContext _ = failwith msg +let unsat _ = failwith msg +let assertAxiom _ = failwith msg +let assertDistinct _ = failwith msg +let bracket _ = failwith msg +let assertPreds _ = failwith msg +let valid _ = failwith msg +let contra _ = failwith msg +let print_stats _ = failwith msg + +end diff --git a/external/fixpoint/solve.ml b/external/fixpoint/solve.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/solve.ml @@ -0,0 +1,271 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + *) + + +(** This module implements a fixpoint solver *) +module BS = BNstats +module F = Format +module A = Ast +module Co = Constants +module P = A.Predicate +module E = A.Expression +module So = A.Sort +module Su = A.Subst +module Q = Qualifier +module Sy = A.Symbol +module SM = Sy.SMap +module C = FixConstraint +module Ci = Cindex +module PP = Prepass +module Cg = FixConfig +(* module TP = TpNull.Prover *) +module Misc = FixMisc open Misc.Ops + + +let mydebug = false + +type t = { + sri : Ci.t + ; ws : C.wf list + ; tt : Timer.t + + (* Stats *) + ; stat_refines : int ref + ; stat_cfreqt : (int * bool, int) Hashtbl.t +} + +module type SOLVER = sig + type soln + type bind + val create : bind Cg.cfg -> FixConstraint.soln option -> (t * soln) + val solve : t -> soln -> (soln * (FixConstraint.t list) * Counterexample.cex list) + val save : string -> t -> soln -> unit + val read : soln -> FixConstraint.soln + val min_read : soln -> FixConstraint.soln + val read_bind : soln -> Ast.Symbol.t -> bind + val cone : t -> FixConstraint.id -> FixConstraint.tag Ast.Cone.t + (* val meet : soln -> soln -> soln *) +end + +module Make (Dom : SolverArch.DOMAIN) = struct + type soln = Dom.t + type bind = Dom.bind + let min_read = Dom.min_read + let read = Dom.read + let read_bind = Dom.read_bind +(* let meet = Dom.meet *) + + +(*************************************************************) +(********************* Stats *********************************) +(*************************************************************) + +let hashtbl_incr_frequency t k = + let n = try Hashtbl.find t k with Not_found -> 0 in + Hashtbl.replace t k (n+1) + +let hashtbl_print_frequency t = + Misc.hashtbl_to_list t + |> Misc.kgroupby (fun ((k,b),n) -> (n,b)) + |> List.map (fun ((n,b), xs) -> (n, b, List.map (fst <+> fst) xs)) + |> List.sort compare + |> List.iter begin fun (n, b, xs) -> + Co.bprintf mydebug "ITERFREQ: %d times (ch = %b) %d constraints %s \n" + n b (List.length xs) (Misc.map_to_string string_of_int xs) + end + +(***************************************************************) +(************************ Debugging/Stats **********************) +(***************************************************************) + +let print_constr_stats ppf cs = + let cn = List.length cs in + let scn = List.length (List.filter C.is_simple cs) in + F.fprintf ppf "#Constraints: %d (simple = %d) \n" cn scn + +let print_solver_stats ppf me = + print_constr_stats ppf (Ci.to_list me.sri); + F.fprintf ppf "#Iterations = %d\n" !(me.stat_refines); + F.fprintf ppf "Iteration Frequency: \n"; + hashtbl_print_frequency me.stat_cfreqt; + F.fprintf ppf "Iteration Periods: @[%a@] \n" Timer.print me.tt + +let dump me s = + Co.bprintf mydebug "%a \n" print_solver_stats me; + Co.bprintf mydebug "%a \n" Dom.print_stats s; + Dom.dump s + +let log_iter_stats me s = + (if Co.ck_olev Co.ol_insane then Co.bprintf mydebug "log_iter_stats\n%a" Dom.print s); + (if !(me.stat_refines) mod 100 = 0 then + let msg = Printf.sprintf "\n num refines=%d" !(me.stat_refines) in + let _ = Timer.log_event me.tt (Some msg) in + let _ = Co.bprintf mydebug "%s\n %a\n" msg Dom.print_stats s in + let _ = Format.print_flush () in + ()); + () + +(***************************************************************) +(******************** Iterative Refinement *********************) +(***************************************************************) + +let is_solved s c = + let sol = read s in + c |> C.rhs_of_t + |> C.kvars_of_reft + |> List.map (sol <.> snd) + |> List.for_all ((=) []) + +let refine_constraint s c = + try BS.time "refine" (Dom.refine s) c with ex -> + let _ = F.printf "constraint refinement fails with: %s\n" (Printexc.to_string ex) in + let _ = F.printf "Failed on constraint:\n%a\n" (C.print_t None) c in + assert false + +let update_worklist me s' c w' = + c |> Ci.deps me.sri + |> Misc.filter (not <.> is_solved s') + |> Ci.wpush me.sri w' + +let rec acsolve me w s = + let _ = log_iter_stats me s in + let _ = Misc.display_tick () in + match Ci.wpop me.sri w with + | (None,_) -> + let _ = Timer.log_event me.tt (Some "Finished") in + s + | (Some c, w') -> + let _ = me.stat_refines += 1 in + let (ch, s') = BS.time "refine" (refine_constraint s) c in + let _ = hashtbl_incr_frequency me.stat_cfreqt (C.id_of_t c, ch) in + let _ = Co.bprintf mydebug "iter=%d id=%d ch=%b %a \n" + !(me.stat_refines) (C.id_of_t c) ch C.print_tag (C.tag_of_t c) in + let w'' = if ch then update_worklist me s' c w' else w' in + acsolve me w'' s' + +let unsat_constraints me s = + me.sri |> Ci.to_list |> List.filter (Dom.unsat s) + +let simplify_solution me s = Dom.simplify s + + +(***************************************************************) +(****************** Pruning Unconstrained Vars *****************) +(***************************************************************) + +let rhs_ks cs = + cs |> Misc.flap (Misc.compose C.kvars_of_reft C.rhs_of_t) + |> List.fold_left (fun rhss (_, kv) -> Sy.SSet.add kv rhss) Sy.SSet.empty + +let unconstrained_kvars cs = + let rhss = rhs_ks cs in + cs |> Misc.flap C.kvars_of_t + |> List.map snd + |> List.filter (fun kv -> not (Sy.SSet.mem kv rhss)) + +let true_unconstrained sri s = + sri |> Ci.to_list + |> unconstrained_kvars + |> Dom.top s + +(* +let true_unconstrained sri s = + if !Co.true_unconstrained then + let _ = Co.logPrintf "Fixpoint: Pruning unconstrained kvars \n" + in true_unconstrained sri s + else + let _ = Co.logPrintf "Fixpoint: NOT Pruning unconstrained kvars \n" + in s +*) + +(* API *) +let solve me s = + let _ = Co.bprintflush mydebug "Fixpoint: Validating Initial Solution \n" in + (* let _ = F.printf "create: SOLUTION \n %a \n" Dom.print s in *) + let _ = BS.time "Prepass.profile" PP.profile me.sri in + let _ = Co.bprintflush mydebug "\nBEGIN: Fixpoint: Trueing Unconstrained Variables \n" in + let s = s |> (!Co.true_unconstrained BS.time "Prepass.true_unconstr" (true_unconstrained me.sri)) in + let _ = Co.bprintflush mydebug "\nDONE: Fixpoint: Trueing Unconstrained Variables \n" in + (* let _ = F.printf "create: SOLUTION1 \n %a \n" Dom.print s in *) + let _ = Co.bprintflush mydebug "\nBEGIN: Fixpoint: Initialize Worklist \n" in + let w = BS.time "Cindex.winit" Ci.winit me.sri in + let _ = Co.bprintflush mydebug "\nDONE: Fixpoint: Initialize Worklist \n" in + let _ = Co.bprintflush mydebug "\nBEGIN: Fixpoint Refinement Loop \n" in + let s = BS.time "Solve.acsolve" (acsolve me w) s in + let _ = Co.bprintflush mydebug "\nDONE: Fixpoint Refinement Loop \n" in + (* let _ = F.printf "create: SOLUTION2 \n %a \n" Dom.print s in *) + let s = if !Co.minquals then simplify_solution me s else s in + let _ = Co.bprintflush mydebug "\nDONE: Simplify Solution \n" in + let _ = BS.time "Solve.dump" (dump me) s in + let _ = Co.bprintflush mydebug "Fixpoint: Testing Solution \n" in + let u = BS.time "Solve.unsatcs" (unsat_constraints me) s in + let _ = if u != [] then F.printf "Unsatisfied Constraints:\n %a" (Misc.pprint_many true "\n" (C.print_t None)) u in + let cx = if !Co.cex && Misc.nonnull u then Dom.ctr_examples s (Ci.to_list me.sri) u else [] in + (s, u, cx) + +let global_symbols cfg = + (SM.to_list cfg.Cg.uops) (* specified globals *) + ++ (Theories.interp_syms) (* theory globals *) + +(* API *) +let create cfg kf = + let gts = global_symbols cfg in + let sri = cfg.Cg.cs + >> Co.bprintf mydebug "Pre-Simplify Stats\n%a" print_constr_stats + |> BS.time "Constant Env" (List.map (C.add_consts_t gts)) + |> BS.time "Simplify" FixSimplify.simplify_ts + >> Co.bprintf mydebug "Post-Simplify Stats\n%a" print_constr_stats + |> BS.time "Ref Index" Ci.create cfg.Cg.kuts cfg.Cg.ds + |> (!Co.slice BS.time "Slice" Ci.slice) in + let ws = cfg.Cg.ws + |> (!Co.slice BS.time "slice_wf" (Ci.slice_wf sri)) + |> BS.time "Constant EnvWF" (List.map (C.add_consts_wf gts)) + |> PP.validate_wfs in + let cfg = { cfg with Cg.cs = Ci.to_list sri; Cg.ws = ws } in + let s = if !Constants.dump_simp <> "" then Dom.empty else BS.time "Dom.create" (Dom.create cfg) kf in + let _ = Co.bprintflush mydebug "\nDONE: Dom.create\n" in + let _ = Co.bprintflush mydebug "\nBEGIN: PP.validate\n" in + let _ = Ci.to_list sri + |> BS.time "Validate" (PP.validate cfg.Cg.a (Dom.read s)) in + let _ = Co.bprintflush mydebug "\nEND: PP.validate\n" in + ({ sri = sri + ; ws = ws + (* stat *) + ; tt = Timer.create "fixpoint iters" + ; stat_refines = ref 0 + ; stat_cfreqt = Hashtbl.create 37 + }, s) + >> (fun _ -> Co.bprintflush mydebug "DONE: Solve.create\n") + +(* API *) +let save fname me s = + let oc = open_out fname in + let ppf = F.formatter_of_out_channel oc in + F.fprintf ppf "@[%a@] \n" Ci.print me.sri; + F.fprintf ppf "@[%a@] \n" (Misc.pprint_many true "\n" (C.print_wf None)) me.ws; + F.fprintf ppf "@[%a@] \n" Dom.print s; + close_out oc + +(* API *) +let cone me = Cindex.data_cones (Ci.to_list me.sri) + +end diff --git a/external/fixpoint/solve.mli b/external/fixpoint/solve.mli new file mode 100644 --- /dev/null +++ b/external/fixpoint/solve.mli @@ -0,0 +1,34 @@ +(* + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +type t + +module type SOLVER = sig + type soln + type bind + val create : bind FixConfig.cfg -> FixConstraint.soln option -> (t * soln) + val solve : t -> soln -> (soln * (FixConstraint.t list) * Counterexample.cex list) + val save : string -> t -> soln -> unit + val read : soln -> FixConstraint.soln + val min_read : soln -> FixConstraint.soln + val read_bind : soln -> Ast.Symbol.t -> bind + val cone : t -> FixConstraint.id -> FixConstraint.tag Ast.Cone.t + (* val meet : soln -> soln -> soln *) + +end + +module Make (Dom : SolverArch.DOMAIN) : SOLVER + with type bind = Dom.bind + with type soln = Dom.t diff --git a/external/fixpoint/solverArch.ml b/external/fixpoint/solverArch.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/solverArch.ml @@ -0,0 +1,44 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +type qbind = Qualifier.t list + +module type DOMAIN = sig + type t + type bind + val empty : t + (* val meet : t -> t -> t *) + val min_read : t -> FixConstraint.soln + val read : t -> FixConstraint.soln + val read_bind : t -> Ast.Symbol.t -> bind + val top : t -> Ast.Symbol.t list -> t + val refine : t -> FixConstraint.t -> (bool * t) + val unsat : t -> FixConstraint.t -> bool + val create : bind FixConfig.cfg -> FixConstraint.soln option -> t + val print : Format.formatter -> t -> unit + val print_stats : Format.formatter -> t -> unit + val dump : t -> unit + val simplify : t -> t + val ctr_examples : t -> FixConstraint.t list -> FixConstraint.t list -> Counterexample.cex list + val mkbind : qbind -> bind +end diff --git a/external/fixpoint/theories.ml b/external/fixpoint/theories.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/theories.ml @@ -0,0 +1,198 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + *) + +module So = Ast.Sort +module Sy = Ast.Symbol +(* module SMT = SmtZ3.SMTZ3 *) + +open ProverArch +open FixMisc.Ops + +let set_tycon = So.tycon "Set_Set" +let t_set a = So.t_app set_tycon [a] + +(* API *) +let is_interp t = t = set_tycon + +(* API *) +let emp = ( Sy.of_string "Set_emp" + , So.t_func 1 [t_set (So.t_generic 0); So.t_bool] ) + +let sng = ( Sy.of_string "Set_sng" + , So.t_func 1 [So.t_generic 0; t_set (So.t_generic 0)] ) + +let mem = ( Sy.of_string "Set_mem" + , So.t_func 1 [So.t_generic 0; t_set (So.t_generic 0); So.t_bool] ) + + +let cup = ( Sy.of_string "Set_cup" + , So.t_func 1 [t_set (So.t_generic 0); t_set (So.t_generic 0); t_set (So.t_generic 0)]) + +let cap = ( Sy.of_string "Set_cap" + , So.t_func 1 [t_set (So.t_generic 0); t_set (So.t_generic 0); t_set (So.t_generic 0)]) + +let dif = ( Sy.of_string "Set_dif" + , So.t_func 1 [t_set (So.t_generic 0); t_set (So.t_generic 0); t_set (So.t_generic 0)]) + +let sub = ( Sy.of_string "Set_sub" + , So.t_func 1 [t_set (So.t_generic 0); t_set (So.t_generic 0); So.t_bool] ) + +let interp_syms = [emp; sng; mem; cup; cap; dif; sub] + +module MakeTheory(SMT : SMTSOLVER): + (THEORY with type context = SMT.context + and type sort = SMT.sort + and type ast = SMT.ast) + = struct + +type context = SMT.context +type sort = SMT.sort +type ast = SMT.ast + + +type appDef = { sy_name : Sy.t + ; sy_sort : So.t + ; sy_emb : SMT.context -> SMT.sort list -> SMT.ast list -> SMT.ast + } + +type sortDef = { so_name : Ast.Sort.tycon + ; so_arity : int + ; so_emb : SMT.context -> SMT.sort list -> SMT.sort + } + +(* API *) +let sort_name d = d.so_name +let sym_name d = d.sy_name +let sym_sort d = d.sy_sort + +(***************************************************************************) +(******************** Theory of Sets ***************************************) +(***************************************************************************) + +let set_set : sortDef = + { so_name = set_tycon + ; so_arity = 1 + ; so_emb = fun c -> function + [t] -> SMT.mkSetSort c t + | _ -> assertf "Set_set: type mismatch" + } + +let set_emp : appDef = + { sy_name = fst emp + ; sy_sort = snd emp + ; sy_emb = fun c ts es -> match ts, es with + | [t], [e] -> SMT.mkRel c Ast.Eq e (SMT.mkEmptySet c t) + | _ -> assertf "Set_emp: type mismatch" + } + +let set_sng : appDef = + { sy_name = fst sng + ; sy_sort = snd sng + ; sy_emb = fun c ts es -> match ts, es with + | [t], [e] -> SMT.mkSetAdd c (SMT.mkEmptySet c t) e + | _ -> assertf "Set_sng: type mismatch" + } + + +let set_mem : appDef = + { sy_name = fst mem + ; sy_sort = snd mem + ; sy_emb = fun c ts es -> match ts, es with + | [t], [e;es] -> SMT.mkSetMem c e es + | _ -> assertf "Set_mem: type mismatch" + } + +let set_cup : appDef = + { sy_name = fst cup + ; sy_sort = snd cup + ; sy_emb = fun c ts es -> match ts, es with + | [t], [e1;e2] -> SMT.mkSetCup c e1 e2 + | _ -> assertf "Set_cup: type mismatch" + } + +let set_cap : appDef = + { sy_name = fst cap + ; sy_sort = snd cap + ; sy_emb = fun c ts es -> match ts, es with + | [t], [e1;e2] -> SMT.mkSetCap c e1 e2 + | _ -> assertf "Set_cap: type mismatch" + } + +let set_dif : appDef = + { sy_name = fst dif + ; sy_sort = snd dif + ; sy_emb = fun c ts es -> match ts, es with + | [t], [e1;e2] -> SMT.mkSetDif c e1 e2 + | _ -> assertf "Set_dif: type mismatch" + } + +let set_sub : appDef = + { sy_name = fst sub + ; sy_sort = snd sub + ; sy_emb = fun c ts es -> match ts, es with + | [t], [e1;e2] -> SMT.mkSetSub c e1 e2 + | _ -> assertf "Set_dif: type mismatch" + } + +(***************************************************************************) +(********* Wrappers Around Z3 Constructors For Last-Minute Checking ********) +(***************************************************************************) + +let app_sort_arity def = match So.func_of_t def.sy_sort with + | Some (n,_,_) -> n + | None -> assertf "Theories: app with non-function symbol %s" + (Sy.to_string def.sy_name) + +let check_app_arities def tArgs eArgs = match So.func_of_t def.sy_sort with + | Some (n, ts,_) + -> asserts (n = List.length tArgs) + "Theories: app with mismatched sorts %s" (Sy.to_string def.sy_name); + asserts (List.length ts = List.length eArgs) + "Theories: app with mismatched args %s" (Sy.to_string def.sy_name) + | None + -> assertf "Theories: app with non-function symbol %s" + (Sy.to_string def.sy_name) + + +(* API *) +let mk_thy_app def c ts es = + check_app_arities def ts es; + def.sy_emb c ts es + +(* API *) +let mk_thy_sort def c ts = + asserts (List.length ts = def.so_arity) + "Theories: app with mismatched sorts %s" (So.tycon_string def.so_name); + def.so_emb c ts + +(* API *) +let theories = + ([set_set], [set_emp; + set_sng; + set_mem; + set_cup; + set_cap; + set_dif; + set_sub]) + + +end diff --git a/external/fixpoint/theories.mli b/external/fixpoint/theories.mli new file mode 100644 --- /dev/null +++ b/external/fixpoint/theories.mli @@ -0,0 +1,27 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + *) + +val is_interp : Ast.Sort.tycon -> bool +val interp_syms : (Ast.Symbol.t * Ast.Sort.t) list + +module MakeTheory(SMT : ProverArch.SMTSOLVER): (ProverArch.THEORY with type context = SMT.context and type sort = SMT.sort and type ast = SMT.ast) + diff --git a/external/fixpoint/timeout.ml b/external/fixpoint/timeout.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/timeout.ml @@ -0,0 +1,30 @@ + + +module M = Mutex +module T = Thread + +let get_time () = int_of_float (Unix.time ()) + +let mk_task = + fun f x lk (ret, rd) -> let rv = f x in + M.lock lk; ret := Some rv; rd := true; M.unlock lk + +let not_done lk (ret, rd) = + M.lock lk; let trd = !rd in (M.unlock lk; not(trd)) + +let fail thread (ret, rd) = + T.kill thread; ret := None; rd := true + +let do_timeout i f x = + let task = mk_task f x in + let (ret, rd) as rr = (ref None, ref false) in + let stime = get_time () in + let lk = M.create () in + let t = T.create (task lk) rr in + while not_done lk rr do + if (get_time () - stime < i) then + T.yield () + else + fail t rr + done; !ret + diff --git a/external/fixpoint/timeout.mli b/external/fixpoint/timeout.mli new file mode 100644 --- /dev/null +++ b/external/fixpoint/timeout.mli @@ -0,0 +1,4 @@ +(* simple timeout mechanism executes a function for a number of seconds + * specified by the first argument *) + +val do_timeout: int -> ('a -> 'b) -> 'a -> 'b option diff --git a/external/fixpoint/toARMC.ml b/external/fixpoint/toARMC.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/toARMC.ml @@ -0,0 +1,333 @@ +(* translation to ARMC *) + +module C = FixConstraint +module StrMap = Map.Make (struct type t = string let compare = compare end) +module StrSet = Set.Make (struct type t = string let compare = compare end) +module Misc = FixMisc open Misc.Ops + + +(* Andrey: TODO get rid of grd in t? grd p is a binding v:{v:b|p} *) +(* Andrey: TODO move to fixConstraint.ml? *) + + +(* Andrey: TODO move to ast.ml? *) +let pred_is_atomic (p, _) = + match p with + | Ast.True | Ast.False | Ast.Bexp _ | Ast.Atom _ -> true + | Ast.And _ | Ast.Or _ | Ast.Not _ | Ast.Imp _ | Ast.Forall _ -> false + +(* +let negate_brel = function + | Ast.Eq -> Ast.Ne + | Ast.Ne -> Ast.Eq + | Ast.Gt -> Ast.Le + | Ast.Ge -> Ast.Lt + | Ast.Lt -> Ast.Ge + | Ast.Le -> Ast.Gt + +let deep_negate_pred (p, t) = + match p with + | Ast.True -> Ast.pFalse + | Ast.False -> Ast.pTrue + | Ast.Atom (e1, r, e2) -> Ast.pAtom (e1, negate_brel r, e2) + | _ -> Ast.pNot (p, t) +*) + +let start_pc = "start" +let loop_pc = "loop" +let error_pc = "error" +let val_vname = "VVVV" +let card_vname = "CARD" +let exists_kv = "EX" +let primed_suffix = "p" +let str__cil_tmp = "__cil_tmp" + +type kv_scope = { + kvs : string list; + kv_scope : string list StrMap.t +} + +let sanitize_symbol s = + Str.global_replace (Str.regexp "@") "_at_" s |> Str.global_replace (Str.regexp "#") "_hash_" + +let symbol_to_armc s = Ast.Symbol.to_string s |> sanitize_symbol + +let mk_data_var ?(suffix = "") kv v = + Printf.sprintf "_%s_%s%s%s" + (sanitize_symbol kv) (sanitize_symbol v) (if suffix = "" then "" else "_") suffix + +let constant_to_armc = Ast.Constant.to_string +let bop_to_armc = function + | Ast.Plus -> "+" + | Ast.Minus -> "-" + | Ast.Times -> "*" + | Ast.Div -> "/" +let brel_to_armc = function + | Ast.Eq -> "=" + | Ast.Ne -> "=\\=" + | Ast.Gt -> ">" (* ">= 1+" *) + | Ast.Ge -> ">=" + | Ast.Lt -> "<" (* "+1 =<" *) + | Ast.Le -> "=<" +let bind_to_armc (s, t) = (* Andrey: TODO support binders *) + Printf.sprintf "%s:%s" (symbol_to_armc s) (Ast.Sort.to_string t |> sanitize_symbol) +let rec expr_to_armc (e, _) = + match e with + | Ast.Con c -> constant_to_armc c + | Ast.Var s -> mk_data_var exists_kv (symbol_to_armc s) + | Ast.App (s, es) -> + let str = symbol_to_armc s in + if es = [] then str else + Printf.sprintf "f_%s(%s)" str (List.map expr_to_armc es |> String.concat ", ") + | Ast.Bin (e1, op, e2) -> + Printf.sprintf "(%s %s %s)" + (expr_to_armc e1) (bop_to_armc op) (expr_to_armc e2) + | Ast.Ite (ip, te, ee) -> + Printf.sprintf "ite(%s, %s, %s)" + (pred_to_armc ip) (expr_to_armc te) (expr_to_armc ee) + | Ast.Fld (s, e) -> + Printf.sprintf "fld(%s, %s)" (expr_to_armc e) (symbol_to_armc s) +and pred_to_armc (p, _) = + match p with + | Ast.True -> "1=1" + | Ast.False -> "0=1" + | Ast.Bexp e -> expr_to_armc e + | Ast.Not p -> Printf.sprintf "neg(%s)" (pred_to_armc p) + | Ast.Imp (p1, p2) -> Printf.sprintf "(neg(%s); %s)" (pred_to_armc p1) (pred_to_armc p2) + | Ast.And [] -> "1=1" + | Ast.And [p] -> pred_to_armc p + | Ast.And (_::_ as ps) -> Printf.sprintf "(%s)" (List.map pred_to_armc ps |> String.concat ", ") + | Ast.Or [] -> "0=1" + | Ast.Or [p] -> pred_to_armc p + | Ast.Or (_::_ as ps) -> Printf.sprintf "(%s)" (List.map pred_to_armc ps |> String.concat "; ") + | Ast.Atom (e1, r, e2) -> + Printf.sprintf "%s %s %s" + (expr_to_armc e1) (brel_to_armc r) (expr_to_armc e2) + | Ast.Forall (qs,p) -> (* Andrey: TODO support forall *) + Printf.sprintf "forall([%s], %s)" + (List.map bind_to_armc qs |> String.concat ", ") + (pred_to_armc p) + + +let mk_kv_scope out ts wfs = + output_string out "% kv -> scope:\n"; + let kvs = List.map C.kvars_of_t ts |> List.flatten |> List.map snd + |> List.map symbol_to_armc |> Misc.sort_and_compact in + let kv_scope = + List.fold_left + (fun m wf -> + match C.reft_of_wf wf |> C.ras_of_reft with + | [C.Kvar([], kvar)] -> + let v = symbol_to_armc kvar in + let scope = + card_vname :: val_vname :: + (C.env_of_wf wf |> C.bindings_of_env |> List.map fst |> List.map symbol_to_armc + |> List.filter (fun s -> not (Misc.is_prefix str__cil_tmp s)) |> List.sort compare) in + Printf.fprintf out "%% %s -> %s\n" + v (String.concat ", " scope); + StrMap.add v scope m + | _ -> (* Andrey: TODO print ill-formed wf *) + failure "ERROR: kname_scope_map: ill-formed wf" + ) StrMap.empty wfs in + {kvs = kvs; kv_scope = kv_scope} + +let mk_data ?(suffix = "") ?(skip_kvs = []) s = + Printf.sprintf "[%s]" + (List.map + (fun kv -> + try + StrMap.find kv s.kv_scope |> + List.map (mk_data_var ~suffix:(if List.mem kv skip_kvs then "" else suffix) kv) + with Not_found -> failure "ERROR: rel_state_vs: scope not found for %s" kv + ) s.kvs |> List.flatten |> String.concat ", ") + +let mk_var2names state = + List.map + (fun kv -> + List.map + (fun v -> + Printf.sprintf "(%s, \'%s_%s\')" + (mk_data_var kv v) kv v + ) (StrMap.find kv state.kv_scope) |> String.concat ", " + ) state.kvs |> String.concat ", " + +let mk_skip_update state kvs = + if kvs = [] then "1=1" else + List.map + (fun kv -> + List.map + (fun v -> + Printf.sprintf "%s = %s" + (mk_data_var ~suffix:primed_suffix kv v) (mk_data_var kv v) + ) (StrMap.find kv state.kv_scope) |> String.concat ", " + ) kvs |> String.concat ", " + +let mk_update_str from_vs to_vs updates = + List.map2 + (fun v vp -> + Printf.sprintf "%s = %s" vp (try StrMap.find v updates with Not_found -> v) + ) from_vs to_vs |> String.concat ", " + +let split_scope scope = + match scope with + | card :: value :: data -> card, value, data + | _ -> failure "ERROR: split_scope: empty scope %s" (String.concat ", " scope) + +let reft_to_armc ?(suffix = "") state reft = + let vv = C.vv_of_reft reft |> symbol_to_armc in + let rs = C.ras_of_reft reft in + if rs = [] then "1=1" else + List.map + (function + | C.Conc pred -> pred_to_armc pred + | C.Kvar (subs, sym) -> + let subs_map = List.fold_left + (fun m (s, e) -> StrMap.add (symbol_to_armc s) e m) StrMap.empty subs in + let find_subst v default = + try StrMap.find v subs_map |> expr_to_armc with Not_found -> default in + let kv = symbol_to_armc sym in + let card, value, data = StrMap.find kv state.kv_scope |> split_scope in + Printf.sprintf "%s = 1" (mk_data_var ~suffix:suffix kv card) + :: Printf.sprintf "%s = %s" + (mk_data_var ~suffix:suffix kv value) + (find_subst vv (mk_data_var exists_kv vv)) + :: List.map + (fun v -> + Printf.sprintf "%s = %s" + (mk_data_var ~suffix:suffix kv v) + (find_subst v (mk_data_var exists_kv v)) + ) data |> String.concat ", " + ) rs |> String.concat ", " + +let mk_rule from_pc from_data to_pc to_data annot_guards annot_updates id = +(* + let unless_error l = if to_pc = error_pc then to_pc else l in + let from_pc, to_pc = + if id = "t_init" then + from_pc, unless_error "l0" + else if List.mem id ["11"; "12"; "13"; "14"; "15"; "16"; "17"; "18"; "19"] then + "l0", unless_error "l1" + else if List.mem id ["1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; "10"; "20"; "21"; "22"; "23"; "24"; "25"; "26"; "27"; "28"] then + "l1", unless_error "l1" + else if List.mem id ["29"; "30"; "31"; "32"; "33"; "34"; "35"; "36"; "37"; "38"; "39"; "40"; "41"; "42"; "43"; "44"; "45"] then + "l1", unless_error "l2" + else + "l2", unless_error "l2" + in +*) + let rec annot_conj_to_armc = function + | (g, a) :: rest -> + if rest = [] then Printf.sprintf "\n %s \t%% %s\n ]," g a + else Printf.sprintf "\n %s, \t%% %s%s" g a (annot_conj_to_armc rest) + | [] -> "]," + in + Printf.sprintf + " +r(p(pc(%s), data(%s)), + p(pc(%s), data(%s)), + [%s + [%s + %s). +" + from_pc from_data to_pc to_data + (annot_conj_to_armc annot_guards) + (annot_conj_to_armc annot_updates) + id + +let t_to_armc from_data to_data state t = + let grd = C.grd_of_t t in + let lhs = C.lhs_of_t t in + let rhs = C.rhs_of_t t in + let rhs_s = C.reft_to_string rhs in + let tag = try string_of_int (C.id_of_t t) with _ -> + failure "ERROR: t_to_armc: anonymous constraint %s" (C.to_string t) in + let annot_guards = + List.map + (fun (bv, reft) -> + reft_to_armc state (C.theta [(C.vv_of_reft reft, Ast.eVar bv)] reft), + C.binding_to_string (bv, reft) + ) (C.env_of_t t |> C.bindings_of_env) + ++ [(pred_to_armc grd, Ast.Predicate.to_string grd); + (reft_to_armc state lhs, "|- " ^ (C.reft_to_string lhs))] in + let ps, kvs = + List.fold_left (fun (ps', kvs') refa -> + match refa with + | C.Conc p -> p::ps', kvs' + | C.Kvar (subs, sym) -> ps', (subs, sym)::kvs' + ) ([], []) (C.ras_of_reft rhs) in + (if ps <> [] then + [mk_rule loop_pc from_data error_pc to_data annot_guards + [(Ast.pAnd ps |> Ast.pNot |> pred_to_armc, "<: " ^ rhs_s)] + tag] + else + []) + ++ + (List.map + (fun (_, sym) -> + let kv = symbol_to_armc sym in + let skip_kvs = List.filter (fun kv' -> kv <> kv') state.kvs in + mk_rule loop_pc from_data loop_pc + (mk_data ~suffix:primed_suffix ~skip_kvs:skip_kvs state) + annot_guards + [(reft_to_armc ~suffix:primed_suffix state rhs, "<: " ^ rhs_s)] + tag + ) kvs) + +let to_armc out ts wfs = + print_endline "Translating to ARMC."; + let state = mk_kv_scope out ts wfs in + let from_data = mk_data state in + let to_data = mk_data ~suffix:primed_suffix state in + Printf.fprintf out + ":- multifile r/5,implicit_updates/0,var2names/2,preds/2,trans_preds/3,cube_size/1,start/1,error/1,refinement/1,cutpoint/1,invgen_template/2,invgen_template/1,cfg_exit_relation/1,stmtsrc/2,strengthening/2. + +refinement(inter). +cube_size(1). + +start(pc(%s)). +error(pc(%s)). +cutpoint(pc(%s)). + +preds(p(_, data(%s)), [%s]). + +trans_preds(p(_, data(%s)), p(_, data(%s)), []). + +var2names(p(_, data(%s)), [%s]). +" + start_pc error_pc loop_pc + from_data (List.map (fun kv -> + let card, _, _ = StrMap.find kv state.kv_scope |> split_scope in + let kv_card = mk_data_var kv card in + Printf.sprintf "%s = 0, %s = 1" kv_card kv_card + ) state.kvs |> String.concat ", ") (* preds *) + from_data to_data (* trans_preds *) + from_data (mk_var2names state); (* var2names *) + output_string out + (mk_rule start_pc from_data loop_pc to_data [] + [(List.map + (fun kv -> + let card, _, _ = StrMap.find kv state.kv_scope |> split_scope in + Printf.sprintf "%s = 0" (mk_data_var ~suffix:primed_suffix kv card) + ) state.kvs |> String.concat ", ", + "")] + "t_init"); + List.iter (fun t -> t_to_armc from_data to_data state t |> List.iter (output_string out)) ts + + +(* + make -f Makefile.fixtop && ./f -latex /tmp/main.tex -armc /tmp/a.pl tests/pldi08-max.fq && cat /tmp/a.pl + +tests: + +for file in `ls pldi08-*-atom.fq`; do ../f -latex /tmp/main.tex -armc /tmp/a.pl $file; head -n 1 /tmp/a.pl; armc a.pl | grep correct; done + +pldi08-arraymax-atom.fq pass +pldi08-max-atom.fq pass +pldi08-foldn-atom.fq pass +pldi08-sum-atom.fq pass +mask-atom.fq pass +samples-atom.fq pass + +test00.c pass + +*) diff --git a/external/fixpoint/toDot.ml b/external/fixpoint/toDot.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/toDot.ml @@ -0,0 +1,173 @@ +module C = FixConstraint +module StrSet = Set.Make (struct type t = string let compare = compare end) +module StrStrSet = Set.Make (struct type t = StrSet.t let compare = StrSet.compare end) + +module S2 = StrSet +module S3 = StrStrSet +module Misc = FixMisc open Misc.Ops + + +module V = struct + type t = string + let compare = Pervasives.compare + let hash = Hashtbl.hash + let equal = (=) +end +module E = struct + type t = string + let compare = Pervasives.compare + let default = "" +end + + +module G = Graph.Persistent.Digraph.ConcreteLabeled(V)(E) + +module Display = struct + include G + let vertex_name v = "\"" ^ String.escaped v ^ "\"" + let graph_attributes _ = [] + let default_vertex_attributes _ = [] + let vertex_attributes _ = [] + let default_edge_attributes _ = [] + let edge_attributes e = [`Label (G.E.label e)] + let get_subgraph _ = None +end + +module DotOutput = Graph.Graphviz.Dot(Display) + +module SCC = Graph.Components.Make(G) + +let vertices_of_graph g = G.fold_vertex (fun v vs -> v::vs) g [] +let edges_e_of_graph g = G.fold_edges_e (fun e es -> e::es) g [] + +let set_of_strings = List.fold_left (fun s x -> StrSet.add x s) StrSet.empty + +let set_to_string default s = + if StrSet.is_empty s then default else StrSet.elements s |> List.map String.escaped |> String.concat ", " + +let edges_e_to_graph es = List.fold_left (fun g e -> G.add_edge_e g e) G.empty es + +(* k_1, ..., k_n <: k_0 depends on l_1, ..., l_m <: l_0 iff l_0 = k_i for some 1 \leq i \leq n *) + + +let t_to_dep t = + let env = C.env_of_t t in + let lhs = C.lhs_of_t t in + let rhs = C.rhs_of_t t in + let tag = try string_of_int (C.id_of_t t) with _ -> + failure "ERROR: t_to_edge: anonymous constraint %s" (C.to_string t) in + let src = + C.kvars_of_reft lhs :: List.map (fun b -> snd b |> C.kvars_of_reft) (C.bindings_of_env env) |> + List.flatten |> List.map snd |> List.map Ast.Symbol.to_string |> set_of_strings in + let dst = C.kvars_of_reft rhs |> List.map snd |> List.map Ast.Symbol.to_string |> set_of_strings in + src, tag, dst + +let sccs_to_dot g prefix = + let n, scc_of = SCC.scc g in + let vs = vertices_of_graph g in + Printf.printf "%s #scc = %d\n" prefix n; + for i = 0 to n-1 do + let scc, rest = List.partition (fun v -> scc_of v = i) vs in + let g' = List.fold_left (fun g'' v -> G.remove_vertex g'' v) g rest in + let out = open_out (Printf.sprintf "/tmp/%s-scc-%d.dot" prefix i) in + Printf.printf "%s scc %d %s\n" prefix i (String.concat ", " scc); + DotOutput.output_graph out g'; + close_out out + done + + +let mk_dep_graph ts = + let ds' = List.map t_to_dep ts in + let ds = List.map (fun (src, tag, dst) -> + (if StrSet.is_empty src then StrSet.singleton "start" else src), + tag, + (if StrSet.is_empty dst then StrSet.singleton "error" else dst) + ) ds' in + let g = + List.map + (fun (src, tag, dst) -> + Misc.map_partial + (fun (src', tag', dst') -> + let inter = StrSet.inter dst src' in + if StrSet.is_empty inter then + None + else + begin + Printf.printf "self loop %s\n" tag; + Some(G.E.create tag (set_to_string "" inter) tag') (* tag depends on tag' via inter *) + end + ) ds + ) ds |> List.flatten |> edges_e_to_graph in + let srcs = List.fold_left (fun xs (src, tag, dst) -> src::xs) [] ds' in + +(* + let veanu = + List.fold_left (fun xs src -> + S3.fold (fun x ys -> + ys |> S3.add (S2.diff x src) |> S3.add (S2.diff src x) |> S3.add (S2.inter x src) + ) xs S3.empty + ) (List.hd srcs |> S3.singleton) (List.tl srcs) in +*) + let oc = open_out "/tmp/dep.dot" in + DotOutput.output_graph oc g; + close_out oc; + sccs_to_dot g "dep"; + print_endline "start deps"; + List.iter (fun (src, tag, dst) -> + Printf.printf "%s <: %s (%s)\n" (set_to_string "" src) (set_to_string "" dst) tag) ds; + print_endline "end deps"; + print_endline "start dep graph"; + List.iter (fun e -> + Printf.printf "%s - %s -> %s\n" (G.E.src e) (G.E.label e) (G.E.dst e)) (edges_e_of_graph g); + print_endline "end dep graph" +(* + Printf.printf "Veanu %d sets\n%s\n" + (S3.cardinal veanu) + (S3.fold (fun x s -> + (Printf.sprintf "{%s}" (set_to_string "empty" x))::s + ) veanu [] |> String.concat ",\n") +*) + + +let other_graph ts = + let deps = List.map t_to_dep ts in + let srcs, dsts = List.map (fun (s, _, d) -> s, d) deps |> List.split in + let es = List.map (fun (src, tag, dst) -> + G.E.create (set_to_string "start" src) tag (set_to_string "error" dst) + ) deps in + let es' = List.fold_left (fun es'' dst -> + Misc.map_partial (fun src -> + if StrSet.diff dst src |> StrSet.is_empty then + Some (G.E.create (set_to_string "error" dst) "" (set_to_string "start" src)) + else + None + ) srcs ++ es'' + ) es dsts in + let g = List.fold_left (fun g e -> G.add_edge_e g e) G.empty es' in + g + +let t_to_edge t = + let srcs', tag, dsts' = t_to_dep t in + let srcs = if StrSet.is_empty srcs' then ["start"] else StrSet.elements srcs' in + let dsts = if StrSet.is_empty dsts' then ["error"] else StrSet.elements dsts' in + List.fold_left (fun es src -> List.map (G.E.create src tag) dsts ++ es) [] srcs + + + + +let to_dot oc ts = + let _ = List.fold_left (fun g e -> G.add_edge_e g e ) G.empty (List.map t_to_edge ts |> List.flatten) in + let g = other_graph ts in + let vs = G.fold_vertex (fun v vs' -> v::vs') g [] in + let n, scc_of = SCC.scc g in + DotOutput.output_graph oc g; + Printf.printf "#scc = %d\n" n; + for i = 0 to n-1 do + let scc, rest = List.partition (fun v -> scc_of v = i) vs in + let g' = List.fold_left (fun g'' v -> G.remove_vertex g'' v) g rest in + let out = open_out (Printf.sprintf "/tmp/scc-%d.dot" i) in + Printf.printf "scc %d %s\n" i (String.concat ", " scc); + DotOutput.output_graph out g'; + close_out out + done; + mk_dep_graph ts diff --git a/external/fixpoint/toHC.ml b/external/fixpoint/toHC.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/toHC.ml @@ -0,0 +1,613 @@ +(* translation to HC'ARMC *) + + +module C = FixConstraint +module Co = Constants +module Sy = Ast.Symbol +module Su = Ast.Subst +module P = Ast.Predicate +module E = Ast.Expression +module StrMap = Map.Make (struct type t = string let compare = compare end) +module StrSet = Set.Make (struct type t = string let compare = compare end) +module Misc = FixMisc open Misc.Ops + +let strlist_to_strset = List.fold_left (fun s x -> StrSet.add x s) StrSet.empty + + +let armc_true = "1=1" +let armc_false = "0=1" +(* +let armc_true = "true" +let armc_false = "false" +*) +let loop_pc = "loop" +let start_pc = "start" +let error_pc = "error" +let val_vname = "AA_0" +let card_vname = "CARD" +let exists_kv = "EX" +let primed_suffix = "p" +let str__cil_tmp = "__cil_tmp" + +type kv_scope = { + kvs : string list; + kv_scope : string list StrMap.t; + sol : Ast.pred list Sy.SMap.t; +} + +type horn_clause = { + body_pred : Ast.pred; + body_kvars : (Su.t * Sy.t) list; + head_pred : Ast.pred; + head_kvar_opt : (Su.t * Sy.t) option; + tag : string; +} + +let sanitize_symbol s = + Str.global_replace (Str.regexp "@") "_at_" s |> Str.global_replace (Str.regexp "#") "_hash_" |> + Str.global_replace (Str.regexp "\\.") "_dot_" |> Str.global_replace (Str.regexp "'") "_q_" + +let symbol_to_armc s = Sy.to_string s |> sanitize_symbol + +let mk_data_var ?(suffix = "") kv v = + Printf.sprintf "_%s_%s%s%s" + (sanitize_symbol v) (sanitize_symbol kv) (if suffix = "" then "" else "_") suffix + +let mk_data ?(suffix = "") ?(skip_kvs = []) s = + Printf.sprintf "[%s]" + (List.map + (fun kv -> + try + StrMap.find kv s.kv_scope |> + List.map (mk_data_var ~suffix:(if List.mem kv skip_kvs then "" else suffix) kv) + with Not_found -> failure "ERROR: rel_state_vs: scope not found for %s" kv + ) s.kvs |> List.flatten |> String.concat ", ") + +let constant_to_armc = Ast.Constant.to_string +let bop_to_armc = function + | Ast.Plus -> "+" + | Ast.Minus -> "-" + | Ast.Times -> "*" + | Ast.Div -> "/" +let brel_to_armc = function + | Ast.Eq -> "=" + | Ast.Ne -> "=\\=" + | Ast.Gt -> ">" + | Ast.Ge -> ">=" + | Ast.Lt -> "<" + | Ast.Le -> "=<" +let bind_to_armc (s, t) = (* Andrey: TODO support binders *) + Printf.sprintf "%s:%s" (symbol_to_armc s) (Ast.Sort.to_string t |> sanitize_symbol) +let rec expr_to_armc expr = + let e = E.unwrap expr in + match e with + | Ast.Con c -> constant_to_armc c + | Ast.Var s -> mk_data_var exists_kv (symbol_to_armc s) + | Ast.App (s, es) -> + if !Co.purify_function_application then "_" else + let str = symbol_to_armc s in + if es = [] then str else + Printf.sprintf "f_%s(%s)" str (List.map expr_to_armc es |> String.concat ", ") + | Ast.Bin (e1, op, e2) -> + Printf.sprintf "(%s %s %s)" + (expr_to_armc e1) (bop_to_armc op) (expr_to_armc e2) + | Ast.Ite (ip, te, ee) -> + Printf.sprintf "ite(%s, %s, %s)" + (pred_to_armc ip) (expr_to_armc te) (expr_to_armc ee) + | Ast.Fld (s, e) -> + Printf.sprintf "fld(%s, %s)" (expr_to_armc e) (symbol_to_armc s) + | _ -> failwith (Printf.sprintf "expr_to_armc: %s" (E.to_string expr)) +and pred_to_armc pred = + let p = P.unwrap pred in + match p with + | Ast.True -> armc_true + | Ast.False -> armc_false + | Ast.Bexp e -> Printf.sprintf "%s = 1" (expr_to_armc e) + | Ast.Not (Ast.True, _) -> armc_false + | Ast.Not (Ast.False, _) -> armc_true + | Ast.Not p -> Printf.sprintf "neg(%s)" (pred_to_armc p) + | Ast.Imp (p1, p2) -> Printf.sprintf "imp(%s, %s)" (pred_to_armc p1) (pred_to_armc p2) + | Ast.And [] -> armc_true + | Ast.And [p] -> pred_to_armc p + | Ast.And (_::_ as ps) -> + Printf.sprintf "(%s)" (List.map pred_to_armc ps |> String.concat ", ") + | Ast.Or [] -> armc_false + | Ast.Or [p] -> pred_to_armc p + | Ast.Or (_::_ as ps) -> Printf.sprintf "(%s)" (List.map pred_to_armc ps |> String.concat "; ") + | Ast.Atom (e1, Ast.Eq, (Ast.Ite(ip, te, ee), _)) -> + let ip_str = pred_to_armc ip in + let e1_str = expr_to_armc e1 in + Printf.sprintf "((%s, %s = %s); (neg(%s), %s = %s))" + ip_str e1_str (expr_to_armc te) + ip_str e1_str (expr_to_armc ee) + | Ast.Atom (e1, r, e2) -> + Printf.sprintf "%s %s %s" + (expr_to_armc e1) (brel_to_armc r) (expr_to_armc e2) + | Ast.Forall (qs,p) -> (* Andrey: TODO support forall *) + Printf.sprintf "forall([%s], %s)" + (List.map bind_to_armc qs |> String.concat ", ") + (pred_to_armc p) + +let preds_kvars_of_reft reft = + List.fold_left + (fun (ps, ks) r -> + match r with + | C.Conc p -> p :: ps, ks + | C.Kvar (subs, kvar) -> ps, (subs, kvar) :: ks + ) ([], []) (C.ras_of_reft reft) + +let preds_to_pred ps = + match ps with + | [] -> Ast.pTrue + | [p] -> p + | _ :: _ -> Ast.pAnd ps + +let rec flatten_pAnd pred = + match P.unwrap pred with + | Ast.And [] -> [] + | Ast.And [p] -> flatten_pAnd p + | Ast.And ps -> List.map flatten_pAnd ps |> List.flatten + | _ -> [pred] + +let t_to_horn_clause t = + let lhs_ps, lhs_ks = C.lhs_of_t t |> preds_kvars_of_reft in + let body_ps, body_ks = + Sy.SMap.fold + (fun bv reft (ps, ks) -> + let ps', ks' = preds_kvars_of_reft (C.theta (Su.of_list [(C.vv_of_reft reft, Ast.eVar bv)]) reft) in + List.rev_append ps' ps, List.rev_append ks' ks + ) (C.env_of_t t) (C.grd_of_t t :: lhs_ps, lhs_ks) in + let head_ps, head_ks = C.rhs_of_t t |> preds_kvars_of_reft in + let head_kvar_opt = + match head_ks with + | [] -> None + | [head_kvar] -> Some head_kvar + | _ -> + failwith (Printf.sprintf "t_to_horn_clause: multiple k's in rhs of %d" (C.id_of_t t)); + in + { + body_pred = Ast.pAnd body_ps |> flatten_pAnd |> preds_to_pred; + body_kvars = body_ks; + head_pred = Ast.pAnd head_ps |> flatten_pAnd |> preds_to_pred; + head_kvar_opt = head_kvar_opt; + tag = C.id_of_t t |> string_of_int; + } + +let horn_clause_to_string hc = + Printf.sprintf "%s: %s, %s :- %s, %s." + hc.tag + (P.to_string hc.head_pred) + (match hc.head_kvar_opt with + | Some (subs, kvar) -> C.refa_to_string (C.Kvar (subs, kvar)) + | None -> "none" + ) + (P.to_string hc.body_pred) + (List.map (fun (subs, kvar) -> C.refa_to_string (C.Kvar (subs, kvar))) hc.body_kvars |> String.concat ", ") + + +module CFGNodeSet = Set.Make (struct type t = StrSet.t let compare = StrSet.compare end) + + +module DepV = struct + type t = string + let compare = Pervasives.compare + let hash = Hashtbl.hash + let equal = (=) +end +module DepE = struct + type t = string + let compare = Pervasives.compare + let default = "" +end +module DepG = Graph.Persistent.Digraph.ConcreteLabeled(DepV)(DepE) + +module Display = struct + include DepG + let vertex_name v = DepG.V.label v + let graph_attributes _ = [] + let default_vertex_attributes _ = [] + let vertex_attributes _ = [] + let default_edge_attributes _ = [] + let edge_attributes _ = [] + let get_subgraph _ = None +end +module DepGToDot = Graph.Graphviz.Dot(Display) +module DepGOper = Graph.Oper.P(DepG) + +module DepGSCC = Graph.Components.Make(DepG) + +module G = Graph.Pack.Digraph + +let hc_to_dep hc = + (match hc.head_kvar_opt with + | Some (_, sym) -> Some (symbol_to_armc sym) + | None -> None + ), + List.map (fun (_, sym) -> symbol_to_armc sym) hc.body_kvars |> List.sort compare + +(* +let mk_cfg state hcs = + let nodes = ref (CFGNodeSet.singleton StrSet.empty) in + let nodes_size = ref 0 in + let nodes_size' = ref 1 in + while !nodes_size < !nodes_size' do + nodes_size := CFGNodeSet.cardinal !nodes; + List.iter (fun hc -> + let heads, body = hc_to_dep hc in + let body_set = List.fold_left (fun sofar b -> StrSet.add b sofar) StrSet.empty body in + List.iter (fun node -> + List.iter (fun head -> + if StrSet.subset body_set node then + nodes := CFGNodeSet.add (StrSet.add head node) !nodes + ) heads + ) (CFGNodeSet.elements !nodes) + ) hcs; + nodes_size' := CFGNodeSet.cardinal !nodes + done; + Printf.printf "nodes: %s\n" (List.sort compare state.kvs |> String.concat ", "); + CFGNodeSet.iter (fun node -> + Printf.printf "node: %s\n" (StrSet.elements node |> List.sort compare |> String.concat ", ") + ) !nodes; + let g = G.create () in + List.iter (fun hc -> + let heads, body = hc_to_dep hc in + List.iter (fun b -> + List.iter (fun head -> + G.add_edge g (G.V.create 1) (G.V.create 2) + ) heads + ) body + ) hcs; + let depg = + List.fold_left + (fun g hc -> + let heads, body = hc_to_dep hc in + List.fold_left + (fun g' b -> + List.fold_left + (fun g'' head -> + DepG.add_edge_e g'' (DepG.E.create b (* hc.tag *) "" head) + ) g' heads + ) g body + ) DepG.empty hcs in + let dep_cs = + List.fold_left + (fun g hc -> + let heads, _ = hc_to_dep hc in + List.fold_left + (fun g' hc' -> + (* check if heads intersect body' *) + let _, body' = hc_to_dep hc' in + if hc.tag <> hc'.tag && List.exists (fun head -> List.mem head body') heads then + DepG.add_edge g' hc.tag hc'.tag + else + g' + ) g hcs + ) DepG.empty hcs in + let out = open_out "/var/tmp/awesome/g.dot" in + DepGToDot.output_graph out depg; + close_out out; + let out = open_out "/var/tmp/awesome/t.dot" in + DepGToDot.output_graph out (DepGOper.transitive_closure depg); + close_out out; + let out = open_out "/var/tmp/awesome/cs.dot" in + DepGToDot.output_graph out dep_cs; + close_out out +*) + + +let kvar_to_hc_armcs ?(suffix = "") state (subs, sym) = + let subs_map = List.fold_left (fun m (s, e) -> StrMap.add (symbol_to_armc s) e m) StrMap.empty (Su.to_list subs) in + let find_subst v default = try StrMap.find v subs_map |> expr_to_armc with Not_found -> default in + let kv = symbol_to_armc sym in + try + let scope = StrMap.find kv state.kv_scope in + Printf.sprintf "%s(%s)" + kv (List.map (mk_data_var ~suffix:suffix kv) scope |> String.concat ", ") + :: List.map (fun v -> + Printf.sprintf "%s = %s" + (mk_data_var ~suffix:suffix kv v) (find_subst v (mk_data_var exists_kv v)) + ) scope + with Not_found -> [armc_true] (* input variable *) + +let kvar_to_armcs ?(suffix = "") ?(with_card=true) state (subs, sym) = + let subs_map = + List.fold_left (fun m (s, e) -> StrMap.add (symbol_to_armc s) (expr_to_armc e) m) StrMap.empty (Su.to_list subs) in + let find_subst v default = try StrMap.find v subs_map with Not_found -> default in + let kv = symbol_to_armc sym in + try + let scope = StrMap.find kv state.kv_scope in + let card_armc, data = + if with_card then + [Printf.sprintf "%s = 1" (mk_data_var ~suffix:suffix kv card_vname)], List.tl scope + else + [], scope + in + card_armc + @ List.map (fun v -> + Printf.sprintf "%s = %s" + (mk_data_var ~suffix:suffix kv v) (find_subst v (mk_data_var exists_kv v)) + ) data |> String.concat ", " + with Not_found -> armc_true (* input variable *) + +let hc_to_rule state hc = + let mk_rule head body tag = Printf.sprintf "rule(%s, %s, [%s])." tag head body in + let body = + pred_to_armc hc.body_pred :: (List.map (kvar_to_hc_armcs state) hc.body_kvars |> List.flatten) |> + String.concat ", " in + let prules = + if P.is_tauto hc.head_pred then [] + else [mk_rule error_pc (Printf.sprintf "%s, %s" body (Ast.pNot hc.head_pred |> pred_to_armc)) hc.tag] in + let krules = + match hc.head_kvar_opt with + | Some kvar -> + let head_armcs = kvar_to_hc_armcs ~suffix:primed_suffix state kvar in + [mk_rule + (List.hd head_armcs) (* kv *) + (body :: (List.tl head_armcs (* subs *)) |> String.concat ", ") + hc.tag] + | None -> [] + in + krules @ prules + +let mk_rule from_pc from_data to_pc to_data guard update tag = + Printf.sprintf "r(p(pc(%s), data(%s)),\np(pc(%s), data(%s)),\n[%s],\n[%s], %s).%s" + from_pc from_data to_pc to_data guard update tag + (if guard = "" && update = "" then Printf.sprintf "\nid_trans(%s)." tag else "") + +let hc_to_armc ?(cfg=false) ?(with_card=true) ?(with_dataflow=false) state hc = + let from_data = mk_data state in + let to_data = mk_data ~suffix:primed_suffix state in + let body = pred_to_armc hc.body_pred :: List.map (kvar_to_armcs ~with_card:with_card state) hc.body_kvars in + let body_kv_strs = hc_to_dep hc |> snd |> List.filter (fun kv -> StrMap.mem kv state.kv_scope) in + let prules = + if P.is_tauto hc.head_pred then [] + else + mk_rule + (if cfg then Printf.sprintf "src_%s" hc.tag else loop_pc) + from_data error_pc to_data + ((Ast.pNot hc.head_pred |> pred_to_armc) :: body |> String.concat ",\n") "" hc.tag + :: + if with_dataflow then + [Printf.sprintf "dataflow_transition(%s, [%s], [])." hc.tag (String.concat ", " body_kv_strs)] + else [] in + let krules = + match hc.head_kvar_opt with + | Some ((subs, sym) as kvar) -> + let kv = symbol_to_armc sym in + let skip_kvs = List.filter (fun kv' -> kv <> kv') state.kvs in + mk_rule + (if cfg then Printf.sprintf "src_%s" hc.tag else loop_pc) + from_data + (if cfg then Printf.sprintf "dst_%s" hc.tag else loop_pc) + (mk_data ~suffix:primed_suffix ~skip_kvs:skip_kvs state) + (body |> String.concat ",\n") + (kvar_to_armcs ~with_card:with_card ~suffix:primed_suffix state kvar) + hc.tag + :: + if with_dataflow then + [Printf.sprintf "dataflow_transition(%s, [%s], [%s])." hc.tag (String.concat ", " body_kv_strs) kv] + else [] + | None -> [] + in + krules @ prules + +let mk_hc_var2names state = + List.map + (fun kv -> + Printf.sprintf "var2names(p(pc(%s), data(%s)), [%s])." + kv + (List.map (mk_data_var kv) (StrMap.find kv state.kv_scope) |> String.concat ", ") + (List.map + (fun v -> + Printf.sprintf "(%s, \'%s_%s\')" (mk_data_var kv v) v kv + ) (StrMap.find kv state.kv_scope) |> String.concat ", ") + ) state.kvs |> String.concat "\n" + +let mk_var2names state = + Printf.sprintf "var2names(p(pc(_), data(%s)), [%s])." + (mk_data state) + (List.map + (fun kv -> + List.map + (fun v -> + Printf.sprintf "(%s, \'%s_%s\')" (mk_data_var kv v) v kv + ) (StrMap.find kv state.kv_scope) |> String.concat ", " + ) state.kvs |> String.concat ", ") + +let mk_hc_preds state = + List.map + (fun kv -> + Printf.sprintf "preds(p(pc(%s), data(%s)), [])." + kv + (List.map (mk_data_var kv) (StrMap.find kv state.kv_scope) |> String.concat ", ") + ) state.kvs |> String.concat "\n" + +let mk_preds ?(with_card = true) state = + let preds = + if with_card then + List.map (fun kv -> + let card = StrMap.find kv state.kv_scope |> List.hd in + let kv_card = mk_data_var kv card in + Printf.sprintf "%s = 0, %s = 1" kv_card kv_card + ) state.kvs |> String.concat ", " + else + "" + in + Printf.sprintf "preds(p(pc(_), data(%s)), [%s])." (mk_data state) preds + +let mk_start_rule state = + mk_rule start_pc (mk_data state) loop_pc (mk_data ~suffix:primed_suffix state) "" + (List.map (fun kv -> + let card = StrMap.find kv state.kv_scope |> List.hd in + Printf.sprintf "%s = 0" (mk_data_var ~suffix:primed_suffix kv card) + ) state.kvs |> String.concat ", ") + "start_t" + +let find_kv_wf_scope wfs kv = + let wf = + try List.find (fun wf -> + match C.reft_of_wf wf |> C.kvars_of_reft with + | [(subs, kvar)] -> Su.is_empty subs && kv = symbol_to_armc kvar + | _ -> false + ) wfs + with Not_found -> failwith (Printf.sprintf "find_wf_scope: %s" kv) + in + Sy.SMap.fold (fun kvar _ sofar -> StrSet.add (symbol_to_armc kvar) sofar) (C.env_of_wf wf) StrSet.empty + +(* map each k variable to variables in its scope *) +(* k variables no appearing in any rhs don't have any scope *) +let mk_kv_scope ?(with_card=true) ?(hcs=[]) out ts wfs sol = + (* + List.iter (fun wf -> + let env = C.env_of_wf wf in + let bvs = Sy.SMap.fold (fun bv _ sofar -> symbol_to_armc bv :: sofar) env [] in + Printf.printf "wf: %s : %s\n" (C.reft_of_wf wf |> C.reft_to_string) (String.concat ", " bvs) + ) wfs; + *) + let hcs = if hcs = [] then List.map t_to_horn_clause ts else hcs in + let hc_deps = List.map hc_to_dep hcs in + let kv_scope_aux = + ref (List.fold_left (fun kv_scope' t -> + (* collect bound vars of t *) + let scope = + Sy.SMap.fold (fun bv _ scope' -> + StrSet.add (symbol_to_armc bv) scope' + ) (C.env_of_t t) StrSet.empty in + let _, rhs_kvs = C.rhs_of_t t |> C.preds_kvars_of_reft in + (* add these bound vars to the scope of each k var in rhs of t *) + List.fold_left (fun kv_scope'' kv -> + StrMap.add kv (StrSet.union + (try StrMap.find kv kv_scope'' with Not_found -> StrSet.empty) + scope) kv_scope'' + ) kv_scope' (List.map snd rhs_kvs |> List.map symbol_to_armc) + ) StrMap.empty ts) in + let done_flag = ref false in + (* if k' depends on k then scope(k') contains scope(k) *) + while not(!done_flag) do + done_flag := true; + List.iter (fun (head_opt, body) -> + match head_opt with + | Some kv' -> + let scope_kv' = StrMap.find kv' !kv_scope_aux in + let size_scope_kv' = StrSet.cardinal scope_kv' in + let upd_scope_kv' = + List.fold_left (fun sofar kv -> + StrSet.union (try StrMap.find kv !kv_scope_aux with Not_found -> StrSet.empty) sofar + ) scope_kv' body + in + if size_scope_kv' < StrSet.cardinal upd_scope_kv' then + begin + kv_scope_aux := StrMap.add kv' upd_scope_kv' !kv_scope_aux; + done_flag := false + end + | None -> () + ) hc_deps + done; + let kv_scope = + (* sort scope, add value variable and, if needed, cardinality variable *) + StrMap.mapi (fun kv scope -> + let scope' = val_vname :: (StrSet.inter scope (find_kv_wf_scope wfs kv) |> StrSet.elements |> List.sort compare) in + if with_card then card_vname :: scope' else scope' + ) !kv_scope_aux in + let kvs = StrMap.fold (fun kv _ kvs -> kv :: kvs) kv_scope [] in + StrMap.iter (fun kv scope -> + Printf.fprintf out "%% %s -> %s\n" kv (String.concat ", " scope)) kv_scope; + {kvs = kvs; kv_scope = kv_scope; sol = sol} + + +let to_horn out ts wfs sol = + print_endline "Translating to Horn clauses."; +(* let cex = [1;2;4;5;9;23;24] in *) + let cex = [] in + let ts = if cex = [] then ts else List.filter (fun t -> List.mem (C.id_of_t t) cex) ts in + let state = mk_kv_scope out ~with_card:false ts wfs sol in + Printf.fprintf out + ":- multifile rule/3, var2names/2, preds/2, error/1. + +error(%s). +%s +%s +" + error_pc + (mk_hc_var2names state) + (mk_hc_preds state); + List.iter (fun t -> + Printf.fprintf out "/*\n%s\n%s\n*/\n" (C.to_string t) (t_to_horn_clause t |> horn_clause_to_string); + List.iter (fun r -> + output_string out r; + output_string out "\n\n" + ) (t_to_horn_clause t |> hc_to_rule state) + ) ts + +let to_armc out ts wfs sol = + print_endline "Translating to ARMC. ToHC.to_armc"; +(* let cex = [1;5;13;14;68;69;54] in *) + let cex = [] in + let state = mk_kv_scope out ts wfs sol in + Printf.fprintf out + ":- multifile r/5,implicit_updates/0,var2names/2,preds/2,trans_preds/3,cube_size/1,start/1,error/1,refinement/1,cutpoint/1,invgen_template/2,invgen_template/1,cfg_exit_relation/1,stmtsrc/2,strengthening/2. +refinement(inter). +cube_size(1). + +start(pc(%s)). +error(pc(%s)). +cutpoint(pc(%s)). +\n%s\n\n%s\n +" + start_pc error_pc loop_pc + (mk_var2names state) + (mk_preds state); + Printf.fprintf out "%s\n\n" (mk_start_rule state); + List.iter (fun t -> + if List.mem (C.id_of_t t) cex || List.length cex = 0 then + let hc = t_to_horn_clause t in + Printf.fprintf out "/*\n%s%s\n*/\n" (C.to_string t) (horn_clause_to_string hc); + List.iter (fun r -> + output_string out r; + output_string out "\n\n" + ) (hc_to_armc state hc) + else + () + ) ts; + List.iter (fun id -> + List.iter (fun t -> + if List.mem (C.id_of_t t) cex then + Printf.printf "%s\n" (C.to_string t) + ) ts + ) cex + + +let to_dataflow_armc out ts wfs sol = + print_endline "Translating to ARMC. ToHC.to_dataflow_armc "; + let with_card_flag = false in +(* let cex = [1;2;4;5;9;23;24] in *) + let cex = [] in + let ts = (if cex = [] then ts else List.filter (fun t -> List.mem (C.id_of_t t) cex) ts) in + let hcs = List.map t_to_horn_clause ts in + let state = mk_kv_scope ~with_card:with_card_flag ~hcs:hcs out ts wfs sol in + Printf.fprintf out + ":- multifile r/5,implicit_updates/0,var2names/2,preds/2,trans_preds/3,cube_size/1,start/1,error/1,refinement/1,cutpoint/1,invgen_template/2,invgen_template/1,cfg_exit_relation/1,stmtsrc/2,strengthening/2,id_trans/1,dataflow_transition/3. +refinement(inter). +cube_size(1). + +start(pc(%s)). +error(pc(%s)). + +\n%s\n\n%s\n +" + start_pc error_pc + (mk_var2names state) + (mk_preds ~with_card:with_card_flag state); + (* connect the start with the loop *) + Printf.fprintf out "%s\n\n" (mk_rule start_pc (mk_data state) loop_pc (mk_data state) "" "" "start"); + Printf.fprintf out "dataflow_transition(%s, [], []).\n\n" "start"; + List.iter + (fun hc -> + Printf.fprintf out "/*\n%s\n*/\n" (horn_clause_to_string hc); + (* the actual transition relation, each disjunct *) + List.iter (Printf.fprintf out "%s\n\n") (hc_to_armc ~cfg:false ~with_card:with_card_flag ~with_dataflow:true state hc) + ) hcs; + output_string out "/*\n"; + List.iter (fun t -> Printf.fprintf out "%s\n" (C.to_string t)) ts; + List.iter (fun hc -> Printf.fprintf out "%s\n\n" (horn_clause_to_string hc)) hcs; + output_string out "*/\n" diff --git a/external/fixpoint/toImp.ml b/external/fixpoint/toImp.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/toImp.ml @@ -0,0 +1,378 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONAst.Symbol. + * + *) + +(* This module implements the IMP language and translation from fixpoint constraints *) + + +module F = Format +module H = Hashtbl +module A = Ast +module E = A.Expression +module P = A.Predicate +module Sy = A.Symbol +module SM = Sy.SMap +module C = FixConstraint +module Cg = FixConfig +(*module BS = BNstats*) + +module Misc = FixMisc open Misc.Ops + +(**********************************************************************) +(************* Datatypes for IMP Representation ***********************) +(**********************************************************************) + +(* vars are always in lex order *) +(* We can have at most one set of temporaries in scope at a time + * so we share names and mark temporaries *) + +type var = PVar of Sy.t + | TVar of Sy.t + +type kvar = Ast.Subst.t * Sy.t + +type decl = RDecl of Sy.t * Sy.t list + | PDecl of Sy.t + +(* IMP commands *) + +type tupl = var list + +type instr = Assm of A.pred list + | Asst of A.pred list + | Asgn of var * var + | Rget of Sy.t * tupl + | Rset of tupl * Sy.t + | Havc of var + +type block = instr list + +type program = decl list * block list + +(**********************************************************************) +(************* Datatypes for IMP Representation ***********************) +(**********************************************************************) + +(* Convenience *) + +let mk_temp = function + | TVar v -> TVar v + | PVar v -> TVar v + +let rv_append v1 = function + | TVar v2 | PVar v2 -> + PVar (Sy.of_string (Sy.to_string v1 ^ "_" ^ Sy.to_string v2)) + +let collect_apps_from_pred p = + let apps = ref [] in + let f_exp e = + match E.unwrap e with + | A.App (s, es) -> apps := (s, List.length es) :: !apps + | t -> () in + P.iter (fun _ -> ()) f_exp p; !apps + +let collect_apps_from_instr = function + | Assm ps + | Asst ps -> + Misc.flap collect_apps_from_pred ps + | _ -> [] + +let collect_apps_from_block block = + Misc.flap collect_apps_from_instr block + +let collect_apps_from_program (_, blocks) = + Misc.flap collect_apps_from_block blocks + +(*************************************************************************) +(************* Rendering IMP to String ***********************************) +(*************************************************************************) + +let print_var ppf = function + | PVar v -> F.fprintf ppf "%a" Sy.print v + | TVar v -> F.fprintf ppf "'%a" Sy.print v + +let print_tuple ppf = + F.fprintf ppf "(%a)" (Misc.pprint_many false ", " print_var) + +let print_instr ppf = function + | Assm ps -> + F.fprintf ppf "@[assume %a;@]" P.print (A.pAnd ps) + | Asst ps -> + F.fprintf ppf "@[assert %a;@]" P.print (A.pAnd ps) + | Asgn (lhs, rhs) -> + F.fprintf ppf "@[%a@ :=@ %a;@]" print_var lhs print_var rhs + | Rget (rv, tupl) -> + F.fprintf ppf "@[%a@ <|@ %a;@]" print_tuple tupl Sy.print rv + | Rset (tupl, rv) -> + F.fprintf ppf "@[%a@ |>@ %a;@]" print_tuple tupl Sy.print rv + | Havc v -> + F.fprintf ppf "@[havoc@ %a;@]" print_var v + +let print_decl ppf = function + | RDecl (r, vs) -> + F.fprintf ppf "@[rel@ (%a)@ (%a);@]" Sy.print r + (Misc.pprint_many false ", " Sy.print) vs + | PDecl v -> + F.fprintf ppf "@[var@ %a;@]" Sy.print v + +let print_block ppf block = + F.fprintf ppf "@[%a@]" + (Misc.pprint_many false "\n" print_instr) block + +let print_program ppf (decls, blocks) = + F.fprintf ppf "@[%a@.%a@]" + (Misc.pprint_many false "\n" print_decl) decls + (Misc.pprint_many false "\n" print_block) blocks + +(* Printing as C syntax *) + +let print_brel_as_c ppf = function + | A.Eq -> F.fprintf ppf "==" + | A.Ne -> F.fprintf ppf "!=" + | A.Gt -> F.fprintf ppf ">" + | A.Ge -> F.fprintf ppf ">=" + | A.Lt -> F.fprintf ppf "<" + | A.Le -> F.fprintf ppf "<=" + +let print_bop_as_c ppf = function + | A.Plus -> F.fprintf ppf "+" + | A.Minus -> F.fprintf ppf "-" + | A.Times -> F.fprintf ppf "*" + | A.Div -> F.fprintf ppf "/" + +let rec print_predicate_as_c ppf pred = + match P.unwrap pred with + | A.True -> + F.fprintf ppf "True" + | A.False -> + F.fprintf ppf "False" + | A.Atom (e1, r, e2) -> + F.fprintf ppf "(%a %a %a)" print_expr_as_c e1 print_brel_as_c r print_expr_as_c e2 + | A.And ps -> + Misc.pprint_many false " && " P.print ppf ps + | A.Or ps -> + Misc.pprint_many false " || " P.print ppf ps + | A.Not p -> + F.fprintf ppf "!(%a)" print_predicate_as_c p + | A.Imp (p1, p2) -> + print_predicate_as_c ppf (A.pOr [A.pNot p1; p2]) + | A.Iff (p1, p2) -> + print_predicate_as_c ppf (A.pAnd [A.pImp (p1, p2); A.pImp (p2, p1)]) + | A.Bexp e -> + print_expr_as_c ppf e + | A.Forall (ds, p) -> + assert false + +and print_expr_as_c ppf expr = + match E.unwrap expr with + | A.Con c -> + F.fprintf ppf "%a" A.Constant.print c + | A.Var v -> + F.fprintf ppf "%a" Sy.print v + | A.App (f, es) -> + F.fprintf ppf "%a(%a)" Sy.print f + (Misc.pprint_many false ", " print_expr_as_c) es + | A.Bin (e1, op, e2) -> + F.fprintf ppf "(%a %a %a)" + print_expr_as_c e1 + print_bop_as_c op + print_expr_as_c e2 + | A.Ite (p, e1, e2) -> + F.fprintf ppf "(%a ? %a : %a)" + print_predicate_as_c p + print_expr_as_c e1 + print_expr_as_c e2 + | A.Fld (s, e) -> + print_expr_as_c ppf (A.eApp (Sy.of_string ("field" ^ Sy.to_string s), [e])) +(* | A.Mod (e1, i) -> + F.fprintf ppf "(%a mod %d)" print_expr_as_c e1 i +*) + +let print_var_as_c ppf = function + | PVar v -> F.fprintf ppf "%a" Sy.print v + | TVar v -> F.fprintf ppf "_%a" Sy.print v + +let sy_append v1 v2 = + Sy.of_string ((Sy.to_string v1) ^ "_" ^ (Sy.to_string v2)) + +let print_decl_as_c ppf = function + | RDecl (rv, tupl) -> + let pv v1 = (fun v2 -> F.fprintf ppf "@[int %a;@]@\n" Sy.print (sy_append v1 v2)) in + List.iter (pv rv) tupl + | PDecl v -> + F.fprintf ppf "@[int %a;@]@\n" Sy.print v + +let rec print_instr_as_c ppf = function + | Havc v -> + F.fprintf ppf "@[%a = nondet();@]" print_var_as_c v + | Asgn (v1, v2) -> + F.fprintf ppf "@[%a = %a@]" print_var_as_c v1 print_var_as_c v2 + | Assm ps -> + F.fprintf ppf "@[if (!(%a)) { diverge(); }@]" print_predicate_as_c (A.pAnd ps) + | Asst ps -> + F.fprintf ppf "@[if (!(%a)) { error(); }@]" print_predicate_as_c (A.pAnd ps) + | Rget (rv, tupl) -> + List.map (fun v -> Asgn (mk_temp v, rv_append rv v)) tupl |> + print_block_as_c ppf + | Rset (tupl, rv) -> + List.map (fun v -> Asgn (rv_append rv v, mk_temp v)) tupl |> + print_block_as_c ppf + +and print_block_as_c ppf block = + F.fprintf ppf "@[%a@]" + (Misc.pprint_many false "\n" print_instr_as_c) block + +let print_list ppf = List.iter (F.fprintf ppf "%s") + +let generate_uf (name, numargs) = + let rec mkargs n s = + if numargs > 0 then + mkargs (n-1) ("int, " ^ s) + else + s in + "int " ^ (Sy.to_string name) ^ "(" ^ (mkargs (numargs-1) "int") ^ ") {}" + +let prologue = + [ "void error() { ERROR: goto ERROR; }" + ; "void diverge() { DIV: goto DIV; }" + ; "int nondet() { int x; return x; }" + ; "int main() {" + ] + +let epilogue = + ["return 0; }"] + +let print_program_as_c ppf ((decls, blocks) as program) = + F.fprintf ppf "@[%a@.%a@.%a@.%a@.%a@.@]" + print_list (collect_apps_from_program program |> List.map generate_uf) + print_list prologue + (Misc.pprint_many false "\n" print_decl_as_c) decls + (Misc.pprint_many false "\n" print_block_as_c) blocks + print_list epilogue + +let check_imp (decls, instrs) = true +(* Translation from fixpoint to IMP *) + +(*************************************************************************) +(************* Converting FixConfig.deft to SMTLIB ***********************) +(*************************************************************************) + +(* Declarations *) + +let filter_wfs cs = + (* Misc.maybe_list (List.map (function Cg.Wfc x -> Some x | _ -> None) cs) *) + Misc.map_partial (function Cg.Wfc x -> Some x | _ -> None) cs + +let filter_subt cs = + Misc.map_partial (function Cg.Cst x -> Some x | _ -> None) cs + (* Misc.maybe_list (List.map (function Cg.Cst x -> Some x | _ -> None) cs) + *) + +let wf_to_decls wf = + let vars = wf |> C.env_of_wf + |> C.bindings_of_env + |> List.map fst + |> Misc.sort_and_compact + in + let kvars = C.kvars_of_reft (C.reft_of_wf wf) in + ( List.map (fun k -> RDecl (snd k, vars)) kvars + , List.map (fun v -> PDecl v) vars) + +let constraints_to_decls cs = + let decls = List.map wf_to_decls (filter_wfs cs) in + let (rdecls, pdecls) = (Misc.flap fst decls, Misc.flap snd decls) in + rdecls @ pdecls + +(* Constraint translation *) + +let rec get_kdecl kvar decls = + match decls with + | RDecl (k, vars) :: decls -> + if k = kvar then + vars + else + get_kdecl kvar decls + | _ :: decls -> get_kdecl kvar decls + | [] -> raise Not_found + +let sub_to_assume (var, expr) = + Assm [A.pAtom (A.eVar var, A.Eq, expr)] + +(* [[{t | p}]]_get *) + +let get_instrs vv decls (subs, kvar) = + let vars = get_kdecl kvar decls |> List.map (fun v -> TVar v) in + let assumes = subs |> Ast.Subst.to_list |> List.map sub_to_assume in + Rget (kvar, vars) :: assumes @ + [Asgn (PVar vv, List.hd vars)] + +let set_instr decls (subs, kvar) = + Rset (List.map (fun v -> TVar v) (get_kdecl kvar decls), kvar) + +let emptySol = PredAbs.read PredAbs.empty + +let reft_to_get_instrs decls reft = + let vv = C.vv_of_reft reft in + let kvars = C.kvars_of_reft reft in + let preds = C.preds_of_reft emptySol reft in + match (kvars, preds) with + | ([], preds) -> Havc (PVar vv) :: Assm preds :: [] + | (kvars, []) -> Misc.flap (get_instrs vv decls) kvars + | (kvars, preds) -> Misc.flap (get_instrs vv decls) kvars @ ([Assm preds]) + +(* [[{t | p}]]_set *) + +let reft_to_set_instrs decls reft = + let kvars = C.kvars_of_reft reft in + let preds = C.preds_of_reft emptySol reft in + match (kvars, preds) with + | ([], preds) -> Asst preds :: [] + | (kvars, []) -> List.map (set_instr decls) kvars + | (kvars, preds) -> List.map (set_instr decls) kvars @ [(Asst preds)] + +(* [[x:T; G]] *) + +let binding_to_instrs decls (var, reft) = + reft_to_get_instrs decls reft @ [Asgn (PVar var, PVar (C.vv_of_reft reft))] + +let envt_to_instrs decls envt = + Misc.flap (binding_to_instrs decls) (C.bindings_of_env envt) + +let constraint_to_block decls c = + let (env, grd, lhs, rhs) = + (C.env_of_t c, C.grd_of_t c, C.lhs_of_t c, C.rhs_of_t c) in + Assm [grd] :: + envt_to_instrs decls env @ + reft_to_get_instrs decls lhs @ + reft_to_set_instrs decls rhs + +let constraints_to_blocks decls cs = + List.map (constraint_to_block decls) (filter_subt cs) + +let mk_program cs = + let decls = constraints_to_decls cs in + (decls, constraints_to_blocks decls cs) + +(* API *) +let render ppf cs = + cs |> mk_program + |> F.fprintf ppf "%a" print_program_as_c diff --git a/external/fixpoint/toImp.mli b/external/fixpoint/toImp.mli new file mode 100644 --- /dev/null +++ b/external/fixpoint/toImp.mli @@ -0,0 +1,26 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONAst.Symbol. + * + *) + +val render : Format.formatter -> FixConfig.deft list -> unit + + diff --git a/external/fixpoint/toLatex.ml b/external/fixpoint/toLatex.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/toLatex.ml @@ -0,0 +1,149 @@ +(* translation of constraints to latex *) + +module C = FixConstraint +module Su = Ast.Subst +module Misc = FixMisc open Misc.Ops + +(* print linebreak after each connective in constraint *) +let c_linebreak = ref true + +let q_mathit = Printf.sprintf "\\mathit{%s}" + +let sort_to_latex s = Ast.Sort.to_string s |> q_mathit +let symbol_to_latex s = + Ast.Symbol.to_string s + |> Str.global_replace (Str.regexp "_") "\\_" + |> Str.global_replace (Str.regexp "#") "\\#" |> q_mathit +let constant_to_latex = Ast.Constant.to_string + +let bop_to_latex = function + | Ast.Plus -> "+" + | Ast.Minus -> "-" + | Ast.Times -> "" + | Ast.Div -> "/" +let brel_to_latex = function + | Ast.Eq -> "=" + | Ast.Ne -> "!=" + | Ast.Gt -> ">" + | Ast.Ge -> "\\geq" + | Ast.Lt -> "<" + | Ast.Le -> "\\leq" +let bind_to_latex (s, t) = + Printf.sprintf "%s:%s" (symbol_to_latex s) (sort_to_latex t) +let rec expr_to_latex (e, _) = + match e with + | Ast.Con c -> constant_to_latex c + | Ast.Var s -> symbol_to_latex s + | Ast.App (s, es) -> + Printf.sprintf "%s([%s])" + (symbol_to_latex s) (List.map expr_to_latex es |> String.concat " ") + | Ast.Bin (e1, op, e2) -> + Printf.sprintf "(%s %s %s)" + (expr_to_latex e1) (bop_to_latex op) (expr_to_latex e2) + | Ast.Ite (ip, te, ee) -> + Printf.sprintf "%s ? %s : %s" + (pred_to_latex ip) (expr_to_latex te) (expr_to_latex ee) + | Ast.Fld (s, e) -> + Printf.sprintf "%s.%s" (expr_to_latex e) (symbol_to_latex s) +and pred_to_latex (p, _) = + match p with + | Ast.True -> "\\ltrue" + | Ast.False -> "\\lfalse" + | Ast.Bexp e -> expr_to_latex e + | Ast.Not p -> Printf.sprintf "\\neg (%s)" (pred_to_latex p) + | Ast.Imp (p1, p2) -> + Printf.sprintf "(%s \\limp %s)" (pred_to_latex p1) (pred_to_latex p2) + | Ast.And ps -> + if ps = [] then "\\ltrue" else + List.map pred_to_latex ps |> String.concat " \\land " + | Ast.Or ps -> + if ps = [] then "\\lfalse" else + List.map pred_to_latex ps |> String.concat " \\lor " + | Ast.Atom (e1, r, e2) -> + Printf.sprintf "(%s %s %s)" + (expr_to_latex e1) (brel_to_latex r) (expr_to_latex e2) + | Ast.Forall (qs,p) -> + Printf.sprintf "\\forall %s: %s" + (List.map bind_to_latex qs |> String.concat ", ") (pred_to_latex p) +let subst_to_latex (s, e) = + Printf.sprintf "[%s/%s]" (expr_to_latex e) (symbol_to_latex s) +let refa_to_latex refa = + match refa with + | C.Conc pred -> pred_to_latex pred + | C.Kvar (subs, sym) -> + Printf.sprintf "%s%s" + (symbol_to_latex sym) + (List.map subst_to_latex (Su.to_list subs) |> String.concat "") +let reft_to_latex (v, b, r) = + Printf.sprintf "\\{ %s:%s \\mid %s \\}" + (symbol_to_latex v) (sort_to_latex b) + (if r = [] then "\\ltrue" else + (List.map refa_to_latex r |> String.concat " \\land ")) +let envt_to_latex envt = + if Ast.Symbol.SMap.is_empty envt then + "\\ltrue;\\ " + else + Ast.Symbol.SMap.fold + (fun sym reft sofar -> + Printf.sprintf "%s:%s;%s%s" + (symbol_to_latex sym) (reft_to_latex reft) + (if !c_linebreak then "\\\\\n" else "\\ ") + sofar) envt "" + +let c_to_latex out c = + Printf.fprintf out + "\\begin{footnotesize} + \\begin{verbatim} +%s + \\end{verbatim} +\\end{footnotesize} +" (C.to_string c); + Printf.fprintf out + "\\begin{displaymath} + \\begin{array}[t]{l} + %s %s\\ \\deriv\\\\ %s\\ <:\\\\ %s\\qquad %s + \\end{array} +\\end{displaymath} +\\hrule +" + (C.env_of_t c |> envt_to_latex) + (C.grd_of_t c |> pred_to_latex) + (C.lhs_of_t c |> reft_to_latex) + (C.rhs_of_t c |> reft_to_latex) + (try string_of_int (C.id_of_t c) with _ -> "") + +let wf_to_latex out wf = + Printf.fprintf out + "\\begin{displaymath} + \\begin{array}[t]{l} + %s\\ \\deriv\\ %s\\qquad %s + \\end{array} +\\end{displaymath} +\\hrule +" + (C.env_of_wf wf |> envt_to_latex) + (C.reft_of_wf wf |> reft_to_latex) + (try string_of_int (C.id_of_wf wf) with _ -> "") + + +let to_latex out cs ws = + print_endline "Translating to LaTeX."; + Printf.fprintf out +"\\documentclass[10pt]{llncs} +\\pagestyle{plain} +\\usepackage{amsmath} +\\newcommand{\\ltrue}{\\mathit{true}} +\\newcommand{\\lfalse}{\\mathit{false}} +\\newcommand{\\limp}{\\rightarrow} +\\newcommand{\\deriv}{\\vdash} +\\begin{document} +"; + List.iter (c_to_latex out) cs; + List.iter (wf_to_latex out) ws; + Printf.fprintf out +"\\end{document} +%%%%%% Local Variables: +%%%%%% mode: latex +%%%%%% TeX-master: t +%%%%%% End: +" diff --git a/external/fixpoint/toQARMC.ml b/external/fixpoint/toQARMC.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/toQARMC.ml @@ -0,0 +1,721 @@ +(* translation to Q'ARMC *) + + +module C = FixConstraint +module Co = Constants +module Sy = Ast.Symbol +module Su = Ast.Subst +module P = Ast.Predicate +module E = Ast.Expression +module StrMap = Map.Make (struct type t = string let compare = compare end) +module StrSet = Set.Make (struct type t = string let compare = compare end) +module Misc = FixMisc open Misc.Ops + +let strlist_to_strset = List.fold_left (fun s x -> StrSet.add x s) StrSet.empty + +(* Andrey: TODO move to ast.ml? *) +let pred_is_atomic (p, _) = + match p with + | Ast.True | Ast.False | Ast.Bexp _ | Ast.Atom _ -> true + | Ast.And _ | Ast.Or _ | Ast.Not _ | Ast.Imp _ | Ast.Forall _ -> false + +let pred_is_true (p, _) = + match p with + | Ast.True -> true + | Ast.Atom (e1, Ast.Eq, e2) -> E.to_string e1 = E.to_string e2 + | _ -> false + +let neg_brel = function + | Ast.Eq -> Ast.Ne + | Ast.Ne -> Ast.Eq + | Ast.Gt -> Ast.Le + | Ast.Ge -> Ast.Lt + | Ast.Lt -> Ast.Ge + | Ast.Le -> Ast.Gt + +let rec push_neg ?(neg=false) ((p, _) as pred) = + match p with + | Ast.True -> if neg then Ast.pFalse else pred + | Ast.False -> if neg then Ast.pTrue else pred + | Ast.Bexp _ -> if neg then Ast.pNot pred else pred + | Ast.Not p -> push_neg ~neg:(not neg) p + | Ast.Imp (p, q) -> + if neg then Ast.pAnd [push_neg p; push_neg ~neg:true q] + else Ast.pImp (push_neg p, push_neg q) + | Ast.Forall (qs, p) -> + let pred' = Ast.pForall (qs, push_neg ~neg:false p) in + if neg then Ast.pNot pred' else pred' + | Ast.And ps -> List.map (push_neg ~neg:neg) ps |> if neg then Ast.pOr else Ast.pAnd + | Ast.Or ps -> List.map (push_neg ~neg:neg) ps |> if neg then Ast.pAnd else Ast.pOr + | Ast.Atom (e1, brel, e2) -> if neg then Ast.pAtom (e1, neg_brel brel, e2) else pred + +(* Andrey: TODO flatten nested conjunctions/disjunctions *) +let rec simplify_tauto ((p, _) as pred) = + match p with + | Ast.Not p -> Ast.pNot (simplify_tauto p) + | Ast.Imp (p, q) -> Ast.pImp (simplify_tauto p, simplify_tauto q) + | Ast.Forall (qs, p) -> Ast.pForall (qs, simplify_tauto p) + | Ast.And ps -> + let ps' = List.map simplify_tauto ps |> List.filter (fun p -> not(P.is_tauto p)) in + if List.mem Ast.pFalse ps' then Ast.pFalse else + begin + match ps' with + | [] -> Ast.pTrue + | [p'] -> p' + | _ :: _ -> Ast.pAnd ps' + end + | Ast.Or ps -> + let ps' = List.map simplify_tauto ps in + if List.exists P.is_tauto ps' then Ast.pTrue else + begin + match ps' with + | [] -> Ast.pFalse + | [p'] -> p' + | _ :: _ -> Ast.pOr ps' + end + | _ -> pred + +let rec partition_pred_defs edefs pdefs ((p, _) as pred) = + match p with + | Ast.Atom ((Ast.Var v, _), Ast.Eq, e) -> Ast.pTrue, Sy.SMap.add v e edefs, pdefs + | Ast.And [Ast.Imp ((Ast.Bexp (Ast.Var v1, _), _), p1), _; + Ast.Imp (p2, (Ast.Bexp (Ast.Var v2, _), _)), _] when v1 = v2 && p1 = p2 -> + Ast.pTrue, edefs, Sy.SMap.add v1 p1 pdefs + | Ast.And preds -> + let preds', edefs', pdefs' = List.fold_left + (fun (preds_sofar, edefs_sofar, pdefs_sofar) p -> + let p'', edefs'', pdefs'' = partition_pred_defs edefs_sofar pdefs_sofar p in + p'' :: preds_sofar, edefs'', pdefs'' + ) ([], edefs, pdefs) preds in + (Ast.pAnd preds'), edefs', pdefs' + | _ -> pred, edefs, pdefs + +let rec defs_of_pred edefs pdefs (p, _) = + match p with + | Ast.Atom ((Ast.Var v, _), Ast.Eq, e) -> Sy.SMap.add v e edefs, pdefs + | Ast.And [Ast.Imp ((Ast.Bexp (Ast.Var v1, _), _), p1), _; + Ast.Imp (p2, (Ast.Bexp (Ast.Var v2, _), _)), _] when v1 = v2 && p1 = p2 -> + edefs, Sy.SMap.add v1 p1 pdefs + | Ast.And preds -> + let edefs', pdefs' = List.fold_left + (fun (edefs_sofar, pdefs_sofar) p -> + let edefs'', pdefs'' = defs_of_pred edefs_sofar pdefs_sofar p in + edefs'', pdefs'' + ) (edefs, pdefs) preds in + edefs', pdefs' + | _ -> edefs, pdefs + + +let some_def_applied = ref false +let rec expr_apply_defs edefs pdefs ((e, _) as expr) = + let current_some_def_applied = !some_def_applied in + some_def_applied := false; + let expr'' = + match e with + | Ast.Con _ -> expr + | Ast.Var v -> + begin + try + let expr' = Sy.SMap.find v edefs in + some_def_applied := true; + expr' + with Not_found -> expr + end + | Ast.App (v, es) -> + let edefs' = Sy.SMap.remove v edefs in + Ast.eApp (v, List.map (expr_apply_defs edefs' pdefs) es) + | Ast.Bin (e1, op, e2) -> + Ast.eBin (expr_apply_defs edefs pdefs e1, op, expr_apply_defs edefs pdefs e2) + | Ast.Ite (p, e1, e2) -> + Ast.eIte (pred_apply_defs edefs pdefs p, + expr_apply_defs edefs pdefs e1, + expr_apply_defs edefs pdefs e2) + | Ast.Fld (v, e) -> + let v' = + try + match Sy.SMap.find v edefs with + | (Ast.Var v'', _) -> + some_def_applied := true; + v'' + | _ -> v + with Not_found -> v + in + Ast.eFld (v', expr_apply_defs edefs pdefs e) + in + if !some_def_applied then + let expr''' = expr_apply_defs edefs pdefs expr'' in + some_def_applied := current_some_def_applied; + expr''' + else + begin + some_def_applied := current_some_def_applied; + expr'' + end +and pred_apply_defs edefs pdefs ((p, _) as pred) = + let current_some_def_applied = !some_def_applied in + some_def_applied := false; + let pred'' = + match p with + | Ast.And ps -> List.map (pred_apply_defs edefs pdefs) ps |> Ast.pAnd + | Ast.Or ps -> List.map (pred_apply_defs edefs pdefs) ps |> Ast.pOr + | Ast.Not p -> pred_apply_defs edefs pdefs p |> Ast.pNot + | Ast.Imp (p, q) -> Ast.pImp (pred_apply_defs edefs pdefs p, pred_apply_defs edefs pdefs q) + | Ast.Bexp (Ast.Var v, _) -> + begin + Printf.printf "Applying on Bexp: %s\n" (P.to_string pred); + (* Andrey: TODO also consider edefs *) + try + let expr' = Sy.SMap.find v edefs in + some_def_applied := true; + Ast.pBexp expr' + with Not_found -> + try + let pred' = Sy.SMap.find v pdefs in + some_def_applied := true; + pred' + with Not_found -> + pred + end + | Ast.Atom (e1, brel, e2) -> + Ast.pAtom (expr_apply_defs edefs pdefs e1, brel, expr_apply_defs edefs pdefs e2) + | Ast.Forall (qs, p) -> + let vs = List.map fst qs in + let edefs' = List.fold_left (fun defs v -> Sy.SMap.remove v defs) edefs vs in + let pdefs' = List.fold_left (fun defs v -> Sy.SMap.remove v defs) pdefs vs in + Ast.pForall (qs, pred_apply_defs edefs' pdefs' p) + | _ -> pred + in + if !some_def_applied then + let pred''' = pred_apply_defs edefs pdefs pred'' in + some_def_applied := current_some_def_applied; + pred''' + else + begin + some_def_applied := current_some_def_applied; + pred'' + end + + +let support_of_env sol env = + Sy.SMap.fold + (fun ksym reft sup -> + let vv = C.vv_of_reft reft in + let kv = Ast.eVar ksym in + let syms = C.preds_of_reft sol reft |> + List.map (fun p -> P.subst p vv kv) |> List.filter (fun p -> not(pred_is_true p)) |> + List.map P.support |> List.flatten + in + List.fold_left (fun sup' sym -> Sy.SSet.add sym sup') sup syms + ) env Sy.SSet.empty + + + +let armc_true = "true" +let armc_false = "false" +let loop_pc = "loop" +let start_pc = "start" +let error_pc = "error" +let val_vname = "VVVV" +let exists_kv = "EX" +let primed_suffix = "p" +let str__cil_tmp = "__cil_tmp" + +type kv_scope = { + kvs : string list; + kv_scope : string list StrMap.t +} + +type horn_clause = { + body_pred : Ast.pred; + body_kvars : (Su.t * Sy.t) list; + head_pred : Ast.pred; + head_kvars : (Su.t * Sy.t) list; + tag : string; +} + +let sanitize_symbol s = + Str.global_replace (Str.regexp "@") "_at_" s |> Str.global_replace (Str.regexp "#") "_hash_" |> + Str.global_replace (Str.regexp "\\.") "_dot_" |> Str.global_replace (Str.regexp "'") "_q_" + +let symbol_to_armc s = Sy.to_string s |> sanitize_symbol + +let var_to_armc s = Sy.to_string s |> sanitize_symbol |> String.capitalize + +let subs_to_map subs = + List.fold_left + (fun m (s, e) -> + StrMap.add (symbol_to_armc s) e m + ) StrMap.empty (Su.to_list subs) + +let mk_data_var ?(suffix = "") kv v = + Printf.sprintf "_%s_%s%s%s" + (sanitize_symbol v) (sanitize_symbol kv) (if suffix = "" then "" else "_") suffix + + +(* +let defs_of_env state env = + Sy.SMap.fold + (fun ksym reft defs -> + let vv = C.vv_of_reft reft in + let kv = Ast.eVar ksym in + let defs' = C.preds_of_reft state.sol reft |> + List.map (fun p -> P.subst p vv kv) |> List.filter (fun p -> not(pred_is_true p)) |> + List.map (defs_of_pred state) |> List.flatten + in + defs' ++ defs + ) env [] +*) + +let constant_to_armc = Ast.Constant.to_string +let bop_to_armc = function + | Ast.Plus -> "+" + | Ast.Minus -> "-" + | Ast.Times -> "*" + | Ast.Div -> "/" +let brel_to_armc = function + | Ast.Eq -> "=" + | Ast.Ne -> "=\\=" + | Ast.Gt -> ">" + | Ast.Ge -> ">=" + | Ast.Lt -> "<" + | Ast.Le -> "=<" +let bind_to_armc (s, t) = (* Andrey: TODO support binders *) + Printf.sprintf "%s:%s" (symbol_to_armc s) (Ast.Sort.to_string t |> sanitize_symbol) +let rec expr_to_armc (e, _) = + match e with + | Ast.Con c -> constant_to_armc c + | Ast.Var s -> var_to_armc s + | Ast.App (s, es) -> + if !Co.purify_function_application then "_" else + let str = symbol_to_armc s in + if es = [] then str else + Printf.sprintf "f_%s(%s)" str (List.map expr_to_armc es |> String.concat ", ") + | Ast.Bin (e1, op, e2) -> + Printf.sprintf "(%s %s %s)" + (expr_to_armc e1) (bop_to_armc op) (expr_to_armc e2) + | Ast.Ite (ip, te, ee) -> + Printf.sprintf "ite(%s, %s, %s)" + (pred_to_armc ip) (expr_to_armc te) (expr_to_armc ee) + | Ast.Fld (s, e) -> + Printf.sprintf "fld(%s, %s)" (expr_to_armc e) (symbol_to_armc s) +and pred_to_armc ((p, _) as pred) = + if pred_is_true pred then + armc_true + else + match p with + | Ast.True -> armc_true + | Ast.False -> armc_false + | Ast.Bexp e -> Printf.sprintf "bexp(%s)" (expr_to_armc e) + | Ast.Not (Ast.True, _) -> armc_false + | Ast.Not (Ast.False, _) -> armc_true + | Ast.Not p -> Printf.sprintf "neg(%s)" (pred_to_armc p) + | Ast.Imp (p1, p2) -> Printf.sprintf "imp(%s, %s)" (pred_to_armc p1) (pred_to_armc p2) + | Ast.And [] -> armc_true + | Ast.And [p] -> pred_to_armc p + | Ast.And [Ast.Imp ((Ast.Bexp e1, _) as p, p1), _; + Ast.Imp (p2, (Ast.Bexp e2, _)), _] when e1 = e2 && p1 = p2 -> + Printf.sprintf "bexp_def(%s, %s)" (pred_to_armc p) (pred_to_armc p1) + | Ast.And (_::_ as ps) -> + Printf.sprintf "(%s)" (List.map pred_to_armc ps |> String.concat ", ") + | Ast.Or [] -> armc_false + | Ast.Or [p] -> pred_to_armc p + | Ast.Or (_::_ as ps) -> Printf.sprintf "(%s)" (List.map pred_to_armc ps |> String.concat "; ") + | Ast.Atom (e1, Ast.Eq, (Ast.Ite(ip, te, ee), _)) -> + let ip_str = pred_to_armc ip in + let e1_str = expr_to_armc e1 in + Printf.sprintf "((%s, %s = %s); (neg(%s), %s = %s))" + ip_str e1_str (expr_to_armc te) + ip_str e1_str (expr_to_armc ee) + | Ast.Atom (e1, r, e2) -> + Printf.sprintf "%s %s %s" + (expr_to_armc e1) (brel_to_armc r) (expr_to_armc e2) + | Ast.Forall (qs,p) -> (* Andrey: TODO support forall *) + Printf.sprintf "forall([%s], %s)" + (List.map bind_to_armc qs |> String.concat ", ") + (pred_to_armc p) + + +let mk_kv_scope out ts wfs = + (* let kvs = List.map C.kvars_of_t ts |> List.flatten |> List.map snd |> + List.map symbol_to_armc |> (* (fun s -> Printf.sprintf "k%s" (symbol_to_armc s)) |> *) + Misc.sort_and_compact in + *) + let kv_scope_wf = + List.fold_left + (fun m wf -> + match C.reft_of_wf wf |> C.ras_of_reft with + | [C.Kvar (subs, kvar)] when Su.is_empty subs -> + let v = symbol_to_armc kvar in + let scope = +(* val_vname :: *) + (C.env_of_wf wf + |> C.bindings_of_env + |> List.filter + (fun (_, (_, typ, _)) -> + Ast.Sort.t_int = typ + ) + |> List.map fst + |> List.map symbol_to_armc + |> List.filter + (fun s -> + not(Misc.is_prefix str__cil_tmp s + || Misc.is_prefix "FP_" s + || Misc.is_prefix "Open_" s + || Misc.is_prefix "None_0" s + || Misc.is_prefix "Some_0" s + || Misc.is_prefix "true_0" s + || Misc.is_prefix "false_0" s + || Misc.is_prefix "Pervasives_" s + || Misc.is_prefix "FIXPOINTSYMBOL_" s)) + |> List.sort compare) + in + StrMap.add v scope m + | _ -> m + (* Andrey: TODO handle ill-formed wf *) + (* Format.printf "%a" (C.print_wf None) wf; + + failure "ERROR: kname_scope_map: ill-formed wf" + *) + ) StrMap.empty wfs in + let kv_scope_t = + List.fold_left + (fun m (subs, kvar) -> + let v = symbol_to_armc kvar in + let scope = + List.filter (fun (v, (e, _)) -> + match e with + | Ast.Var v' -> v <> v' + | _ -> true + ) (Su.to_list subs) |> + List.map fst |> List.map symbol_to_armc |> strlist_to_strset in + let scope' = try StrMap.find v m with Not_found -> StrSet.empty in + StrMap.add v (StrSet.union scope scope') m + ) StrMap.empty (List.map C.kvars_of_t ts |> List.flatten) in + let kv_scope = kv_scope_wf in + let kv_scope_old = + StrMap.map (fun scope -> val_vname :: (StrSet.elements scope |> List.sort compare)) kv_scope_t in + let kvs = StrMap.fold (fun kv _ kvs -> kv :: kvs) kv_scope [] in + (* + StrMap.iter (fun kv scope -> + Printf.fprintf out "%% %s -> %s\n" kv (String.concat ", " scope)) kv_scope; + *) + {kvs = kvs; kv_scope = kv_scope} + +let mk_data ?(suffix = "") ?(skip_kvs = []) s = + Printf.sprintf "[%s]" + (List.map + (fun kv -> + try + StrMap.find kv s.kv_scope |> + List.map (mk_data_var ~suffix:(if List.mem kv skip_kvs then "" else suffix) kv) + with Not_found -> failure "ERROR: mk_data: scope not found for %s" kv + ) s.kvs |> List.flatten |> String.concat ", ") + +let mk_query ?(suffix = "") s kv = + Printf.sprintf "k%s(%s)" + kv (List.map (mk_data_var ~suffix:suffix kv) (StrMap.find kv s.kv_scope) |> String.concat ", ") + +let mk_var2names state = + List.map + (fun kv -> + Printf.sprintf "var2names(p(pc(k%s), data(%s)), [%s])." + kv + (List.map (mk_data_var kv) (StrMap.find kv state.kv_scope) |> String.concat ", ") + (List.map + (fun v -> + Printf.sprintf "(%s, \'%s_%s\')" (mk_data_var kv v) v kv + ) (StrMap.find kv state.kv_scope) |> String.concat ", ") + ) state.kvs |> String.concat "\n" + +let mk_skip_update state kvs = + if kvs = [] then armc_true else + List.map + (fun kv -> + List.map + (fun v -> + Printf.sprintf "%s = %s" + (mk_data_var ~suffix:primed_suffix kv v) (mk_data_var kv v) + ) (StrMap.find kv state.kv_scope) |> String.concat ", " + ) kvs |> String.concat ", " + +let mk_update_str from_vs to_vs updates = + List.map2 + (fun v vp -> + Printf.sprintf "%s = %s" vp (try StrMap.find v updates with Not_found -> v) + ) from_vs to_vs |> String.concat ", " + +let split_scope scope = + match scope with + | value :: data -> value, data + | _ -> failure "ERROR: split_scope: empty scope %s" (String.concat ", " scope) + +let reft_to_armc ?(noquery = false) ?(suffix = "") state reft = + let vv = C.vv_of_reft reft |> symbol_to_armc in + let rs = C.ras_of_reft reft in + if rs = [] then armc_true else + List.map + (function + | C.Conc pred -> pred_to_armc pred + | C.Kvar (subs, sym) -> + failwith "AR: toQARMC.ml reft_to_armc"; + if true (* Sy.SMap.mem sym state.sol && Sy.SMap.find sym state.sol = [] *)then + armc_true (* skip true *) + else + let subs_map = subs_to_map subs in + let find_subst v default = + try StrMap.find v subs_map |> expr_to_armc with Not_found -> default in + let kv = symbol_to_armc sym in + let value, data = StrMap.find kv state.kv_scope |> split_scope in + Printf.sprintf "%s%s = %s" + (if noquery then "" else (mk_query ~suffix:suffix state kv) ^ ", ") + (mk_data_var ~suffix:suffix kv value) + (find_subst vv (mk_data_var exists_kv vv)) + :: List.map + (fun v -> + Printf.sprintf "%s = %s" + (mk_data_var ~suffix:suffix kv v) + (find_subst v (mk_data_var exists_kv v)) + ) data |> String.concat ", " + ) rs |> String.concat ", " + +let mk_rule head annot_guards annot_updates id = + let rec annot_conj_to_armc = function + | (g, a) :: rest -> + if rest = [] then Printf.sprintf "\n %s \t%% %s\n ]," g a + else Printf.sprintf "\n %s, \t%% %s%s" g a (annot_conj_to_armc rest) + | [] -> "]," + in + Printf.sprintf + " +hc(%s, [%s %s). +" + head (annot_guards @ annot_updates |> List.filter (fun (g, _) -> g <> armc_true) |> annot_conj_to_armc) id + +let preds_kvars_of_reft reft = + List.fold_left + (fun (ps, ks) r -> + match r with + | C.Conc p -> p :: ps, ks + | C.Kvar (subs, kvar) -> ps, (subs, kvar) :: ks + ) ([], []) (C.ras_of_reft reft) + +let t_to_horn_clause t = + let lhs_ps, lhs_ks = C.lhs_of_t t |> preds_kvars_of_reft in + let body_ps, body_ks = + Sy.SMap.fold + (fun bv reft (ps, ks) -> + let ps', ks' = preds_kvars_of_reft (C.theta (Su.of_list [(C.vv_of_reft reft, Ast.eVar bv)]) reft) in + List.rev_append ps' ps, List.rev_append ks' ks + ) (C.env_of_t t) (C.grd_of_t t :: lhs_ps, lhs_ks) in + let head_ps, head_ks = C.rhs_of_t t |> preds_kvars_of_reft in + { + body_pred = Ast.pAnd body_ps |> simplify_tauto; + body_kvars = body_ks; + head_pred = Ast.pAnd head_ps |> simplify_tauto; + head_kvars = head_ks; + tag = try string_of_int (C.id_of_t t) with _ -> failure "ERROR: t_to_horn_clause: anonymous constraint %s" (C.to_string t) + } + +let simplify_horn_clause hc = + let body_edefs, body_pdefs = defs_of_pred Sy.SMap.empty Sy.SMap.empty hc.body_pred in + let edefs, pdefs = defs_of_pred body_edefs body_pdefs hc.head_pred in + { + body_pred = pred_apply_defs edefs pdefs hc.body_pred |> simplify_tauto; + body_kvars = hc.body_kvars; + head_pred = pred_apply_defs edefs pdefs hc.head_pred |> simplify_tauto; + head_kvars = hc.head_kvars; + tag = hc.tag + } + +let print_horn_clause hc = + Printf.printf "%s: %s, %s :- %s, #%d %s\n" + hc.tag + (P.to_string hc.head_pred) + (List.map (fun (subs, kvar) -> C.refa_to_string (C.Kvar (subs, kvar))) hc.head_kvars |> String.concat ", ") + (P.to_string hc.body_pred) + (List.length hc.body_kvars) + (List.map (fun (subs, kvar) -> C.refa_to_string (C.Kvar (subs, kvar))) hc.body_kvars |> String.concat ", ") + + +let t_to_armc state t = + t_to_horn_clause t |> simplify_horn_clause |> print_horn_clause; + let env = C.env_of_t t in + let grd = C.grd_of_t t in + let lhs = C.lhs_of_t t in + let rhs = C.rhs_of_t t in + let rhs_s = C.reft_to_string rhs in + let tag = try string_of_int (C.id_of_t t) with _ -> + failure "ERROR: t_to_armc: anonymous constraint %s" (C.to_string t) in +(* let defs = defs_of_env state env in *) + let annot_guards = + Misc.map_partial + (fun (bv, reft) -> + if C.ras_of_reft reft <> [] then + Some (reft_to_armc state (C.theta (Su.of_list [(C.vv_of_reft reft, Ast.eVar bv)]) reft), + C.binding_to_string (bv, reft)) + else + None + ) (env |> C.bindings_of_env) + ++ [(pred_to_armc grd, P.to_string grd); + (reft_to_armc state lhs, "|- " ^ (C.reft_to_string lhs))] in + let ps, kvs = + List.fold_left (fun (ps', kvs') refa -> + match refa with + | C.Conc p -> p::ps', kvs' + | C.Kvar (subs, sym) -> ps', (subs, sym)::kvs' + ) ([], []) (C.ras_of_reft rhs) in +(* Andrey: obsolete code + let env_sup = support_of_env state.sol env |> Sy.SSet.elements in + Printf.printf "Rule %s\n" tag; + Printf.printf "Env support #%d: %s\n" + (List.length env_sup) (env_sup |> List.map Sy.to_string |> String.concat ", "); + Printf.printf "Guard support %s: %s\n" + (P.to_string grd) + (P.support grd |> List.map Sy.to_string |> String.concat ", "); +*) + (if ps <> [] then + [mk_rule error_pc annot_guards [(Ast.pAnd ps |> Ast.pNot |> pred_to_armc, "<: " ^ rhs_s)] tag] + else + []) + ++ + (List.map + (fun (_, sym) -> + mk_rule (mk_query ~suffix:primed_suffix state (symbol_to_armc sym)) + annot_guards + [(reft_to_armc ~noquery:true ~suffix:primed_suffix state rhs, "<: " ^ rhs_s)] + tag + ) kvs) + + +(* + make -f Makefile.fixtop && ./f -latex /tmp/main.tex -armc /tmp/a.pl tests/pldi08-max.fq && cat /tmp/a.pl + +tests: + +for file in `ls pldi08-*-atom.fq`; do ../f -latex /tmp/main.tex -armc /tmp/a.pl $file; head -n 1 /tmp/a.pl; armc a.pl | grep correct; done + +pldi08-arraymax-atom.fq pass +pldi08-max-atom.fq pass +pldi08-foldn-atom.fq pass +pldi08-sum-atom.fq pass +mask-atom.fq pass +samples-atom.fq pass + +test00.c pass + +*) + +let subs_kvar_to_strs state ?(suffix = "") subs kvar = + let kv = symbol_to_armc kvar in + let scope = StrMap.find kv state.kv_scope in + let scope_set = strlist_to_strset scope in + let subs_map = subs_to_map subs in + let kvar_str = + Printf.sprintf "%s(%s)" kv + (List.map + (fun v -> + let v_cap = String.capitalize v in + let v_cap_suffix = v_cap ^ suffix in + try + match StrMap.find v subs_map with + | (Ast.Var s, _) -> + let v_exp = var_to_armc s in + if StrSet.mem v_exp scope_set then v_cap_suffix + else v_exp + | _ -> v_cap_suffix + with Not_found -> v_cap + ) scope |> String.concat ", ") + in + let subs_strs = + StrMap.fold (fun v e acc -> + let subs_str = + Printf.sprintf "%s%s = %s" + (String.capitalize v) suffix (StrMap.find v subs_map |> expr_to_armc) + in + match e with + | (Ast.Var s, _) -> + let v_exp = var_to_armc s in + if StrSet.mem v_exp scope_set then subs_str :: acc + else acc + | _ -> subs_str :: acc + ) subs_map [] + in + kvar_str, subs_strs + +let mk_query_naming state = + List.map + (fun kv -> + Printf.sprintf "query_naming(%s(%s))." kv + (StrMap.find kv state.kv_scope + |> List.map + (fun v -> + if 'a' <= v.[0] && v.[0] <= 'z' then v + else Printf.sprintf "'%s'" v + ) + |> String.concat ", ") + ) state.kvs |> String.concat "\n" + +exception ValidClause +let horn_clause_to_tc state hc = + let head_str, head_grd_strs = +(* + match hc.head_kvars with + | [(subs, kvar)] -> + let head_kvar_str, head_subs_strs = + subs_kvar_to_strs state ~suffix:"_0" subs kvar + in + head_kvar_str, head_subs_strs + | [] -> + let head_pred = push_neg ~neg:true hc.head_pred |> simplify_tauto in + "false", if P.is_tauto head_pred then [] else [pred_to_armc head_pred] + | _ :: _ -> + print_horn_clause hc; + failwith ("horn_clause_to_tc: unexpected clause " ^ hc.tag) +*) + match P.is_tauto hc.head_pred, hc.head_kvars with + | true, [(subs, kvar)] -> + let head_kvar_str, head_subs_strs = + subs_kvar_to_strs state ~suffix:"_0" subs kvar + in + head_kvar_str, head_subs_strs + | true, [] -> raise ValidClause + | false, [] -> + let head_pred = push_neg ~neg:true hc.head_pred |> simplify_tauto in + "false", if P.is_tauto head_pred then [] else [pred_to_armc head_pred] + | _, _ -> + print_horn_clause hc; + failwith ("horn_clause_to_tc: unexpected clause " ^ hc.tag) + in + let tag_str = Printf.sprintf "id(%s)" hc.tag in + let simple_body_pred = hc.body_pred |> push_neg ~neg:false |> simplify_tauto in + let grd_tag_strs = + if P.is_tauto simple_body_pred then tag_str :: head_grd_strs + else pred_to_armc simple_body_pred :: tag_str :: head_grd_strs + in + let body_strs, _ = + List.fold_left (fun (s, n) (subs, kvar) -> + let kvar_str, subs_strs = subs_kvar_to_strs state ~suffix:("_" ^ string_of_int n) subs kvar in + kvar_str :: (subs_strs ++ s), + n+1 + ) (grd_tag_strs, 1) hc.body_kvars + in + Printf.sprintf "%s :- %s.\n" head_str (body_strs |> List.rev |> String.concat ", ") + +let to_qarmc out ts wfs = + print_endline "Translating to QARMC."; + + print_endline "========================="; + List.iter (Format.printf "%a" (C.print_t None)) ts; + print_endline "========================="; + + let state = mk_kv_scope out ts wfs in +(* let hcs = List.map (fun t -> t_to_horn_clause t |> simplify_horn_clause) ts in *) + let hcs = List.map t_to_horn_clause ts in + output_string out (mk_query_naming state); + output_string out "\n\n"; + List.iter (fun hc -> + try horn_clause_to_tc state hc |> output_string out + with ValidClause -> () + ) hcs; + print_endline "heheheheh"; + List.iter (fun hc -> print_horn_clause hc; output_string out "\n") hcs diff --git a/external/fixpoint/toRawHorn.ml b/external/fixpoint/toRawHorn.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/toRawHorn.ml @@ -0,0 +1,200 @@ +(* Dumping constraints as Horn clauses without any simplifications *) + +module C = FixConstraint +module Co = Constants +module Sy = Ast.Symbol +module Su = Ast.Subst +module P = Ast.Predicate +module E = Ast.Expression +module StrMap = Map.Make (struct type t = string let compare = compare end) +module StrSet = Set.Make (struct type t = string let compare = compare end) +module Misc = FixMisc open Misc.Ops + +let raw_true = "1=1" +let raw_false = "0=1" + + +let sanitize_symbol s = + Str.global_replace (Str.regexp "@") "_at_" s |> Str.global_replace (Str.regexp "#") "_hash_" |> + Str.global_replace (Str.regexp "\\.") "_dot_" |> Str.global_replace (Str.regexp "'") "_q_" + +let symbol_to_raw s = Sy.to_string s |> sanitize_symbol +let constant_to_raw = Ast.Constant.to_string +let bop_to_raw = function + | Ast.Plus -> "+" + | Ast.Minus -> "-" + | Ast.Times -> "*" + | Ast.Div -> "/" +let brel_to_raw = function + | Ast.Eq -> "=" + | Ast.Ne -> "=\\=" + | Ast.Gt -> ">" + | Ast.Ge -> ">=" + | Ast.Lt -> "<" + | Ast.Le -> "=<" +let bind_to_raw (s, t) = (* Andrey: TODO support binders *) + Printf.sprintf "%s:%s" (symbol_to_raw s) (Ast.Sort.to_string t |> sanitize_symbol) +let rec expr_to_raw expr = + let e = E.unwrap expr in + match e with + | Ast.Con c -> constant_to_raw c + | Ast.Var s -> symbol_to_raw s + | Ast.App (s, es) -> + if !Co.purify_function_application then "_" else + let str = symbol_to_raw s in + if es = [] then str else + Printf.sprintf "f_%s(%s)" str (List.map expr_to_raw es |> String.concat ", ") + | Ast.Bin (e1, op, e2) -> + Printf.sprintf "(%s %s %s)" + (expr_to_raw e1) (bop_to_raw op) (expr_to_raw e2) + | Ast.Ite (ip, te, ee) -> + Printf.sprintf "ite(%s, %s, %s)" + (pred_to_raw ip) (expr_to_raw te) (expr_to_raw ee) + | Ast.Fld (s, e) -> + Printf.sprintf "fld(%s, %s)" (expr_to_raw e) (symbol_to_raw s) + | _ -> failwith (Printf.sprintf "expr_to_raw: %s" (E.to_string expr)) +and pred_to_raw pred = + if P.is_tauto pred then + raw_true + else + let p = P.unwrap pred in + match p with + | Ast.True -> raw_true + | Ast.False -> raw_false + | Ast.Bexp e -> Printf.sprintf "%s = 1" (expr_to_raw e) + | Ast.Not (Ast.True, _) -> raw_false + | Ast.Not (Ast.False, _) -> raw_true + | Ast.Not p -> Printf.sprintf "neg(%s)" (pred_to_raw p) + | Ast.Imp (p1, p2) -> Printf.sprintf "imp(%s, %s)" (pred_to_raw p1) (pred_to_raw p2) + | Ast.And [] -> raw_true + | Ast.And [p] -> pred_to_raw p + | Ast.And (_::_ as ps) -> + Printf.sprintf "(%s)" (List.map pred_to_raw ps |> String.concat ", ") + | Ast.Or [] -> raw_false + | Ast.Or [p] -> pred_to_raw p + | Ast.Or (_::_ as ps) -> Printf.sprintf "(%s)" (List.map pred_to_raw ps |> String.concat "; ") + | Ast.Atom (e1, Ast.Eq, (Ast.Ite(ip, te, ee), _)) -> + let ip_str = pred_to_raw ip in + let e1_str = expr_to_raw e1 in + Printf.sprintf "((%s, %s = %s); (neg(%s), %s = %s))" + ip_str e1_str (expr_to_raw te) + ip_str e1_str (expr_to_raw ee) + | Ast.Atom (e1, r, e2) -> + Printf.sprintf "%s %s %s" + (expr_to_raw e1) (brel_to_raw r) (expr_to_raw e2) + | Ast.Forall (qs,p) -> (* Andrey: TODO support forall *) + Printf.sprintf "forall([%s], %s)" + (List.map bind_to_raw qs |> String.concat ", ") + (pred_to_raw p) + +let subst_to_raw subst = + Misc.map_to_string + (fun (sym, expr) -> + Printf.sprintf "%s = %s" (symbol_to_raw sym) (expr_to_raw expr) + ) (Ast.Subst.to_list subst) + +let kvar_to_scope_tbl = Hashtbl.create 100 + +let wfs_option = ref None + +let is_upper c = c = Char.uppercase c + +let find_scope wfs sym = + match Misc.map_partial + (fun wf -> + let reft = C.reft_of_wf wf in + let vv = C.vv_of_reft reft in + match C.ras_of_reft reft with + | [C.Kvar (subst, sym')] when (Ast.Subst.is_empty subst) && sym = sym' -> + let vv_raw = symbol_to_raw vv in + Some (vv_raw, + StrSet.remove vv_raw + (Sy.SMap.fold (fun bv reft sofar -> + if not(C.sort_of_reft reft |> Ast.Sort.is_int) +(* is_upper (Sy.to_string bv).[0] *) + then + sofar + else + StrSet.add (symbol_to_raw bv) sofar + ) (C.env_of_wf wf) StrSet.empty)) + | _ -> None + ) wfs with + | (vv, scope) :: _ -> vv, scope + | [] -> failwith (Printf.sprintf "Not found wf constraint for %s" (Sy.to_string sym)) + +let scope_of_ksym ksym = + try + Hashtbl.find kvar_to_scope_tbl ksym + with Not_found -> + begin + match !wfs_option with + | Some wfs -> + let scope = find_scope wfs ksym in + Hashtbl.add kvar_to_scope_tbl ksym scope; + scope + | None -> failwith "Uninitialized wfs_option reference" + end + +let refa_to_raw = function + | C.Conc pred -> pred_to_raw pred + | C.Kvar (subst, sym) -> + let vv, scope = scope_of_ksym sym in + let subs = Ast.Subst.to_list subst in + let params = + List.map (fun param -> + try + let _, exp = + List.find (fun (v, _) -> + symbol_to_raw v = param + ) subs in + match exp with + | Ast.Var param', _ -> symbol_to_raw param' + | _ -> failwith (Printf.sprintf "substition by a non-variable %s" (E.to_string exp)) + with Not_found -> param + ) (vv :: (StrSet.elements scope |> List.sort compare)) + in + Printf.sprintf "%s(%s)" (symbol_to_raw sym) (String.concat ", " params) + +let reft_to_raw reft = + if C.sort_of_reft reft |> Ast.Sort.is_func then + raw_true + else + let ras = C.ras_of_reft reft in + match ras with + | [] -> raw_true + | _ :: _ -> + Misc.map_to_string refa_to_raw ras + +let subst_refa refa sym exp = + match refa with + | C.Conc pred -> C.Conc (P.subst pred sym exp) + | C.Kvar (subst, sym') -> C.Kvar (Ast.Subst.extend subst (sym, exp), sym') + +let subst_reft reft sym exp = + C.make_reft + (C.vv_of_reft reft) (C.sort_of_reft reft) + (List.map (fun refa -> subst_refa refa sym exp) (C.ras_of_reft reft)) + +let env_to_raw env = + Sy.SMap.fold + (fun bv reft sofar -> + [subst_reft reft (C.vv_of_reft reft) (Ast.eVar bv) |> reft_to_raw] ++ sofar + ) env [] |> List.filter ((<>) "1=1") |> String.concat ", " + + +let c_to_raw c = + Printf.sprintf "rule(%d, %s, [\n%s,\n%s,\n%s\n]).\n\n" + (C.id_of_t c) + (C.rhs_of_t c |> reft_to_raw) + (C.lhs_of_t c |> reft_to_raw) + (C.grd_of_t c |> pred_to_raw) + (C.env_of_t c |> env_to_raw) + +let to_raw_horn out cs wfs sol = + let cs = FixSimplify.simplify_ts cs in + wfs_option := Some wfs; + print_endline "Translating to raw Horn clauses."; + List.iter (fun c -> + Printf.fprintf out "/*\n%s*/\n" (C.to_string c); + output_string out (c_to_raw c) + ) cs diff --git a/external/fixpoint/toSmtLib.ml b/external/fixpoint/toSmtLib.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/toSmtLib.ml @@ -0,0 +1,503 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONAst.Symbol. + * + *) + +(* This module implements the IMP language and translation from fixpoint constraints *) + + +module F = Format +module H = Hashtbl +module A = Ast +module E = A.Expression +module P = A.Predicate +module Sy = A.Symbol +module So = A.Sort +module SM = Sy.SMap +module SS = Sy.SSet +module C = FixConstraint +module Cg = FixConfig +module Co = Constants +(*module BS = BNstats*) + +module Misc = FixMisc open Misc.Ops + +let mydebug = false + +(*************************************************************************) +(************* Datatypes for SMTLIB Representation ***********************) +(*************************************************************************) +(* +type sort = Int | Bool | Func of (sort list * sort) +*) +type rpred + = A.pred (* Bexp (App (k, es)) *) + +type vdef + = Sy.t * So.t (* variable, sort *) + +type kdef + = Sy.t * (vdef list) + +type cstr + = { lhs : A.pred + ; rhs : rpred option + ; id : int + } + +type smtlib + = { vars : vdef list + ; kvars : kdef list + ; cstrs : cstr list + ; consts : vdef list + } + +type kmap + = kdef SM.t + +let is_kvar x = Misc.is_prefix "k_" (Sy.to_string x) + +(*************************************************************************) +(************* Rendering SMTLIB to String ********************************) +(*************************************************************************) + +(* Printing as C syntax *) + +let print_brel ppf = function + | A.Eq -> F.fprintf ppf "=" + | A.Ne -> F.fprintf ppf "!=" + | A.Gt -> F.fprintf ppf ">" + | A.Ge -> F.fprintf ppf ">=" + | A.Lt -> F.fprintf ppf "<" + | A.Le -> F.fprintf ppf "<=" + +let print_bop ppf = function + | A.Plus -> F.fprintf ppf "+" + | A.Minus -> F.fprintf ppf "-" + | A.Times -> F.fprintf ppf "*" + | A.Div -> F.fprintf ppf "/" + | A.Mod -> F.fprintf ppf "mod" + +let rec print_pred ppf pred = + match P.unwrap pred with + | A.True -> + F.fprintf ppf "true" + | A.False -> + F.fprintf ppf "false" + | A.Atom (e1, A.Ne, e2) -> + F.fprintf ppf "(not (= %a %a))" + print_expr e1 + print_expr e2 + | A.Atom (e1, r, e2) -> + F.fprintf ppf "(%a %a %a)" + print_brel r + print_expr e1 + print_expr e2 + | A.And ps -> + Misc.pprint_many_prefix "and" A.pTrue print_pred ppf ps + | A.Or ps -> + Misc.pprint_many_prefix "or" A.pFalse print_pred ppf ps + | A.Not p -> + F.fprintf ppf "(not %a)" print_pred p + | A.Imp (p1, p2) -> + F.fprintf ppf "(=> %a %a)" + print_pred p1 + print_pred p2 + | A.Iff (p1, p2) -> + F.fprintf ppf "(= %a %a)" + print_pred p1 + print_pred p2 + | A.Bexp e -> + print_expr ppf e + | _ -> assertf "ERROR: ToSmtLib.print_pred %s" (P.to_string pred) + +and print_expr_app f ppf = function + | [e] -> + F.fprintf ppf "(select %a %a)" + Sy.print f + print_expr e + | e::es -> + F.fprintf ppf "(select %a %a)" + (print_expr_app f) es + print_expr e + +and print_expr ppf expr = + match E.unwrap expr with + | A.Con c -> + F.fprintf ppf "%a" A.Constant.print c + | A.App (v, []) + | A.Var v -> + F.fprintf ppf "%a" Sy.print v + | A.App (f, es) when is_kvar f -> + F.fprintf ppf "(%a %a)" + Sy.print f + (Misc.pprint_many false " " print_expr) es + + | A.App (f, es) -> + print_expr_app f ppf (List.rev es) + + (* + print_expr_app f ppf (List.rev es) + F.fprintf ppf "(%a %a)" + Sy.print f + (Misc.pprint_many false " " print_expr) es *) + | A.Bin (e1, op, e2) -> + F.fprintf ppf "(%a %a %a)" + print_bop op + print_expr e1 + print_expr e2 + | A.Ite (p, e1, e2) -> + F.fprintf ppf "(ite %a %a %a)" + print_pred p + print_expr e1 + print_expr e2 + | A.Cst (e, _) -> + F.fprintf ppf "%a" print_expr e + | _ -> assertf "ERROR: ToSmtLib.print_expr %s" (E.to_string expr) + +let print_sort_base ppf t = + if So.is_bool t then + Format.fprintf ppf "Bool" + else + Format.fprintf ppf "Int" + +let rec print_sort ppf t = match So.func_of_t t with + | Some (_, [], t) -> + print_sort_base ppf t + + | Some (_, ts, t) -> + Format.fprintf ppf "%a %a" + (Misc.pprint_many false " " print_sort) ts + print_sort t + | None -> + print_sort_base ppf t + + +(* +let print_vdef ppf (x, t) = match So.func_of_t t with + | Some (_, ts, t') when So.is_bool t' -> + Format.fprintf ppf ":extrapreds ((%a %a))" + Sy.print x + (Misc.pprint_many false " " print_sort) ts + | _ -> + Format.fprintf ppf ":extrafuns ((%a %a))" + Sy.print x + print_sort t +*) + +let rec print_fun_sorts ppf = function + | [t] -> print_sort ppf t + | t::ts -> Format.fprintf ppf "(Array %a %a)" + print_sort t + print_fun_sorts ts + +let print_vdef ppf (x, t) = match So.func_of_t t with + | Some (_, ts, t') -> + Format.fprintf ppf "(%a %a)" + Sy.print x + print_fun_sorts (ts @ [t']) + | _ -> + Format.fprintf ppf "(%a %a)" + Sy.print x + print_sort t + +let print_const ppf c = + Format.fprintf ppf "; constant \n%a\n" print_vdef c + +let groupConsts cs = + cs |> Misc.kgroupby snd + |> Misc.map (Misc.app_snd (List.map fst)) + |> List.filter (snd <+> List.length <+> (>) 0) + +let print_distinct ppf (t, cs) = + Format.fprintf ppf + "; distinct constants of sort: %a\n(distinct %a)\n" + print_sort t + (Misc.pprint_many false " " Sy.print) cs + +(* +let print_kdef ppf (kf, xts) = + Format.fprintf ppf ":extrapreds ((%a %a))" + Sy.print kf + (Misc.pprint_many false " " print_sort) (List.map snd xts) +*) +let print_kdef ppf (kf, xts) = + Format.fprintf ppf "(declare-fun %a (%a) Bool)" + Sy.print kf + (Misc.pprint_many false " " print_sort) (List.map snd xts) + + +let print_rhs ppf = function + | None -> Format.fprintf ppf "false" + | Some p -> Format.fprintf ppf "%a" print_pred p + +(* +let print_cstr ppf c = + Format.fprintf ppf "\n; cid = %d\n:assumption\n(implies (%a) %a)\n" + c.id print_pred c.lhs print_rhs c.rhs +*) + +let binds_of_cstr env c = + let lsyms = P.support c.lhs in + let rsyms = match c.rhs with None -> [] | Some p -> P.support p in + Misc.sort_and_compact (lsyms ++ rsyms) + |> List.filter (fun x -> SM.mem x env) + |> List.map (fun x -> (x, SM.safeFind x env "binds_of_cstr")) + +let print_cstr env ppf c = + Format.fprintf ppf "\n; cid = %d\n(assert (forall (%a) \n (=> %a %a))\n)" + c.id + (Misc.pprint_many true " " print_vdef) (binds_of_cstr env c) + print_pred c.lhs + print_rhs c.rhs + + +(* +let print ppf smt = + Format.fprintf ppf + "(benchmark unknown\n:status unsat\n:logic AUFLIA\n%a\n%a\n%a\n%a\n%a\n)" + (Misc.pprint_many true "\n" print_vdef) smt.vars + (Misc.pprint_many true "\n" print_const) smt.consts + (Misc.pprint_many true "\n" print_kdef) smt.kvars + (Misc.pprint_many true "\n" print_distinct) (groupConsts smt.consts) + (Misc.pprint_many true "\n" print_cstr) smt.cstrs +*) + +let print ppf smt = + let env = SM.of_list (smt.vars ++ smt.consts) in + Format.fprintf ppf + "(set-logic HORN)\n; KVARS\n\n%a\n\n; CONSTRAINTS\n%a\n" + (Misc.pprint_many true "\n" print_kdef) smt.kvars + (Misc.pprint_many true "\n" (print_cstr env)) smt.cstrs + + + +(*************************************************************************) +(************* Helpers for extracting var-sort bindings ******************) +(*************************************************************************) + +let sort_compat x t t' = + Ast.Sort.compat t t' + >> (fun b -> if not b then + Printf.printf "WARNING: k-sort incompatible for %s" + (Sy.to_string x)) + +(* HACKY sort_compat because in the end everything is an Int *) +let sort_compat x t1 t2 = + not (So.is_bool t1) + && not (So.is_bool t2) + && (not (So.is_func t1) || (t1 = t2)) + && (not (So.is_func t2) || (t1 = t2)) + +let vdefs_of_env env r = + env |> C.bindings_of_env + |> (++) [(C.vv_of_reft r, r)] + |> List.map (Misc.app_snd C.sort_of_reft) + (* |> List.filter (not <.> So.is_func <.> snd) *) + |> Misc.fsort fst + +(*************************************************************************) +(************* Build VMap : gather all vars/sorts for regular vars *******) +(*************************************************************************) + +let update_vmap vm (x, t) = + Misc.maybe_iter begin fun t' -> + asserts (sort_compat x t t') "ERROR: v-sort incompatible %s" (Sy.to_string x) + end (SM.maybe_find x vm); + SM.add x t vm + +let update_vmap_int vm (x, t) = + SM.add x So.t_int vm + +let add_c_var_to_vmap vm c = + let vvl = C.vv_of_reft (C.lhs_of_t c) in + let vvr = C.vv_of_reft (C.rhs_of_t c) in + let _ = asserts (vvl = vvr) "Different VVs in Constr: %d" (C.id_of_t c) in + vdefs_of_env (C.env_of_t c) (C.lhs_of_t c) + |> List.fold_left update_vmap_int vm + +let add_wf_var_to_vmap vm w = + vdefs_of_env (C.env_of_wf w) (C.reft_of_wf w) + |> List.fold_left update_vmap_int vm + +(*************************************************************************) +(************ Build KMap: gather scopes for each kvar from wfs** *********) +(*************************************************************************) + +let check_no_subs wid suks = + asserts + (List.for_all (fst <+> A.Subst.is_empty) suks) + "NonTriv Subst wid=%d" wid + +let join vds vds' = + let xm = SM.of_list vds in + List.filter begin fun (x, t) -> + match SM.maybe_find x xm with + | None -> false + | Some t' -> sort_compat x t t' + end vds' + +let update_kmap vdefs km k : kmap = + match SM.maybe_find k km with + | None -> SM.add k (k, vdefs) km + | Some (_,vdefs') -> SM.add k (k, join vdefs vdefs') km + +let add_wf_to_kmap km wf = + let vdefs = vdefs_of_env (C.env_of_wf wf) (C.reft_of_wf wf) + |> List.filter (snd <+> So.is_func <+> not) + in + C.reft_of_wf wf + |> C.kvars_of_reft + >> check_no_subs (C.id_of_wf wf) + |> List.map snd + |> List.fold_left (update_kmap vdefs) km + +let make_kmap defs : kmap = + defs + |> Misc.map_partial (function Cg.Wfc x -> Some x | _ -> None) + |> List.fold_left add_wf_to_kmap SM.empty + +let mkFreshI, _ = Misc.mk_int_factory () +let mkFresh cid x = + Sy.of_string (Format.sprintf "%s_smt_%d_%d" (Sy.to_string x) cid (mkFreshI ())) +(* >> (fun x' -> Format.printf "fresh_var: %a \n" Sy.print x') + *) + +let fresh_vars env cid es = + let t = Hashtbl.create 17 in + let msg = "fresh_vars: cid = "^(string_of_int cid) in + let es' = List.map begin fun e -> match e with + | (A.Var x, _) -> + if Hashtbl.mem t x then + x |> mkFresh cid >> Hashtbl.add t x |> A.eVar + else let _ = Hashtbl.add t x x in e + | _ -> failwith ("ERROR: " ^ msg) + end es in + let l' = Misc.hashtbl_keys t + |> Misc.flap begin fun x -> + let so = SM.safeFind x env msg in + foreach (Hashtbl.find_all t x) begin fun x' -> + (x', so), A.pEqual ((A.eVar x), (A.eVar x')) + end + end + |> List.split + |> Misc.app_snd A.pAnd in + l', es' + +(*************************************************************************) +(************* Translating using the KMap ********************************) +(*************************************************************************) + +let pred_of_kdef (kf, xts) = + A.pBexp <| A.eApp (kf, List.map (fst <+> A.eVar) xts) + +let soln_of_kmap km k = + [pred_of_kdef <| SM.safeFind k km "soln_of_kmap"] + (* >> (Format.printf "soln_of_kmap: k = %a ps = %a \n" Sy.print k (Misc.pprint_many false " " P.print)) + *) + +let tx_constraint s c = + let cid = C.id_of_t c in + let lps = C.preds_of_lhs_nofilter s c in + let v,t,ras = C.rhs_of_t c in + ras |>: begin function + | C.Conc p -> { lhs = A.pAnd ((A.pNot p) :: lps) + ; rhs = None + ; id = cid } + | ra -> { lhs = A.pAnd lps + ; rhs = (match C.preds_of_refa s ra with + | [p] -> Some p + | _ -> failwith "tx_constraint") + ; id = cid} + end + + |>: begin function + (* Ken needed this tx but it messes up with typeclasses... maybe not + * needed any more? + + | { rhs = Some (A.Bexp (A.App (f, es),_), _) } as c' -> + let (xts, eqp), es' = fresh_vars (C.senv_of_t c) cid es in + let r' = A.pBexp (A.eApp (f, es')) in + (xts, {c' with lhs = A.pAnd [eqp; c'.lhs]; rhs = Some r' }) + *) + | c' -> ([], c') + end + +let tx_defs cfg = + let defs = List.map (fun c -> Cg.Cst c) cfg.Cg.cs ++ + List.map (fun c -> Cg.Wfc c) cfg.Cg.ws in + let km = defs |> make_kmap in + let s = soln_of_kmap km in + let cs = cfg.Cg.cs in + let ws = cfg.Cg.ws in + let xts,cs' = List.split <| Misc.flap (tx_constraint s) cs in + { vars = Misc.flatten xts + ++ (SM.to_list <| List.fold_left add_c_var_to_vmap SM.empty cs) + ++ (SM.to_list <| List.fold_left add_wf_var_to_vmap SM.empty ws) + ; kvars = SM.range km + ; cstrs = cs' + ; consts = SM.to_list cfg.Cg.uops + } + +(*************************************************************************) +(************* Slicing into Single Assertions ****************************) +(*************************************************************************) + + +let split_by_assertion cfg = + let ccs, kcs = Misc.tr_partition C.is_conc_rhs cfg.Cg.cs in + Misc.map (fun c -> { cfg with Cg.cs = c :: kcs }) ccs + +let slice_by_assertion cfg = + let cs' = cfg.Cg.cs + |> Cindex.create cfg.Cg.kuts cfg.Cg.ds + |> Cindex.slice + |> Cindex.to_list + in {cfg with Cg.cs = cs' } + + +(*************************************************************************) +(************* API *******************************************************) +(*************************************************************************) + +let dump_smtlib_indexed (no, cfg) = + let su = Misc.maybe_apply (fun x _ -> "." ^ (string_of_int x)) no "" in + let fn = !Constants.out_file ^ su ^ ".smt2" in + let _ = Co.bprintflush mydebug ("BEGIN: Dump SMTLIB \n") in + let me = tx_defs cfg in + let _ = Misc.with_out_formatter fn (fun ppf -> F.fprintf ppf "%a" print me) in + let _ = Co.bprintflush mydebug ("DONE: Dump SMTLIB to " ^ !Constants.out_file ^"\n") in + () + +let dump_smtlib_mono cfg = + dump_smtlib_indexed (None, cfg); + exit 1 + +let dump_smtlib_sliced cfg = + cfg |> split_by_assertion + |>: slice_by_assertion + |> Misc.index_from 0 + |>: (Misc.app_fst some) + |> List.iter dump_smtlib_indexed + |> (fun _ -> exit 1) + +let dump_smtlib = dump_smtlib_sliced + diff --git a/external/fixpoint/toSmtLib.mli b/external/fixpoint/toSmtLib.mli new file mode 100644 --- /dev/null +++ b/external/fixpoint/toSmtLib.mli @@ -0,0 +1,86 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONAst.Symbol. + * + *) + +(* HIDE: all the sigs for defined binders + +type rpred = A.pred +type vdef = Sy.t * So.t +type kdef = Sy.t * vdef list +type cstr = { lhs : A.pred; rhs : rpred option; id : int; } +type smtlib = { + vars : vdef list; + kvars : kdef list; + cstrs : cstr list; + consts : vdef list; +} +type kmap = kdef SM.t +val is_kvar : Sy.t -> bool +val print_brel : F.formatter -> A.brel -> unit +val print_bop : F.formatter -> A.bop -> unit +val print_pred : F.formatter -> A.pred -> unit +val print_expr_app : Sy.t -> F.formatter -> A.expr list -> unit +val print_expr : F.formatter -> A.expr -> unit +val print_sort_base : Format.formatter -> So.t -> unit +val print_sort : Format.formatter -> So.t -> unit +val print_fun_sorts : Format.formatter -> So.t list -> unit +val print_vdef : Format.formatter -> Sy.t * So.t -> unit +val print_const : Format.formatter -> Sy.t * So.t -> unit +val groupConsts : ('a * 'b) list -> ('b * 'a list) list +val print_distinct : Format.formatter -> So.t * Sy.t list -> unit +val print_kdef : Format.formatter -> Sy.t * ('a * So.t) list -> unit +val print_rhs : Format.formatter -> A.pred option -> unit +val binds_of_cstr : 'a SM.t -> cstr -> (SM.key * 'a) list +val print_cstr : So.t SM.t -> Format.formatter -> cstr -> unit +val print : Format.formatter -> smtlib -> unit +val sort_compat : 'a -> So.t -> So.t -> bool +val vdefs_of_env : C.envt -> C.reft -> (Ast.Symbol.t * Ast.Sort.t) list +val update_vmap : So.t SM.t -> Sy.t * So.t -> So.t SM.t +val update_vmap_int : So.t SM.t -> SM.key * 'a -> So.t SM.t +val add_c_var_to_vmap : So.t SM.t -> C.t -> So.t SM.t +val add_wf_var_to_vmap : So.t SM.t -> C.wf -> So.t SM.t +val check_no_subs : int -> (A.Subst.t * 'a) list -> unit +val join : (SM.key * So.t) list -> (SM.key * So.t) list -> (SM.key * So.t) list +val update_kmap : vdef list -> kdef SM.t -> SM.key -> kmap +val add_wf_to_kmap : kdef SM.t -> C.wf -> kdef SM.t +val make_kmap : Cg.deft list -> kmap +val mkFreshI : unit -> int +val mkFresh : int -> Sy.t -> Sy.t +val fresh_vars : 'a SM.t -> int -> A.expr list -> ((Sy.t * 'a) list * A.pred) * A.expr list +val pred_of_kdef : A.Symbol.t * (A.Symbol.t * 'a) list -> A.pred +val soln_of_kmap : (A.Symbol.t * (A.Symbol.t * 'a) list) SM.t -> SM.key -> A.pred list +val tx_constraint : C.soln -> C.t -> ('a list * cstr) list +val tx_defs : 'a Cg.cfg -> smtlib +val split_by_assertion : 'a Cg.cfg -> 'a Cg.cfg list +val slice_by_assertion : 'a Cg.cfg -> 'a Cg.cfg +val dump_smtlib_indexed : int option * 'a Cg.cfg -> unit +val dump_smtlib_mono : 'a Cg.cfg -> 'b +val dump_smtlib_sliced : 'a Cg.cfg -> 'b +val dump_smtlib : 'a Cg.cfg -> 'b + +*) + +(* val render : Format.formatter -> FixConfig.deft list -> unit +val render : Format.formatter -> 'a FixConfig.cfg -> unit +*) +val dump_smtlib : 'a FixConfig.cfg -> unit + diff --git a/external/fixpoint/toplevel.ml b/external/fixpoint/toplevel.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/toplevel.ml @@ -0,0 +1,48 @@ +module BS = BNstats +module SM = Ast.Symbol.SMap +module Co = Constants +module C = FixConstraint +module F = Format +module Misc = FixMisc open Misc.Ops + + +(* +let parse_string str = + let lb = Lexing.from_string str in + ArithParser.aexpr ArithLexer.token lb + +let token_list_of_string s = + let lb = Lexing.from_string s in + let rec helper l = + try + let t = ArithLexer.token lb in + if t = ArithParser.EOF then List.rev l else helper (t::l) + with _ -> List.rev l + in helper [] + +let eval_string env str = ArithInterpreter.eval env (parse_string str) +*) + +(*****************************************************************) +(********************* Command line options **********************) +(*****************************************************************) + +let parse f = + let _ = Errorline.startFile f in + let ic = open_in f in + let rv = Lexing.from_channel ic |> FixParse.defs FixLex.token in + let _ = close_in ic in + rv + +let read_inputs usage = + Co.bprintflush true "\n\n"; + Co.bprintflush true "========================================================\n"; + Co.bprintflush true "© Copyright 2009 Regents of the University of California.\n"; + Co.bprintflush true "All Rights Reserved.\n"; + Co.bprintflush true "========================================================\n"; + Co.bprintflush false (Sys.argv |> Array.to_list |> String.concat " "); + Co.bprintflush false "\n========================================================\n"; + let fs = ref [] in + let _ = Arg.parse Co.arg_spec (fun s -> fs := s::!fs) usage in + let fq = !fs |> BS.time "parse" (Misc.flap parse) |> FixConfig.create in + (!fs, fq) diff --git a/external/fixpoint/toplevel.mli b/external/fixpoint/toplevel.mli new file mode 100644 --- /dev/null +++ b/external/fixpoint/toplevel.mli @@ -0,0 +1,25 @@ +(* + * Copyright © 2009 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONAst.Symbol. + * + *) + +val read_inputs : string -> (string list * SolverArch.qbind FixConfig.cfg) + diff --git a/external/fixpoint/tpGen.ml b/external/fixpoint/tpGen.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/tpGen.ml @@ -0,0 +1,499 @@ +(* + * Copyright © 2008 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + *) + +(* This file is part of the LiquidC Project *) + +module H = Hashtbl +module F = Format +module Co = Constants +module BS = BNstats +module A = Ast +module Sy = A.Symbol +module So = A.Sort +module SM = Sy.SMap +module P = A.Predicate +module E = A.Expression +module Misc = FixMisc +module SSM = Misc.StringMap +module SMT = SmtZ3.SMTZ3 + +open Misc.Ops +open ProverArch + +let mydebug = false + +module MakeProver(SMT : SMTSOLVER) : PROVER = struct + + module Th = Theories.MakeTheory(SMT) + +(*************************************************************************) +(*************************** Type Definitions ****************************) +(*************************************************************************) + +type decl = Vbl of (Sy.t * So.t) | Fun of Sy.t * int | Barrier + +type var_ast = Const of SMT.ast | Bound of int * So.t + +type t = { + c : SMT.context; + tint : SMT.sort; + tbool : SMT.sort; + vart : (decl, var_ast) H.t; + funt : (decl, SMT.fun_decl) H.t; + tydt : (So.t, SMT.sort) H.t; + mutable vars : decl list ; + mutable bnd : int; + thy_sortm : (So.tycon, Th.sortDef) H.t; + thy_symm : (Sy.t, Th.appDef) H.t; +} + +(*************************************************************************) +(************************** Pretty Printing ******************************) +(*************************************************************************) + +let pprint_decl ppf = function + | Vbl (x, t) -> F.fprintf ppf "%a:%a" Sy.print x So.print t + | Barrier -> F.fprintf ppf "----@." + | Fun (s, i) -> F.fprintf ppf "%a[%i]" Sy.print s i + +let dump_decls me = + F.printf "Vars: %a" (Misc.pprint_many true "," pprint_decl) me.vars + +(************************************************************************) +(***************************** Stats Counters **************************) +(************************************************************************) + +let nb_set = ref 0 +let nb_query = ref 0 + +(************************************************************************) +(********************** Misc. Constants *********************************) +(************************************************************************) + +let div_n = Sy.of_string "_DIV" +let tag_n = Sy.of_string "_TAG" +let mul_n = Sy.of_string "_MUL" + +let axioms = [] + +(* TBD these are related to ML and should be in DSOLVE, not here *) +let builtins = + SM.empty + |> SM.add tag_n (So.t_func 0 [So.t_obj; So.t_int]) + |> SM.add div_n (So.t_func 0 [So.t_int; So.t_int; So.t_int]) + |> SM.add mul_n (So.t_func 0 [So.t_int; So.t_int; So.t_int]) + +let select_t = So.t_func 0 [So.t_int; So.t_int] + +let mk_select, is_select = + let ss = "SELECT" in + (fun f -> Sy.to_string f |> (^) (ss ^ "_") |> Sy.of_string), + (fun s -> Sy.to_string s |> Misc.is_prefix ss) + +let fresh = + let x = ref 0 in + fun v -> incr x; (v^(string_of_int !x)) + +(*************************************************************************) +(********************** Typing *******************************************) +(*************************************************************************) + +let varSort env s = + try SM.find s env with Not_found -> + failure "ERROR: varSort cannot type %s in TPZ3 \n" (Sy.to_string s) + +let funSort env s = + try SM.find s builtins with Not_found -> + try SM.find s env with Not_found -> + if is_select s then select_t else + failure "ERROR: could not type function %s in TPZ3 \n" (Sy.to_string s) + +let rec z3Type me t = + Misc.do_memo me.tydt begin fun t -> + if So.is_bool t then me.tbool else + if So.is_int t then me.tint else + match z3TypeThy me t with + | Some t' -> t' + | None -> me.tint + end t t + +and z3TypeThy me t = match So.app_of_t t with + | Some (c, ts) when H.mem me.thy_sortm c -> + let def = H.find me.thy_sortm c in + let zts = List.map (z3Type me) ts in + Some (Th.mk_thy_sort def me.c zts) + | _ -> None + +(***********************************************************************) +(********************** Identifiers ************************************) +(***********************************************************************) + +let getVbl env x = Vbl (x, varSort env x) + +let z3Var_memo me env x = + let vx = getVbl env x in + Misc.do_memo me.vart + (fun () -> + let t = x |> varSort env |> z3Type me in + let sym = fresh "z3v" + (* >> F.printf "z3Var_memo: %a :-> %s\n" Sy.print x *) + |> SMT.stringSymbol me.c in + let rv = Const (SMT.var me.c sym t) in + let _ = me.vars <- vx :: me.vars in + rv) + () vx + +let z3Var me env x = + match BS.time "z3Var memo" (z3Var_memo me env) x with + | Const v -> v + | Bound (b, t) -> SMT.boundVar me.c (me.bnd - b) (z3Type me t) + + +let z3Fun me env p t k = + Misc.do_memo me.funt begin fun _ -> + match So.func_of_t t with + | None -> assertf "MATCH ERROR: z3ArgTypes" + | Some (_, ts, rt) -> + let ts = List.map (z3Type me) ts in + let rt = z3Type me rt in + let cf = SMT.stringSymbol me.c (fresh "z3f") in + let rv = SMT.funcDecl me.c cf (Array.of_list ts) rt in + let _ = me.vars <- (Fun (p,k))::me.vars in + rv + end () (Fun (p, k)) + +(**********************************************************************) +(********************** Pred/Expr Transl ******************************) +(**********************************************************************) + + +exception Z3RelTypeError + +let z3Bind me env x t = + let vx = Vbl (x, varSort env x) in + me.bnd <- me.bnd + 1; + H.replace me.vart vx (Bound (me.bnd, t)); + me.vars <- vx :: me.vars; + SMT.stringSymbol me.c (fresh "z3b") + +let rec z3Rel me env (e1, r, e2) = + let p = A.pAtom (e1, r, e2) in + let ok = A.sortcheck_pred Theories.is_interp (Misc.flip SM.maybe_find env) p in + (* let _ = F.printf "z3Rel: e = %a, res = %b \n" P.print p ok in + let _ = F.print_flush () in *) + if ok then + SMT.mkRel me.c r (z3Exp me env e1) (z3Exp me env e2) + else begin + SM.iter (fun s t -> F.printf "@[%a :: %a@]@." Sy.print s So.print t) env; + F.printf "@[%a@]@.@." P.print (A.pAtom (e1, r, e2)); + F.print_flush (); + raise Z3RelTypeError + end + +and z3App me env p zes = + let t = funSort env p in + let cf = z3Fun me env p t (List.length zes) in + SMT.mkApp me.c cf zes + +and z3AppThy me env def tyo f es = + match A.sortcheck_app Theories.is_interp (Misc.flip SM.maybe_find env) tyo f es with + | Some (s, t) -> + let zts = So.sub_args s |> List.map (snd <+> z3Type me) in + let zes = es |> List.map (z3Exp me env) in + Th.mk_thy_app def me.c zts zes + | None -> + A.eApp (f, es) + |> E.to_string + |> assertf "z3AppThy: sort error %s" + +and z3Mul me env = function + | ((A.Con (A.Constant.Int i), _), e) + | (e, (A.Con (A.Constant.Int i), _)) -> + SMT.mkMul me.c (SMT.mkInt me.c i me.tint) (z3Exp me env e) + | (e1, e2) when !Co.uif_multiply -> + z3App me env mul_n (List.map (z3Exp me env) [e1; e2]) + | (e1, e2) -> + SMT.mkMul me.c (z3Exp me env e1) (z3Exp me env e2) + +and z3Exp me env = function + | A.Con (A.Constant.Int i), _ -> + SMT.mkInt me.c i me.tint + | A.Var s, _ -> + z3Var me env s + | A.Cst ((A.App (f, es), _), t), _ when (H.mem me.thy_symm f) -> + z3AppThy me env (H.find me.thy_symm f) (Some t) f es + | A.App (f, es), _ when (H.mem me.thy_symm f) -> + z3AppThy me env (H.find me.thy_symm f) None f es + | A.App (f, es), _ -> + z3App me env f (List.map (z3Exp me env) es) + | A.Bin (e1, A.Plus, e2), _ -> + SMT.mkAdd me.c (z3Exp me env e1) (z3Exp me env e2) + | A.Bin (e1, A.Minus, e2), _ -> + SMT.mkSub me.c (z3Exp me env e1) (z3Exp me env e2) + | A.Bin((A.Con (A.Constant.Int n1), _), A.Times, (A.Con (A.Constant.Int n2), _)),_ -> + SMT.mkInt me.c (n1 * n2) me.tint + | A.Bin (e1, A.Times, e2), _ -> + z3Mul me env (e1, e2) + | A.Bin (e1, A.Div, e2), _ -> + z3App me env div_n (List.map (z3Exp me env) [e1;e2]) + | A.Bin (e, A.Mod, (A.Con (A.Constant.Int i), _)), _ -> + SMT.mkMod me.c (z3Exp me env e) (SMT.mkInt me.c i me.tint) + | A.Bin (e1, A.Mod, e2), _ -> + SMT.mkMod me.c (z3Exp me env e1) (z3Exp me env e2) + | A.Ite (e1, e2, e3), _ -> + SMT.mkIte me.c (z3Pred me env e1) (z3Exp me env e2) (z3Exp me env e3) + + | A.Fld (f, e), _ -> + z3App me env (mk_select f) [z3Exp me env e] (** REQUIRES: disjoint field names *) + | A.Cst (e, _), _ -> + z3Exp me env e + | e -> + assertf "z3Exp: Cannot Convert %s!" (E.to_string e) + +and z3Pred me env = function + | A.True, _ -> + SMT.mkTrue me.c + | A.False, _ -> + SMT.mkFalse me.c + | A.Not p, _ -> + SMT.mkNot me.c (z3Pred me env p) + | A.And ps, _ -> + SMT.mkAnd me.c (List.map (z3Pred me env) ps) + | A.Or ps, _ -> + SMT.mkOr me.c (List.map (z3Pred me env) ps) + | A.Imp (p1, p2), _ -> + SMT.mkImp me.c (z3Pred me env p1) (z3Pred me env p2) + | A.Iff (p1, p2), _ -> + SMT.mkIff me.c (z3Pred me env p1) (z3Pred me env p2) + | A.Atom (e1, r, e2), _ -> + z3Rel me env (e1, r, e2) + | A.Bexp e, _ -> + let a = z3Exp me env e in + let s2 = E.to_string e in + let Some so = A.sortcheck_expr Theories.is_interp (Misc.flip SM.maybe_find env) e in + let sos = So.to_string so in + (* let s1 = SMT.astString me.c a in + let _ = asserts (SMT.isBool me.c a) + "Bexp is not bool (e = %s)! z3=%s, fix=%s, sort=%s" + (E.to_string e) s1 s2 sos + in *) + a + + | A.Forall (xts, p), _ -> + let (xs, ts) = List.split xts in + let zargs = Array.of_list (List.map2 (z3Bind me env) xs ts) in + let zts = Array.of_list (List.map (z3Type me) ts) in + let rv = SMT.mkAll me.c zts zargs (z3Pred me env p) in + let _ = me.bnd <- me.bnd - (List.length xs) in + rv + | p -> + assertf "z3Pred: Cannot Convert %s!" (P.to_string p) + + + +let z3Pred me env p = + try + let p = BS.time "fixdiv" A.fixdiv p in + BS.time "z3Pred" (z3Pred me env) p + with ex -> (F.printf "z3Pred: error converting %a\n" P.print p) ; raise ex + +(***************************************************************************) +(***************** Binder/Stack Management *********************************) +(***************************************************************************) + +let rec vpop (cs,s) = + match s with + | [] -> (cs,s) + | Barrier :: t -> (cs,t) + | h :: t -> vpop (h::cs,t) + +let clean_decls me = + let cs, vars' = vpop ([],me.vars) in + let _ = me.vars <- vars' in + List.iter begin function + | Barrier -> failure "ERROR: TPZ3-cleanDecls" + | Vbl _ as d -> H.remove me.vart d + | Fun _ as d -> H.remove me.funt d + end cs + +let handle_vv me env vv = + H.remove me.vart (getVbl env vv) (* RJ: why are we removing this? *) + + +(************************************************************************) +(********************************* API **********************************) +(************************************************************************) + +let create_theories () = + Th.theories + |> (Misc.hashtbl_of_list_with Th.sort_name <**> Misc.hashtbl_of_list_with Th.sym_name) + +let assert_distinct_constants me env = function [] -> () | cs -> + cs |> Misc.kgroupby (varSort env) + |> List.iter begin fun (_, xs) -> + xs >> Co.bprintf mydebug "Distinct Constants: %a \n" (Misc.pprint_many false ", " Sy.print) + |> List.map (z3Var me env) + |> SMT.assertDistinct me.c + end + +let prep_preds me env ps = + let ps = List.rev_map (z3Pred me env) ps in + let _ = me.vars <- Barrier :: me.vars in + ps + +let valid me p = + SMT.bracket me begin fun _ -> + SMT.assertPreds me [SMT.mkNot me p]; + BS.time "unsat" SMT.unsat me + end + +(* API *) +let set_filter (me: t) (env: So.t SM.t) (vv: Sy.t) ps qs = + let _ = ignore(nb_set += 1); ignore (nb_query += List.length qs) in + let _ = handle_vv me env vv in + let zps = prep_preds me env ps in (* DO NOT PUSH INSIDE SMT.bracket or z3 blocks postests/ll3.c *) + SMT.bracket me.c begin fun _ -> + let _ = SMT.assertPreds me.c zps in + let tqs, fqs = List.partition (snd <+> P.is_tauto) qs in + let fqs = fqs |> List.rev_map (Misc.app_snd (z3Pred me env)) + |> Misc.filter (snd <+> valid me.c) in + let _ = clean_decls me in + (List.map fst tqs) ++ (List.map fst fqs) + end + +(* API *) +let print_stats ppf me = + SMT.print_stats ppf (); + F.fprintf ppf "TP stats: sets=%d, queries=%d, count=%d\n" + !nb_set !nb_query (List.length me.vars) + +(*************************************************************************) +(****************** Unsat Core for CEX generation ************************) +(*************************************************************************) + +let mk_prop_var me pfx i : SMT.ast = + i |> string_of_int + |> (^) pfx + |> SMT.stringSymbol me.c + |> Misc.flip (SMT.var me.c) me.tbool + +let mk_prop_var_idx me ipa : (SMT.ast array * (SMT.ast -> 'a option)) = + let va = Array.mapi (fun i _ -> mk_prop_var me "uc_p_" i) ipa in + let vm = va + |> Array.map (SMT.astString me.c) + |> Misc.array_to_index_list + |> List .map Misc.swap + |> SSM.of_list in + let f z = SSM.maybe_find (SMT.astString me.c z) vm + |> Misc.maybe_map (fst <.> Array.get ipa) in + (va, f) + +let mk_pa me p2z pfx ics = + ics |> List.map (Misc.app_snd p2z) + |> Array.of_list + |> Array.mapi (fun i (x, p) -> (x, p, mk_prop_var me pfx i)) + +(* API *) +let unsat_core me env bgp ips = + let _ = H.clear me.vart in + let p2z = A.fixdiv <+> z3Pred me env in + let ipa = ips |> List.map (Misc.app_snd p2z) |> Array.of_list in + let va, f = mk_prop_var_idx me ipa in + let zp = ipa |> Array.mapi (fun i (_, p) -> SMT.mkIff me.c va.(i) p) + |> Array.to_list + |> (++) [p2z bgp] + |> SMT.mkAnd me.c in + SMT.bracket me.c begin fun _ -> + let _ = SMT.assertPreds me.c [zp] in + let n = Array.length va in + let va' = Array.map id va in + failwith "SMT-UNSAT-CORE-TODO" + (************************************ + match SMT.check_assumptions me.c va n va' with + | (Z3.L_FALSE, m,_, n, ucore) + -> Array.map f ucore |> Array.to_list |> Misc.map_partial id + | _ -> [] + ************************************) + end + +let contra me p = + SMT.bracket me begin fun _ -> + SMT.assertPreds me [p]; + BS.time "unsat" SMT.unsat me + end + +(* API *) +let is_contra me env = z3Pred me env <+> contra me.c + +(* API *) +let unsat_suffix me env p ps = + let _ = if SMT.unsat me.c then assertf "ERROR: unsat_suffix" in + SMT.bracket me.c begin fun _ -> + let rec loop j = function [] -> None | zp' :: zps' -> + SMT.assertPreds me.c [zp']; + if SMT.unsat me.c then Some j else loop (j-1) zps' + in loop (List.length ps) (List.map (z3Pred me env) (p :: List.rev ps)) + end + +(***********************************************************************) +(******** Prover Object ************************************************) +(***********************************************************************) + +(* API *) +let create ts env ps consts = + let _ = asserts (ts = []) "ERROR: TPZ3-create non-empty sorts!" in + let c = SMT.mkContext [|("MODEL", "false"); ("MODEL_PARTIAL", "true")|] in + let som, sym = create_theories () in + let me = { c = c; + tint = SMT.mkIntSort c; + tbool = SMT.mkBoolSort c; + tydt = H.create 37; + vart = H.create 37; + funt = H.create 37; + vars = []; + bnd = 0; + thy_sortm = som; + thy_symm = sym + } + in + let _ = List.iter (z3Pred me env <+> SMT.assertAxiom me.c) (axioms ++ ps) in + let _ = assert_distinct_constants me env consts in + me + +class tprover ts env ps consts : prover = + object (self) + val me = create ts env ps consts + method interp_syms = Theories.interp_syms + method set_filter : 'a. Ast.Sort.t Ast.Symbol.SMap.t + -> Ast.Symbol.t + -> Ast.pred list + -> ('a * Ast.pred) list + -> 'a list + = set_filter me + method print_stats = fun ppf -> print_stats ppf me + method is_contra = is_contra me + method unsat_suffix = unsat_suffix me + end + +let mkProver ts env ps consts = new tprover ts env ps consts + +end diff --git a/external/fixpoint/tpNull.ml b/external/fixpoint/tpNull.ml new file mode 100644 --- /dev/null +++ b/external/fixpoint/tpNull.ml @@ -0,0 +1,38 @@ +(* + * Copyright © 2008 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + *) + +open FixMisc.Ops + +module Mem : ProverArch.PROVER = TpGen.MakeProver(SmtZ3.SMTZ3) +module Smt : ProverArch.PROVER = TpGen.MakeProver(SmtLIB2.SMTLib2) + +let mydebug = false + +let create ts env ps cs + = match !Constants.smt_solver with + | None -> + Constants.bprintflush mydebug "\nUSING z3 bindings \n"; + Mem.mkProver ts env ps cs + | Some s -> + Constants.bprintflush mydebug ("\nUSING SMTLIB bindings with " ^ s ^ "\n"); + Smt.mkProver ts env ps cs + diff --git a/external/misc/bNstats.ml b/external/misc/bNstats.ml new file mode 100644 --- /dev/null +++ b/external/misc/bNstats.ml @@ -0,0 +1,118 @@ +(* + * + * Copyright (c) 2001 by + * George C. Necula necula@cs.berkeley.edu + * Scott McPeak smcpeak@cs.berkeley.edu + * Wes Weimer weimer@cs.berkeley.edu + * + * All rights reserved. Permission to use, copy, modify and distribute + * this software for research purposes only is hereby granted, + * provided that the following conditions are met: + * 1. XSRedistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * 3. The name of the authors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * DISCLAIMER: + * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + + (* A hierarchy of timings *) +type t = { name : string; + mutable time : float; + mutable sub : t list} + + (* Create the top level *) +let top = { name = "TOTAL"; + time = 0.0; + sub = []; } + + (* The stack of current path through + * the hierarchy. The first is the + * leaf. *) +let current : t list ref = ref [top] + +let reset () = top.sub <- [] + +let do_time = ref true + +let dont_time () = do_time := false + +let print chn msg = + (* Total up *) + top.time <- List.fold_left (fun sum f -> sum +. f.time) 0.0 top.sub; + let rec prTree ind node = + Printf.fprintf chn "%s%-20s %6.3f s\n" + (String.make ind ' ') node.name node.time ; + List.iter (prTree (ind + 2)) node.sub + in + Printf.fprintf chn "%s" msg; + List.iter (prTree 0) [ top ] + +let time str f arg = + (* Find the right stat *) + let stat : t = + let curr = match !current with h :: _ -> h | _ -> assert false in + let rec loop = function + h :: _ when h.name = str -> h + | _ :: rest -> loop rest + | [] -> + let nw = {name = str; time = 0.0; sub = []} in + curr.sub <- nw :: curr.sub; + nw + in + loop curr.sub + in + let oldcurrent = !current in + current := stat :: oldcurrent; + let start = (Unix.times ()).Unix.tms_utime in + let _ = if str == "interp" then Printf.printf "interp start = %6.3f\n" start in + let res = + try (f arg) with + x -> (let finish = Unix.times () in + let diff = finish.Unix.tms_utime -. start in + let _ = if str == "interp" then Printf.printf "interp elapsed = %6.3f\n" diff in + stat.time <- stat.time +. (diff); + current := oldcurrent; + raise x) (* Pop the current stat *) + in + let finish = Unix.times () in + let diff = finish.Unix.tms_utime -. start in + let _ = if str == "interp" then Printf.printf "interp elapsed = %6.3f\n" diff in + stat.time <- stat.time +. (diff); + current := oldcurrent; + res + + +let time str f arg = if !do_time then time str f arg else f arg + +let print chn msg = if !do_time then print chn msg else () + + + + + + + + + + + + + + + + diff --git a/external/misc/bNstats.mli b/external/misc/bNstats.mli new file mode 100644 --- /dev/null +++ b/external/misc/bNstats.mli @@ -0,0 +1,48 @@ +(* + * + * Copyright (c) 2001 by + * George C. Necula necula@cs.berkeley.edu + * Scott McPeak smcpeak@cs.berkeley.edu + * Wes Weimer weimer@cs.berkeley.edu + * + * All rights reserved. Permission to use, copy, modify and distribute + * this software for research purposes only is hereby granted, + * provided that the following conditions are met: + * 1. XSRedistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * 3. The name of the authors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * DISCLAIMER: + * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(** Utilities for maintaining timing statistics *) + +val dont_time : unit -> unit + +(** Reset all the timings *) +val reset : unit -> unit + +(** Time a function and associate the time with the given string. If some + timing information is already associated with that string, then accumulate + the times. If this function is invoked within another timed function then + you can have a hierarchy of timings *) +val time : string -> ('a -> 'b) -> 'a -> 'b + +(** Print the current stats preceeded by a message *) +val print : out_channel -> string -> unit + diff --git a/external/misc/constants.ml b/external/misc/constants.ml new file mode 100644 --- /dev/null +++ b/external/misc/constants.ml @@ -0,0 +1,405 @@ +(* + * Copyright © 2009 The Regents of the University of California. + * All rights reserved. Permission is hereby granted, without written + * agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + *) + +open FixMisc.Ops +module SS = FixMisc.StringSet + +(******* This module contains globals representing "flags" **************) +let lib_path = Sys.argv.(0) |> Filename.dirname |> ref +let annotsep_name = "\n\n=+=\n\n" +let global_name = "GLOBAL" + + +let file: string option ref = ref None (* last commandline param*) +let csolve_file_prefix = ref "csolve" (* where to find/place csolve-related files *) +let safe = ref false (* -safe *) +let manual = ref false (* -manual *) +let out_file = ref "out" (* -save *) +let save_file = ref "out.fq" (* -save *) +let dump_ref_constraints= ref false (* -drconstr *) +let ctypes_only = ref false (* -ctypes *) +let verbose_level = ref 0 (* -v *) +let inccheck = ref SS.empty (* -inccheck *) +let cex = ref false (* -counterexamples *) +let shortannots = ref true (* -shortannots *) +let strictsortcheck = ref false (* -strictsortcheck *) +let latex_file: string option ref = ref None (* translate to LaTeX *) +let armc_file: string option ref = ref None (* translate to ARMC *) +let horn_file: string option ref = ref None (* translate to Horn clauses *) +let raw_horn_file: string option ref = ref None (* translate to raw Horn clauses *) +let q_armc_file: string option ref = ref None (* OBSOLETE translate to Q'ARMC file *) +let dot_file: string option ref = ref None (* translate to dot file *) +let purify_function_application = ref true (* replace fun-terms by existentially quantified variables *) +let z3_timeout = ref 25 + +let fastscalar = ref false (* -fastscalar *) +let vannots = ref true (* -noannots *) +let minquals = ref true (* -allquals *) +let ptag = ref true (* -ptag *) +let genspec = ref false (* -genspec *) +let simplify_t = ref false (* simplify and prune vacuous FixConstraint.t constraints *) +let copyprop = ref true (* perform copyprop to eliminate tempvars *) +let root = ref "" (* root function *) +let refine_sort = ref false (* -refinesort *) +let sorted_quals = ref false (* -sortedquals *) +let true_unconstrained = ref true (* -true_unconstrained *) +let do_nothing = ref false (* -nop *) +let smt_solver = ref (Some "z3") (* -smtsolver [z3, yices, cvc4, ...] *) +let dump_imp = ref false (* -imp *) +let dump_smtlib = ref false (* -smtlib *) +let dump_simp = ref "" (* -simp *) +let prune_live = ref false (* -prunelive *) +let print_nontriv = ref false (* -print_nontriv *) +let heapify_nonarrays = ref true (* heapify all stack variables *) +let timeout = ref (-1) +let lfp = ref true (* -nolfp *) +let slice = ref true (* -slice *) +let no_lib_hquals = ref false (* -no-lib-hquals *) +let gen_qual_sorts = ref true (* -no-gen-qual-sorts *) +let web_demo = ref false (* -web-demo *) +let simple = ref true (* -simple *) + +(* JHALA: what do these do ? *) +let psimple = ref true (* -psimple *) +let dump_graph = ref false (* -dgraph :: this probably caused the dsolve solver to dump the constraint graph *) +let dropcalls = ref false (* -dropcalls *) +let adjdeps = ref true (* -origdeps *) +let check_is = ref false (* -check-indices *) +let trace_scalar = ref false (* -trace-scalar *) +let prune_index = ref false (* -prune-index *) +let uif_multiply = ref true (* -no-uif-multiply *) + +(****************************************************************) +(************* Output levels ************************************) +(****************************************************************) + +(* verbosity levels by purpose *) +let ol_always = 0 +let ol_solve_error = 1 +let ol_warning = 1 +let ol_solve_master = 2 +let ol_solve_stats = 2 +let ol_timing = 2 +let ol_warn_mlqs = 3 +let ol_normalized = 3 +let ol_finals = 3 +let ol_ctypes = 3 +let ol_dquals = 4 +let ol_unique_names = 5 (* must be > ol_dquals *) +let ol_solve = 10 +let ol_refine = 11 +let ol_scc = 12 +let ol_dump_env = 10 +let ol_axioms = 5 +let ol_dump_prover = 20 +let ol_verb_constrs = 21 +let ol_dump_wfs = 22 +let ol_dump_meas = 30 +let ol_dump_quals = 50 +let ol_insane = 200 + +let verb_stack = ref [] +let ck_olev l = l <= !verbose_level +let null_formatter = Format.make_formatter (fun a b c -> ()) ignore +let nprintf a = Format.fprintf null_formatter a +let cprintf l = if ck_olev l then Format.printf else nprintf +let ecprintf l = if ck_olev l then Format.eprintf else nprintf +let fcprintf ppf l = if ck_olev l then Format.fprintf ppf else nprintf +let icprintf printer l ppf = if ck_olev l then printer ppf else printer null_formatter +let cprintln l s = if ck_olev l then Printf.ksprintf (Format.printf "@[%s@\n@]") s else nprintf +let elevate_olev l = if ck_olev l then () else verb_stack := !verbose_level :: !verb_stack; verbose_level := l +let restore_olev = match !verb_stack with + | x :: xs -> verbose_level := x; verb_stack := xs + | _ -> () + +let bprintf b = if b || ck_olev 1 then Format.printf else nprintf +let bprintflush b s = bprintf b "%s" s; flush stdout + + + +(******************************************************************************) +(*********************************** Logging **********************************) +(******************************************************************************) + +let logChannel = ref stdout +let logFormatter = ref (Format.formatter_of_out_channel stdout) + +let setLogChannel lc = + logChannel := lc; + logFormatter := Format.formatter_of_out_channel lc + +let logPrintf a = Format.fprintf !logFormatter a +let blogPrintf b = if b then logPrintf else nprintf +let cLogPrintf l = if ck_olev l then logPrintf else nprintf + +(*****************************************************************) +(*********** Command Line Options ********************************) +(*****************************************************************) + +(* taken from dsolve/liquid/liquid.ml *) + +let arg_spec = + [("-out", + Arg.String (fun s -> out_file := s), + " Save solution to file [out]"); + ("-save", + Arg.String (fun s -> save_file := s), + " Save constraints to file [out.fq]"); + ("-inccheck", + Arg.String (fun s -> true_unconstrained := false; + inccheck := SS.add s !inccheck), + " Incrementally check the specified function"); + ("-noslice", + Arg.Clear slice, + " Compute fixpoint for all kvars, not just those affecting property"); + ("-nolfp", + Arg.Clear lfp, + " Weaken environment (do not produce least fixed-point solution)"); + ("-origdeps", + Arg.Clear adjdeps, + " Don't adjust constraint dependencies [true]"); + ("-dropcalls", + Arg.Set dropcalls, + " Ignore function calls during consgen [false]"); + ("-drconstr", + Arg.Set dump_ref_constraints, + " Dump refinement constraints [false]"); + ("-noshortannots", + Arg.Clear shortannots, + " Annotations with full predicates (not names) [false]"); + ("-strictsortcheck", + Arg.Set strictsortcheck, + " Strict Sort Checking -- e.g. ptr/int comparisons -- for non-C constraints + [false]"); + ("-ctypes", + Arg.Set ctypes_only, + " Infer ctypes only [false]"); + ("-safe", + Arg.Set safe, + " run in failsafe mode [false]"); + ("-manual", + Arg.Set manual, + " only verify manually-inserted checks"); + ("-fastscalar", + Arg.Set fastscalar, + " use new (experimental) fastscalar solver, eventually will be default"); + ("-counterexamples", + Arg.Set cex, + " generate counterexamples [false] "); + ("-noannots", + Arg.Unit (fun () -> vannots := false; minquals := false), + " generate vim readable annotation file [true] "); + ("-allquals", + Arg.Clear minquals, + " don't minimize qualifiers by using pre-computed one-level implication [true] "); + ("-timeout", + Arg.Set_int timeout, + " limit total time (in seconds, default no limit)"); + ("-ptag", + Arg.Set ptag, + " prioritize constraints using lexico-ordering on tags [true]"); + ("-genspec", + Arg.Set genspec, + " Generate spec file only [false]"); + ("-root", + Arg.String (fun s -> root := s), + " Use root function []"); + ( "-nosimple" + , Arg.Clear simple + , " Directly propagate qualifiers for simple constraints (K1 <: K2) [true]"); + ("-psimple", + Arg.Set psimple, + " prioritize simple constraints [true]"); + ("-dgraph", + Arg.Set dump_graph, + " dump constraints SCC to constraints.dot [false]"); + ("-sortedquals", + Arg.Set sorted_quals, + " use sorted parameters in the qualifiers, to speed up instantiation. Should + become default after vetting."); + ("-refinesort", + Arg.Set refine_sort, + " use sortchecking to refine constraints -- and toss out badly instantiated quals. + Shouldn't need except for backward compatibility with dsolve constraints, DONT USE!"); + ("-notruekvars", + Arg.Clear true_unconstrained, + " don't true unconstrained kvars [true]"); + ("-v", Arg.Int (fun c -> verbose_level := c), + " Set degree of analyzer verbosity:\n\ + \032 0 No output\n\ + \032 1 +Verbose errors\n\ + \032 [2] +Verbose stats, timing\n\ + \032 3 +Print normalized source\n\ + \032 11 +Verbose solver\n\ + \032 13 +Dump constraint graph\n\ + \032 64 +Drowning in output"); + ("-latex", + Arg.String (fun s -> + let l = String.length s in + if l = 0 || String.sub s (l-4) 4 <> ".tex" then + print_endline "-latex: invalid parameter" + else + latex_file := Some s), + " translates constraints to LaTeX file" + ); + ("-armc", + Arg.String (fun s -> + let l = String.length s in + if l = 0 then + print_endline "-armc: invalid parameter" + else + armc_file := Some s), + " translate constraints to ARMC file" + ); + ("-horn", + Arg.String (fun s -> + let l = String.length s in + if l = 0 then + print_endline "-rules: invalid parameter" + else + horn_file := Some s), + " translate constraints to Horn clauses" + ); + ("-raw-horn", + Arg.String (fun s -> + let l = String.length s in + if l = 0 then + print_endline "-rules: invalid parameter" + else + raw_horn_file := Some s), + " translate constraints to raw Horn clauses" + ); + ("-qarmc", + Arg.String (fun s -> + let l = String.length s in + if l = 0 then + print_endline "-qarmc: invalid parameter" + else + q_armc_file := Some s), + " translate constraints to Q'ARMC file" + ); + ("-dot", + Arg.String (fun s -> + let l = String.length s in + if l = 0 || String.sub s (l-4) 4 <> ".dot" then + print_endline "-dot: invalid parameter" + else + dot_file := Some s), + " translate constraints to dot file" + ); + ("-keep-uif", + Arg.Clear purify_function_application, + " do not replace function terms by existentially quantified variables" + ); + ("-no-simplify-t", + Arg.Clear simplify_t, + " do not simplify constraints" + ); + ("-simplify-t", + Arg.Set simplify_t, + " simplify constraints" + ); + ("-nocopyprop", + Arg.Clear copyprop, + " simplify constraints via local copy propagation [true]" + ); + ("-libpath", + Arg.String (fun s -> lib_path := s), + (" library path for default spec, quals ["^(!lib_path)^"]") + ); + ("-nop", + Arg.Set do_nothing, + " do nothing (useful for regression tests known to be broken)"; + ); + ("-imp", + Arg.Set dump_imp, + " print constraints as IMP program (experimental)" + ); + ("-smtsolver", + Arg.String (fun s -> smt_solver := if s = "z3mem" then None else Some s), + (" SMT solver (default: Z3 SMTLIB2. z3mem for bindings)") + ); + ("-smtlib", + Arg.Set dump_smtlib, + " print constraints as SMTLIB query (experimental)" + ); + ("-prunelive", + Arg.Set prune_live, + " Restrict liquid types to live variables (experimental)" + ); + ("-no-uif-multiply", + Arg.Clear uif_multiply, + " Don't encode non-linear multiplication with UIFs [true]" + ); + ("-simp", + Arg.String ((:=) dump_simp), + " print simplified constraints to save-file (experimental) use [andrey] or [jhala] or [id]" + ); + ("-print-nontriv", + Arg.Set (print_nontriv), + " print non-trivial bindings in each environment [false]" + ); + ("-trace-scalar", + Arg.Set(trace_scalar), + " print constraints and index values in the Index solver"); + ("-check-indices", + Arg.Set(check_is), + " sanity check computed indices"); + ("-prune-index", + Arg.Set(prune_index), + " use the index domain to prune initial solution"); + ("-no-lib-hquals", + Arg.Set(no_lib_hquals), + " don't use qualifier library in type inference"); + ("-no-gen-qual-sorts", + Arg.Clear(gen_qual_sorts), + " don't generalize parameter sorts in qualifiers"); + ("-web-demo", + Arg.Set(web_demo), + " set HTML output to web demo mode"); + ] + + +let is_prefix p s = + let reg = Str.regexp p in + Str.string_match reg s 0 + +(******************************************************************) +(*************** Paths for builtin specs, quals etc ***************) +(******************************************************************) + +let get_lib_squals = fun () -> Filename.concat !lib_path "lib.squals" +let get_lib_hquals = fun () -> Filename.concat !lib_path "lib.hquals" +let get_lib_spec = fun () -> Filename.concat !lib_path "lib.spec" +let get_lib_h = fun () -> Filename.concat !lib_path "lib.h" +let get_csolve_h = fun () -> Filename.concat !lib_path "../lib/csolve.h" +let get_c2html = fun () -> Filename.concat !lib_path "../demo/jquery/cs2html.py" + +(* TODO: FIX SHADY HACK *) +let set_csolve_file_prefix fn = csolve_file_prefix := fn +(* + let fn' = try (Filename.chop_extension fn)^".c" with _ -> fn in + if Filename.check_suffix fn ".o" && Sys.file_exists fn' then + csolve_file_prefix := fn' + else + csolve_file_prefix := fn + *) diff --git a/external/misc/errorline.ml b/external/misc/errorline.ml new file mode 100644 --- /dev/null +++ b/external/misc/errorline.ml @@ -0,0 +1,31 @@ +type info = + { mutable linenum: int; (* current line number *) + mutable linepos: int; (* char position of beginning of current line *) + fileName : string (* current file name *) + } + +let current : info ref = + ref + { linenum = 1 ; + linepos = 0 ; + fileName = "" + } + +let startFile fname = + current := { linenum = 1 ; + linepos = 0 ; + fileName = fname} + +let startNewline n = + let i = !current in + begin + i.linenum <- i.linenum + 1 ; + i.linepos <- n + end + + +let error n msg = + let i = !current in + Printf.eprintf "%s at %s: %d.%d\n" + msg i.fileName i.linenum (n - i.linepos) + diff --git a/external/misc/fcommon.ml b/external/misc/fcommon.ml new file mode 100644 --- /dev/null +++ b/external/misc/fcommon.ml @@ -0,0 +1,128 @@ +(* + * Copyright © 2008 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +module F = Format +module C = Constants + +let mydebug = false + +(****************************************************************) +(************* SCC Ranking **************************************) +(****************************************************************) + +module Int : Graph.Sig.COMPARABLE with type t = int * string = +struct + type t = int * string + let compare = compare + let hash = Hashtbl.hash + let equal = (=) +end + +module G = Graph.Imperative.Digraph.Concrete(Int) + +module SCC = Graph.Components.Make(G) + +(* Use of Graphviz *) + +let io_to_string = function + | Some i -> string_of_int i + | None -> "*" + +module DotGraph = +struct + type t = G.t + module V = G.V + module E = G.E + let iter_vertex = G.iter_vertex + let iter_edges_e = G.iter_edges_e + let graph_attributes g = [`Size (11.0, 8.5); `Ratio (`Float 1.29)] + let default_vertex_attributes g = [`Shape `Box] + let vertex_name (i,_) = string_of_int i (* Printf.sprintf "V_%d" i *) + let vertex_attributes (_,s) = [`Label s] + let default_edge_attributes g = [] + let edge_attributes e = [] + let get_subgraph v = None +end + +module Dot = Graph.Graphviz.Dot(DotGraph) + +let dump_graph s g = + let oc = open_out (s^".dot") in + Dot.output_graph oc g; + close_out oc + +let int_s_to_string ppf (i,s) = + F.fprintf ppf "(%d,%s)" i s + +let scc_print g a = + C.bprintf mydebug "dep graph: vertices= %d, sccs= %d \n" (G.nb_vertex g) (Array.length a); + C.bprintf mydebug "scc sizes: \n"; + Array.iteri begin fun i xs -> + C.bprintf mydebug "%d : [%a] \n" i (FixMisc.pprint_many false "," int_s_to_string) xs + end a; + C.bprintf mydebug "\n" + +let make_graph s f is ijs = + let g = G.create () in + let _ = List.iter (fun i -> G.add_vertex g (i, (f i))) is in + let _ = List.iter (fun (i,j) -> G.add_edge g (i,(f i)) (j,(f j))) ijs in + let _ = if !Constants.dump_graph then dump_graph s g in + g + +(* Given list [(u,v)] returns a numbering [(ui,ri)] s.t. + * 1. if ui,uj in same SCC then ri = rj + * 2. if ui -> uj then ui >= uj *) +let scc_rank s f is ijs = + let g = BNstats.time "making_graph" (make_graph s f is) ijs in + let a = SCC.scc_array g in + let _ = scc_print g a in + let sccs = FixMisc.array_to_index_list a in + FixMisc.flap (fun (i,vs) -> List.map (fun (j,_) -> (j,i)) vs) sccs + +(* +let g1 = [(1,2);(2,3);(3,1);(2,4);(3,4);(4,5)];; +let g2 = [(0,1);(1,2);(2,0);(1,3);(4,3); + (5,6);(5,7);(6,9);(7,9);(7,8);(8,5)];; +let g3 = (6,2)::g2;; +let g4 = (2,6)::g2;; + +let n1 = make_scc_num g1 ;; +let n2 = make_scc_num g2 ;; +let n3 = make_scc_num g3 ;; +let n4 = make_scc_num g4 ;; *) + +(* +type fc_id = int option +type subref_id = int + +module WH = + Heaps.Functional(struct + type t = subref_id * int * (int * bool * fc_id) + let compare (_,ts,(i,j,k)) (_,ts',(i',j',k')) = + if i <> i' then compare i i' else + if ts <> ts' then -(compare ts ts') else + if j <> j' then compare j j' else + compare k' k + end) +*) + diff --git a/external/misc/fcommon.mli b/external/misc/fcommon.mli new file mode 100644 --- /dev/null +++ b/external/misc/fcommon.mli @@ -0,0 +1,24 @@ +(* + * Copyright © 2008 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +val scc_rank : string -> (int -> string) -> int list -> (int * int) list -> (int * int) list diff --git a/external/misc/fixMisc.ml b/external/misc/fixMisc.ml new file mode 100644 --- /dev/null +++ b/external/misc/fixMisc.ml @@ -0,0 +1,1353 @@ +(* + * Copyright ? 1990-2007 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +(* $Id: misc.ml,v 1.14 2006/09/26 01:47:01 jhala Exp $ + * + * This file is part of the SIMPLE Project. + *) + +(** + * This module provides some miscellaneous useful helper functions. + *) + +module Ops = struct + + type ('a, 'b) either = Left of 'a | Right of 'b + + let (>|) _ x = x + + let (|>) x f = f x + + let (<|) f x = f x + + let (>>) x f = f x; x + + let (|>>) xo f = match xo with None -> None | Some x -> f x + + let (|>:) xs f = List.map f xs + + let (=+) x n = let v = !x in (x := v + n; v) + + let (+=) x n = x := !x + n; !x + + let (++) = List.rev_append + + let (+++)= fun (x1s, y1s) (x2s, y2s) -> (x1s ++ x2s, y1s ++ y2s) + + let id = fun x -> x + + let un = fun x -> () + + let const x = fun _ -> x + + let (<.>) f g = fun x -> x |> g |> f + + let (<+>) f g = fun x -> x |> f |> g + + let () b f = fun x -> if b then f x else x + + let wwhen b f = fun x -> if b then f x + + let (<*>) f g = fun x -> (f x, g x) + + let (<**>) f g = fun (x, y) -> (f x, g y) + + let (<&&>) f g = fun x -> f x && g x + + let failure fmt = Printf.ksprintf failwith fmt + + let foreach xs f = List.map f xs + + let asserts p fmt = + Printf.ksprintf (fun x -> if not p then failwith x) fmt + +let asserti = asserts + (* +let asserti p fmt = + Printf.ksprintf (fun x -> if not p then (print_string (x^"\n"); ignore(0/0)) else ()) fmt +*) + +let assertf fmt = + Printf.ksprintf failwith fmt + +let halt _ = + assert false + +let fst3 (x,_,_) = x +let snd3 (_,x,_) = x +let thd3 (_,_,x) = x + +let fst4 (x, _, _, _) = x +let snd4 (_, x, _, _) = x +let thd4 (_, _, x, _) = x +let fth4 (_, _, _, x) = x + +let withfst3 (_,y,z) x = (x,y,z) +let withsnd3 (x,_,z) y = (x,y,z) +let withthd3 (x,y,_) z = (x,y,z) + +let print_now s = + print_string s; + flush stdout + +let print_now_error msg = + prerr_string msg; + flush stderr + +let output_now c s = + output_string c s; + flush c + +let some = fun x -> Some x + +end + +open Ops + +let maybe_fold f b xs = + let fo = fun bo x -> match bo with Some b -> f b x | _ -> None in + List.fold_left fo (Some b) xs + +let maybe_map f = function Some x -> Some (f x) | None -> None + +let maybe_iter f = function Some x -> f x | None -> () + +let maybe = function Some x -> x | _ -> assertf "maybe called with None" + +let maybe_apply f xo v = match xo with Some x -> f x v | None -> v + +let maybe_default xo y = match xo with Some x -> x | None -> y + +let maybe_string f = function Some x -> "Some " ^ (f x) | None -> "None" + +let rec maybe_chain x d = function + | f::fs -> (match f x with + | Some y -> y + | None -> maybe_chain x d fs) + | [] -> d + + + + + +let trace s f x = + let _ = print_now <| Printf.sprintf "BEGIN: %s \n" s in + let r = f x in + let _ = print_now <| Printf.sprintf "END: %s \n" s in + r + +(* ORIG +let rec pprint_many_box s f ppf = function + | [] -> () + | x::[] -> Format.fprintf ppf "%a" f x + | x::xs' -> (Format.fprintf ppf "%a%s@\n" f x s; pprint_many_box s f ppf xs') +*) +let rec pprint_many_prefix sep base f ppf = function + | x::xs -> Format.fprintf ppf "(%s %a %a)" + sep f x (pprint_many_prefix sep base f) xs + | [] -> Format.fprintf ppf "%a" f base + + +let rec pprint_many_box brk s f ppf = function + | [] -> () + | [x] -> Format.fprintf ppf "%a" f x + | x::xs' when brk -> Format.fprintf ppf "%a@\n%s" f x s; + pprint_many_box brk s f ppf xs' + | x::xs' -> Format.fprintf ppf "%a@,%s" f x s; + pprint_many_box brk s f ppf xs' + +let pprint_many_box brk l s r f ppf = function + | [] -> Format.fprintf ppf "[]" + | xs -> Format.fprintf ppf "@[%s%a%s@]" l (pprint_many_box brk s f) xs r + +let pprint_many_brackets brk f ppf x = + Format.fprintf ppf "%a" (pprint_many_box brk "[ " "; " "]" f) x + +let rec pprint_many brk s f ppf = function + | [] -> () + | [x] -> Format.fprintf ppf "%a" f x + | x::xs' when brk -> Format.fprintf ppf "%a%s@," f x s; pprint_many brk s f ppf xs' + | x::xs' -> Format.fprintf ppf "%a%s" f x s ; pprint_many brk s f ppf xs' + +let pprint_maybe f ppf = function + | Some x -> Format.fprintf ppf "Some %a" f x + | None -> Format.fprintf ppf "None" + +let pprint_int ppf i = + Format.fprintf ppf "%d" i + +let pprint_int_o = pprint_maybe pprint_int +(* +let pprint_int_o ppf = function + | None -> Format.fprintf ppf "None" + | Some d -> Format.fprintf ppf "Some(%d)" d +*) + +let pprint_str ppf s = + Format.fprintf ppf "%s" s + +let pprint_ints ppf is = + pprint_many_brackets false (fun ppf i -> Format.fprintf ppf "%d" i) ppf is + +let pprint_pretty_ints ppf is = + is |> List.map string_of_int |> String.concat ";" |> Format.fprintf ppf "[%s]" + +let pprint_tuple pp1 pp2 ppf (x1, x2) = + Format.fprintf ppf "(%a, %a)" pp1 x1 pp2 x2 + +let rec subsets n = function + | _ when n <= 0 + -> [[]] + | xs when n > List.length xs-> + [] + | x::xs + -> (List.map (fun ys -> x :: ys) (subsets (n-1) xs)) + ++ (subsets n xs) + | _ -> assertf "Misc.subsets" + +let choose b f g = if b then f else g + +let liftfst2 (f: 'a -> 'a -> 'b) (x: 'a * 'c) (y: 'a * 'c): 'b = + f (fst x) (fst y) + +let curry = fun f x y -> f (x,y) +let uncurry = fun f (x,y) -> f x y +let flip = fun f x y -> f y x + +let maybe_bool = function + | Some _ -> true + | None -> false + +module type EMapType = sig + include Map.S + val extendWith : (key -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t + val extend : 'a t -> 'a t -> 'a t + val filter : (key -> 'a -> bool) -> 'a t -> 'a t + val of_list : (key * 'a) list -> 'a t + val to_list : 'a t -> (key * 'a) list + val length : 'a t -> int + val domain : 'a t -> key list + val range : 'a t -> 'a list + val join : 'a t -> 'b t -> ('a * 'b) t + val adds : key -> 'a list -> 'a list t -> 'a list t + val of_alist : (key * 'a) list -> 'a list t + val finds : key -> 'a list t -> 'a list + val safeFind : key -> 'a t -> string -> 'a + val safeAdd : key -> 'a -> 'a t -> string -> 'a t + val single : key -> 'a -> 'a t + val map_partial : ('a -> 'b option) -> 'a t -> 'b t + val maybe_find : key -> 'a t -> 'a option + val find_default : 'a -> key -> 'a t -> 'a + val frequency : key list -> int t +end + +module type ESetType = sig + include Set.S + val of_list : elt list -> t +end + +module ESet (K: Set.OrderedType) = + struct + include Set.Make(K) + let of_list = List.fold_left (flip add) empty +end + +module type EOrderedType = sig + include Map.OrderedType + val print : Format.formatter -> t -> unit +end + +(* module EMap (K: Map.OrderedType) = *) +module EMap (K: EOrderedType) = + struct + include Map.Make(K) + + let extendWith (f: key -> 'a -> 'a -> 'a) (m1: 'a t) (m2: 'a t) = + fold begin fun k v m -> + let v' = if mem k m then f k v (find k m) else v in + add k v' m + end m2 m1 + + let extend (m1: 'a t) (m2: 'a t) : 'a t = fold add m2 m1 + + (* in 3.12 *) + let filter (f: key -> 'a -> bool) (m: 'a t) : 'a t = + fold (fun x y m -> if f x y then add x y m else m) m empty + + let of_list (kvs : (key * 'a) list) = + List.fold_left (fun m (k, v) -> add k v m) empty kvs + + (* in 3.12 -- bindings *) + let to_list (m : 'a t) : (key * 'a) list = + fold (fun k v acc -> (k,v)::acc) m [] + + (* in 3.12 -- cardinality *) + let length (m : 'a t) : int = + fold (fun _ _ i -> i+1) m 0 + + (* in 3.12 -- singleton *) + let single k v = add k v empty + + let domain m = + fold (fun k _ acc -> k :: acc) m [] + + let range (m : 'a t) : 'a list = + fold (fun _ v acc -> v :: acc) m [] + + let join (m1 : 'a t) (m2 : 'b t) : ('a * 'b) t = + mapi begin fun k v1 -> + let _ = asserts (mem k m2) "EMap.join" in + (v1, find k m2) + end m1 + + let maybe_find k m = + try Some (find k m) with Not_found -> None + + let find_default d k m = + maybe_default (maybe_find k m) d + + (* let finds k m = try find k m with Not_found -> [] *) + let finds k m = find_default [] k m + + let adds (k: key) (vs: 'a list) (m : ('a list) t) : 'a list t = + add k (vs ++ find_default [] k m) m + + let of_alist (kvs : (key * 'a) list) = + List.fold_left (fun m (k, v) -> adds k [v] m) empty kvs + + let frequency (ks : key list) : int t = + List.fold_left (fun m k -> + add k (1 + (find_default 0 k m)) m + ) empty ks + + let safeFind k m msg = + try find k m with Not_found -> + let err = Format.fprintf Format.str_formatter + "ERROR: safeFind (%s): %a" msg K.print k; + Format.flush_str_formatter () + in failwith err + + let safeAdd k v m msg = + if mem k m then + let err = Format.fprintf Format.str_formatter + "ERROR: safeAdd (%s): %a" msg K.print k; + Format.flush_str_formatter () + in failwith err + else add k v m + + let map_partial f m = + fold (fun x yo m -> match yo with Some y -> add x y m | _ -> m) (map f m) empty + end + +module type KeyValType = + sig + type t + val compare : t -> t -> int + val print : Format.formatter -> t -> unit + + type v + val default : v + end + +module MapWithDefault (K: KeyValType) = + struct + include EMap(K) + let find (i: K.t) (m: K.v t): K.v = + try find i m with Not_found -> K.default + end + +module IntMap = + EMap + (struct + type t = int + let compare i1 i2 = compare i1 i2 + let print = pprint_int + end) + +module IntSet = + ESet + (struct + type t = int + let compare i1 i2 = + compare i1 i2 + end) + +module IntIntMap = + EMap + (struct + type t = int * int + let compare i1 i2 = compare i1 i2 + let print ppf (i1, i2) = Format.fprintf ppf "(%d, %d)" i1 i2 + end) + +module StringMap = + EMap + (struct + type t = string + let compare i1 i2 = compare i1 i2 + let print ppf s = Format.fprintf ppf "%s" s + end) + +module StringSet = + ESet + (struct + type t = string + let compare i1 i2 = compare i1 i2 + end) + +(* +let sm_join sm1 sm2 = + StringMap.mapi (fun k v1 -> + let v2 = asserts (StringMap.mem k sm2) "sm_join"; StringMap.find k sm2 in + (v1, v2) + ) sm1 + +let sm_extend sm1 sm2 = + StringMap.fold StringMap.add sm2 sm1 + +let sm_filter f sm = + StringMap.fold begin fun x y sm -> + if f x y then StringMap.add x y sm else sm + end sm StringMap.empty + +let sm_of_list kvs = + List.fold_left (fun sm (k,v) -> StringMap.add k v sm) StringMap.empty kvs + +let sm_to_list sm = + StringMap.fold (fun k v acc -> (k,v)::acc) sm [] + +let sm_to_range sm = + sm |> sm_to_list |> List.map snd +*) + +let sm_print_keys name sm = + sm |> StringMap.to_list + |> List.map fst + |> String.concat ", " + |> Printf.printf "%s : %s \n" name + +let foldn f n b = + let rec foo acc i = + if i >= n then acc else foo (f acc i) (i+1) + in foo b 0 + +let rec range i j = + if i >= j then [] else i::(range (i+1) j) + +let dump s = + print_string s; flush stdout + +let mapn f n = + foldn (fun acc i -> (f i) :: acc) n [] + |> List.rev + +let chop_last = function + | [] -> failure "ERROR: Misc.chop_last" + | xs -> xs |> List.rev |> List.tl |> List.rev + +let list_snoc xs = + match List.rev xs with + | [] -> assertf "list_snoc with empty list!" + | h::t -> h, List.rev t + +let negfilter f xs = + List.fold_left (fun acc x -> if f x then acc else x::acc) [] xs + |> List.rev + +let get_option d = function + | Some x -> x + | None -> d + +let list_somes xs = + xs |> List.fold_left begin fun acc -> function + | Some x -> x :: acc + | None -> acc + end [] + |> List.rev + +(* let map_partial f = list_somes <.> List.map f *) + +let map_partial f xs = + List.rev + (List.fold_left + (fun acc x -> + match f x with + | None -> acc + | Some z -> (z::acc)) [] xs) + + +let fold_left_partial f b xs = + List.fold_left begin fun b xo -> + match xo with + | Some x -> f b x + | None -> b + end b xs + +let list_reduce msg f = function + | [] -> assertf "ERROR: list_reduce with empty list: %s" msg + | x::xs -> List.fold_left f x xs + +let nonnull = function + | [] -> false + | _ -> true + +(* +let list_is_empty = function + | [] -> true + | _::_ -> false +*) + +let list_max x xs = + List.fold_left max x xs + +let list_min x xs = + List.fold_left min x xs + +let list_max_with msg f = function + | [] -> assertf "ERROR: list_max_with with empty list: %s" msg + | x::xs -> List.fold_left (fun acc x -> if f x > f acc then x else acc) x xs + +let rec take_max n = function + | x :: xs when n > 0 -> x :: take_max (n - 1) xs + | _ -> [] + +let rec drop n = function + | x :: xs when n > 0 -> drop (n - 1) xs + | [] when n > 0 -> assertf "ERROR: dropped too many" + | xs -> xs + +let getf a i fmt = + try a.(i) with ex -> assertf fmt + +let do_catchu f x g = + try f x with ex -> (g ex; raise ex) + +let do_catchf s f x = + try f x with ex -> + assertf "%s hits exn: %s \n" s (Printexc.to_string ex) + +let do_catch s f x = + try f x with ex -> + (Printf.printf "%s hits exn: %s \n" s (Printexc.to_string ex); raise ex) + +let do_catch_ret s f x y = + try f x with ex -> + (Printf.printf "%s hits exn: %s \n" s (Printexc.to_string ex); y) + +let do_memo memo f args key = + try Hashtbl.find memo key with Not_found -> + let rv = f args in + let _ = Hashtbl.replace memo key rv in + rv + +let do_bimemo fmemo rmemo f args key = + try Hashtbl.find fmemo key with Not_found -> + let rv = f args in + let _ = Hashtbl.replace fmemo key rv in + let _ = Hashtbl.replace rmemo rv key in + rv + +let rec exists_maybe f = function + | [] -> None + | x::xs -> (match f x with None -> exists_maybe f xs | z -> z) + +let map_pair = fun f (x1, x2) -> (f x1, f x2) +let map_triple = fun f (x1, x2, x3) -> (f x1, f x2, f x3) +let app_fst = fun f (a, b) -> (f a, b) +let app_snd = fun f (a, b) -> (a, f b) +let app_fst3 = fun f (a, b, c) -> (f a, b, c) + +let app_snd3 = fun f (a, b, c) -> (a, f b, c) + +let app_thd3 = fun f (a, b, c) -> (a, b, f c) +let pad_snd = fun f x -> (x, f x) +let pad_fst = fun f y -> (f y, y) +let tmap2 = fun (f, g) x -> (f x, g x) +let tmap3 = fun (f, g, h) x -> (f x, g x, h x) +let iter_fst = fun f (a, b) -> f a +let iter_snd = fun f (a, b) -> f b + +let split3 lst = + List.fold_right (fun (x, y, z) (xs, ys, zs) -> (x :: xs, y :: ys, z :: zs)) lst ([], [], []) + +let split4 lst = + List.fold_right (fun (w, x, y, z) (ws, xs, ys, zs) -> (w :: ws, x :: xs, y :: ys, z :: zs)) lst ([], [], [], []) + +let twrap s f x = + let _ = Printf.printf "calling %s \n" s in + let rv = f x in + let _ = Printf.printf "returned from %s \n" s in + rv + +let mapfold_rev f b xs = + List.fold_left begin fun (acc, ys) x -> + let (acc', y) = f acc x in + (acc', y::ys) + end (b, []) xs + +let mapfold f b xs = + mapfold_rev f b xs + |> app_snd List.rev + +let rootsBy leq xs = + let notDomBy x = not <.> (leq x) in + let rec loop acc = function + | [] -> + acc + | (x::xs) -> + let acc', xs' = map_pair (List.filter (notDomBy x)) (acc, xs) in + loop (x::acc') xs' + in loop [] xs + +let cov_filter cov f xs = + let rec loop acc = function + | [] -> + acc + | (x::xs) when f x -> + let covs, uncovs = List.partition (cov x) xs in + loop ((x, covs) :: acc) uncovs + | (_::xs) -> + loop acc xs + in loop [] xs + +let filter f xs = + List.fold_left (fun xs' x -> if f x then x::xs' else xs') [] xs + |> List.rev + +let iter f xs = + List.fold_left (fun () x -> f x) () xs + +let map2 f xs ys = + let _ = asserti (List.length xs = List.length ys) "Misc.map2" in + List.map2 f xs ys + +let map f xs = + List.rev_map f xs |> List.rev + +let flatten xss = + xss + |> List.fold_left (fun acc xs -> xs ++ acc) [] + |> List.rev + +let flatsingles xss = + xss |> List.fold_left (fun acc -> function [x] -> x::acc | _ -> assertf "flatsingles") [] + |> List.rev + +let splitflatten xsyss = + let xss, yss = List.split xsyss in + (flatten xss, flatten yss) + +let splitflatten3 xsyszss = + let xss, yss, zss = split3 xsyszss in + (flatten xss, flatten yss, flatten zss) + +let flap f xs = + xs |> List.rev_map f |> flatten |> List.rev + +let flap_pair f = splitflatten <.> map f + +let tr_rev_flatten xs = + List.fold_left (fun x xs -> x ++ xs) [] xs + +let tr_rev_flap f xs = + List.fold_left (fun xs x -> (f x) ++ xs) [] xs + +let rec fast_unflat ys = function + | x :: xs -> fast_unflat ([x] :: ys) xs + | [] -> ys + +let dup x = (x, x) + + +let rec rev_perms s = function + | [] -> s + | e :: es -> rev_perms + (tr_rev_flap (fun e -> List.rev_map (fun s -> e :: s) s) e) es + +let product = function + | e :: es -> rev_perms (fast_unflat [] e) es + | es -> es + +let pairs xs = + let rec pairs_aux ps = function + | [] -> ps + | x :: xs -> pairs_aux (List.fold_left (fun ps y -> (x, y) :: ps) ps xs) xs + in pairs_aux [] xs + +let cross_product xs ys = + map begin fun x -> + map begin fun y -> + (x,y) + end ys + end xs + |> flatten + +let rec cross_flatten = function + | [] -> + [[]] + | xs::xss -> + map begin fun x -> + map begin fun ys -> + (x::ys) + end (cross_flatten xss) + end xs + |> flatten + + +let append_pref p s = + (p ^ "." ^ s) + + +let fsort f xs = + let cmp = fun (k1,_) (k2,_) -> compare k1 k2 in + xs |> map (fun x -> ((f x), x)) + |> List.sort cmp + |> map snd + +let sort_and_compact ls = + let rec _sorted_compact l = + match l with + h1::h2::tl -> + let rest = _sorted_compact (h2::tl) in + if h1 = h2 then rest else h1::rest + | tl -> tl + in + _sorted_compact (List.sort compare ls) + +let sort_and_compact xs = + List.sort compare xs + |> List.fold_left + (fun ys x -> match ys with + | y::_ when x=y -> ys + | _::_ -> x::ys + | [] -> [x]) + [] + |> List.rev + +let hashtbl_to_list t = + Hashtbl.fold (fun x y l -> (x,y)::l) t [] + +let hashtbl_keys t = + Hashtbl.fold (fun x y l -> x::l) t [] + |> sort_and_compact + +let hashtbl_invert t = + let t' = Hashtbl.create 17 in + hashtbl_to_list t + |> List.iter (fun (x,y) -> Hashtbl.replace t' y x) + |> fun _ -> t' + + +let distinct xs = + List.length xs = List.length (sort_and_compact xs) + +(** repeats f: unit - > unit i times *) +let rec repeat_fn f i = + if i = 0 then () + else (f (); repeat_fn f (i-1)) + +(* chop s chopper returns ([x;y;z...]) if s = x.chopper.y.chopper ...*) +let chop s chopper = Str.split (Str.regexp chopper) s + +(* like chop only the chop is by chop+ *) +let chop_star chopper s = + Str.split (Str.regexp (Printf.sprintf "[%s+]" chopper)) s + +let bounded_chop s chopper i = Str.bounded_split (Str.regexp chopper) s i + +let is_prefix p s = + let (ls, lp) = (String.length s, String.length p) in + if ls < lp + then false + else + (String.sub s 0 lp) = p + +let is_substring s subs = + let reg = Str.regexp subs in + try ignore(Str.search_forward reg s 0); true + with Not_found -> false + +let replace_substring src dst s = + Str.global_replace (Str.regexp src) dst s + +let is_suffix suffix s = + let k = String.length suffix + and n = String.length s in + (n-k >= 0) && Str.string_match (Str.regexp suffix) s (n-k) + +let iteri f xs = + List.fold_left (fun i x -> f i x; i+1) 0 xs + |> ignore + +let numbered_list xs = + xs |> List.fold_left (fun (i, acc) x -> (i+1, (i,x)::acc)) (0,[]) + |> snd + |> List.rev + +exception FalseException + +let sm_protected_add fail k v sm = + if not (StringMap.mem k sm) then StringMap.add k v sm else + if not fail then sm else + assertf "protected_add: duplicate binding for %s \n" k + +let hashtbl_to_list_all t = + hashtbl_keys t |> map (Hashtbl.find_all t) + +let clone x n = + let rec f n xs = if n <= 0 then xs else f (n-1) (x::xs) in + f n [] + +let single x = [x] + +let distinct xs = + List.length (sort_and_compact xs) = List.length xs + +let trunc i j = + let (ai,aj) = (abs i, abs j) in + if aj <= ai then j else ai*j/aj + +let map_to_string f xs = + String.concat "," (List.map f xs) + +let suffix_of_string = fun s i -> String.sub s i (String.length s - 1) + +(* [count_map xs] = fun x -> number of times x appears in xs if non-zero *) +let count_map rs = + List.fold_left begin fun m r -> + let c = try IntMap.find r m with Not_found -> 0 in + IntMap.add r (c+1) m + end IntMap.empty rs + +let o2s f = function + | Some x -> "Some "^ (f x) + | None -> "None" + +let fixpoint f x = + let rec acf b x = + let x', b' = f x in + if b' then acf true x' else (x', b) in + acf false x + + +let fsprintf f p = + Format.fprintf Format.str_formatter "@[%a@]" f p; + Format.flush_str_formatter () + +let rec same_length l1 l2 = match l1, l2 with + | [], [] -> true + | _ :: xs, _ :: ys -> same_length xs ys + | _ -> false + +let ex_one s = function + | [x] -> x + | _ :: _ -> failwith s + | _ -> failwith (s ^ ". empty") + +let only_one s = function + x :: [] -> Some x + | _ :: _ -> failwith s + | [] -> None + +let maybe_one = function + | [x] -> Some x + | _ -> None + + +let int_of_bool b = if b then 1 else 0 + +(*****************************************************************) +(******************** Mem Management *****************************) +(*****************************************************************) + +open Gc +(* open Format *) + +let pprint_gc s = + (*printf "@[Gc@ Stats:@]@."; + printf "@[minor@ words:@ %f@]@." s.minor_words; + printf "@[promoted@ words:@ %f@]@." s.promoted_words; + printf "@[major@ words:@ %f@]@." s.major_words;*) + (*printf "@[total allocated:@ %fMB@]@." (floor ((s.major_words +. s.minor_words -. s.promoted_words) *. (4.0) /. (1024.0 *. 1024.0)));*) + + Format.printf "@[total allocated:@ %fMB@]@." (floor ((allocated_bytes ()) /. (1024.0 *. 1024.0))); + Format.printf "@[minor@ collections:@ %i@]@." s.minor_collections; + Format.printf "@[major@ collections:@ %i@]@." s.major_collections; + Format.printf "@[heap@ size:@ %iMB@]@." (s.heap_words * 4 / (1024 * 1024)); + (*printf "@[heap@ chunks:@ %i@]@." s.heap_chunks; + (*printf "@[live@ words:@ %i@]@." s.live_words; + printf "@[live@ blocks:@ %i@]@." s.live_blocks; + printf "@[free@ words:@ %i@]@." s.free_words; + printf "@[free@ blocks:@ %i@]@." s.free_blocks; + printf "@[largest@ free:@ %i@]@." s.largest_free; + printf "@[fragments:@ %i@]@." s.fragments;*)*) + Format.printf "@[compactions:@ %i@]@." s.compactions; + (*printf "@[top@ heap@ words:@ %i@]@." s.top_heap_words*) () + +let dump_gc s = + Format.printf "@[%s@]@." s; + pprint_gc (Gc.quick_stat ()) + + +let append_to_file f s = + let oc = Unix.openfile f [Unix.O_WRONLY; Unix.O_APPEND; Unix.O_CREAT] 420 in + ignore (Unix.write oc s 0 ((String.length s)-1) ); + Unix.close oc + +(* +let with_out_file file f = + let oc = open_out file in + f oc; + close_out oc +*) + +let display_tick = fun () -> print_now "." + +let display_tick = + let icona = [| "|"; "/" ; "-"; "\\" |] in + let n = ref 0 in + let pos = ref 0 in + fun () -> + let k = !pos in + let _ = pos := (k + 1) mod 4 in + let _ = incr n in + let suf = if (!n mod 76) = 0 + then "\n" + else icona.(k) in + let _ = print_now ("\b."^suf) in + () + + + +let with_out_file file f = file |> open_out >> f |> close_out + +let write_to_file f s = + with_out_file f (fun oc -> output_string oc s) + +let with_out_formatter file f = + with_out_file file (fun oc -> f (Format.formatter_of_out_channel oc)) + +let get_unique = + let cnt = ref 0 in + (fun () -> let rv = !cnt in incr cnt; rv) + +let lines_of_file filename = + let lines = ref [] in + let chan = open_in filename in + try + while true; do + lines := input_line chan :: !lines + done; [] + with End_of_file -> + close_in chan; + List.rev !lines + +let map_lines_of_file infile outfile f = + let ic = open_in infile in + let oc = open_out outfile in + try + while true; do + ic |> input_line |> f |> output_string oc + done; + with End_of_file -> + (close_in ic; close_out oc) + +let maybe_cons m xs = match m with + | None -> xs + | Some x -> x :: xs + +let maybe_list xs = + List.fold_right maybe_cons xs [] + +let rec list_first_maybe f = function + | x::xs -> begin match f x with + | Some y -> Some y + | _ -> list_first_maybe f xs + end + | [] -> None + +let list_find_maybe f xs = + try some <| List.find f xs with Not_found -> None + +let list_assoc_maybe k kvs = + try Some (List.assoc k kvs) with Not_found -> None + +let list_assoc_default d kvs k = + try List.assoc k kvs with Not_found -> d + +let list_assoc_flip xs = + let r (x, y) = (y, x) in + List.map r xs + +let fold_lefti f b xs = + List.fold_left (fun (i,b) x -> ((i+1), f i b x)) (0,b) xs + +let mapi f xs = + xs |> fold_lefti (fun i acc x -> (f i x) :: acc) [] + |> snd |> List.rev + +let index_from n xs = + let is = range n (n + List.length xs) in + List.combine is xs + +let fold_left_flip f b xs = + List.fold_left (flip f) b xs + +let fold_left_swap f xs b = + List.fold_left f b xs + +let rec map3 f xs ys zs = match (xs, ys, zs) with + | ([], [], []) -> [] + | (x :: xs, y :: ys, z :: zs) -> f x y z :: map3 f xs ys zs + | _ -> assert false + +let rec fold_right3 f xs ys zs acc = match xs, ys, zs with + | x :: xs, y :: ys, z :: zs -> f x y z (fold_right3 f xs ys zs acc) + | [], [], [] -> acc + | _ -> assert false + +let rec fold_left3 f acc xs ys zs = match xs, ys, zs with + | x :: xs, y :: ys, z :: zs -> fold_left3 f (f acc x y z) xs ys zs + | [], [], [] -> acc + | _ -> assert false + +let zip_partition xs bs = + let (xbs, xbs') = List.partition snd (List.combine xs bs) in + (List.map fst xbs, List.map fst xbs') + +let rec map4 f ws xs ys zs = match ws, xs, ys, zs with + | [], [], [], [] -> [] + | w :: ws, x :: xs, y :: ys, z :: zs -> f w x y z :: map4 f ws xs ys zs + | _ -> asserti false "map4"; assert false + + +let rec perms es = + match es with + | s :: [] -> + List.map (fun c -> [c]) s + | s :: es -> + flap (fun c -> List.map (fun d -> c :: d) (perms es)) s + | [] -> + [] + +let flap2 f xs ys = + List.flatten (List.map2 f xs ys) + +let flap3 f xs ys zs = + List.flatten (map3 f xs ys zs) + +let combine msg xs ys = + let _ = asserts (List.length xs = List.length ys) "%s" msg in + List.combine xs ys + +let combine3 xs ys zs = + map3 (fun x y z -> (x, y, z)) xs ys zs + +let combine4 ws xs ys zs = + map4 (fun w x y z -> (w, x, y, z)) ws xs ys zs + +let tr_partition f xs = + List.fold_left begin fun (xs,ys) z -> + if f z + then (z::xs, ys) + else (xs, z::ys) + end ([],[]) xs + +let either_partition f xs = + List.fold_left begin fun (xs, ys) z -> + match f z with + | Left x -> (x::xs, ys) + | Right y -> (xs, y::ys) + end ([], []) xs + +(* these do odd things with order for performance + * it is possible that fast is a misnomer *) +let fast_flatten xs = + List.fold_left (++) [] xs + +let fast_append v v' = + let (v, v') = if List.length v > List.length v' then (v', v) else (v, v') in + List.rev_append v v' + +let fast_flap f xs = + List.fold_left (fun xs x -> List.rev_append (f x) xs) [] xs + +let rec fast_unflat ys = function + | x :: xs -> fast_unflat ([x] :: ys) xs + | [] -> ys + +let rec rev_perms s = function + | [] -> s + | e :: es -> rev_perms + (fast_flap (fun e -> List.rev_map (fun s -> e :: s) s) e) es + +let rev_perms = function + | e :: es -> rev_perms (fast_unflat [] e) es + | es -> es + +let tflap2 (e1, e2) f = + List.fold_left (fun bs b -> List.fold_left (fun aas a -> f a b :: aas) bs e1) [] e2 + +let tflap3 (e1, e2, e3) f = + List.fold_left begin fun cs c -> + List.fold_left begin fun bs b -> + List.fold_left begin fun aas a -> + f a b c :: aas + end bs e1 + end cs e2 + end[] e3 + +let rec expand f xs ys = + match xs with + | [] -> ys + | x::xs -> let (xs', ys') = f x in + expand f (xs' ++ xs) (ys' ++ ys) + +let rec get_first f = function + | x::xs when f x -> Some x + | _::xs -> get_first f xs + | [] -> None + +let join f xs ys = + let rec fuse acc xs ys = + match xs, ys with + | [],_ | _, [] -> List.rev acc + | ((kx, _)::xs', (ky,_)::_ ) when kx < ky -> fuse acc xs' ys + | ((kx, _)::_ , (ky,_)::ys') when kx > ky -> fuse acc xs ys' + | ((kx, x)::xs', (ky,y)::ys') (* kx = ky *) -> fuse ((x,y)::acc) xs' ys' in + let xs' = List.map (fun x -> (f x, x)) xs |> List.sort compare in + let ys' = List.map (fun y -> (f y, y)) ys |> List.sort compare in + fuse [] xs' ys' + +let hashtbl_find_default d t x = + try Hashtbl.find t x with Not_found -> d + +let frequency (xs : 'a list) : ('a * int) list = + let t = Hashtbl.create 17 in + List.iter begin fun x -> + let n = hashtbl_find_default 0 t x in + Hashtbl.replace t x (n + 1) + end xs; + hashtbl_to_list t + +let kgroupby (f: 'a -> 'b) (xs: 'a list): ('b * 'a list) list = + let t = Hashtbl.create 17 in + let lookup x = try Hashtbl.find t x with Not_found -> [] in + (* build table *) + List.iter begin fun x -> + Hashtbl.replace t (f x) (x :: lookup (f x)) + end xs; + (* build cluster *) + Hashtbl.fold (fun k xs xxs -> (k, xs) :: xxs) t [] + + + +let groupby (f: 'a -> 'b) (xs: 'a list): 'a list list = + kgroupby f xs |> List.map (snd <+> List.rev) + +let full_join f xs ys = + (xs, ys) + |> map_pair (kgroupby f) + |> uncurry (join fst) + |> flap (map_pair snd <+> uncurry cross_product) + +let exists_pair (f: 'a -> 'a -> bool) (xs: 'a list): bool = + fst (List.fold_left (fun (b, ys) x -> (b || List.exists (f x) ys, x :: ys)) (false, []) xs) + +let rec find_pair (f: 'a -> 'a -> bool): 'a list -> 'a * 'a = function + | [] -> raise Not_found + | x::xs -> try (x, List.find (f x) xs) with Not_found -> find_pair f xs + +let rec is_unique = function + | [] -> true + | x :: xs -> if List.mem x xs then false else is_unique xs + +let map_opt f = function + | Some o -> Some (f o) + | None -> None + +let resl_opt f = function + | Some o -> f o + | None -> [] + +let resi_opt f = function + | Some o -> f o + | None -> () + +let opt_iter f l = + List.iter (resi_opt f) l + +let array_findi p arr = + let rec look i = + if i < 0 then raise Not_found else + if p arr.(i) then i else look i - 1 + in look (Array.length arr - 1) + +let array_to_index_list a = + Array.fold_left (fun (i, rv) v -> (i+1,(i,v)::rv)) (0,[]) a + |> snd + |> List.rev + + +let hashtbl_of_list xys = + let t = Hashtbl.create 37 in + let _ = List.iter (fun (x,y) -> Hashtbl.add t x y) xys in + t + +let hashtbl_of_list_with kf xs = + xs |>: pad_fst kf |> hashtbl_of_list + +let array_flapi f a = + Array.fold_left (fun (i, acc) x -> (i+1, (f i x) :: acc)) (0,[]) a + |> snd + |> List.rev + |> flatten + +let array_fold_lefti f acc a = + Array.fold_left (fun (i, acc) x -> (i + 1, f i acc x)) (0, acc) a |> snd + +let array_map2 f xa ya = + Array.mapi (fun i x -> f x (ya.(i))) xa + +let array_rev_iteri f a = + for i = Array.length a - 1 downto 0 do + f i a.(i) + done + +exception NotForall + +let array_forall f a = + try + Array.iter (fun e -> if f e then () else raise NotForall) a; true + with NotForall -> + false + +let array_combine a1 a2 = + asserts (Array.length a1 = Array.length a2) "array_combine"; + Array.init (Array.length a1) (fun i -> (a1.(i), a2.(i))) + + +let compose f g a = f (g a) + + +let rec gcd (a: int) (b: int): int = + if b = 0 then a else gcd b (a mod b) + +let lcm (a: int) (b: int): int = + if a = 0 then a else (abs (a * b)) / (gcd a b) + +let mk_int_factory () = + let id = ref (-1) in + ((fun () -> incr id; !id), (fun () -> id := -1)) + +let mk_char_factory () = + let (fresh_int, reset_fresh_int) = mk_int_factory () in + ((fun () -> Char.chr (fresh_int () + Char.code 'a')), reset_fresh_int) + +let mk_string_factory s = + let (fresh_int, reset_fresh_int) = mk_int_factory () in + ((fun () -> s^(string_of_int (fresh_int ()))), reset_fresh_int) + +let swap (x,y) = (y,x) + +(* ('a * (int * 'b) list) list -> (int * ('a * 'b) list) list *) +let transpose x_iys_s = + let t = Hashtbl.create 17 in + List.iter begin fun (x, iys) -> + List.iter begin fun (i, y) -> + Hashtbl.add t i (x,y) + end iys + end x_iys_s; + hashtbl_keys t |> List.map (fun i -> (i, Hashtbl.find_all t i)) + +let basename_no_extension fname = + fname |> Filename.basename |> Filename.chop_extension + +let absolute_name name = + if not (Filename.is_relative name) then name else + let b = Filename.basename name in + let d = Filename.dirname name in + let dir = Sys.getcwd () in + let _ = Sys.chdir (Filename.concat dir d) in + let dir' = Sys.getcwd () in + let rv = Filename.concat dir' b in + let _ = Sys.chdir dir in + rv + +let cardinality = fun xs -> xs |> sort_and_compact |> List.length +let disjoint = fun xs ys -> cardinality xs + cardinality ys = cardinality (xs ++ ys) + +let bracket (l : unit -> unit) (r : unit -> unit) (f : unit -> 'a) : 'a = + try l () |> f >> (fun _ -> r ()) + with ex -> assertf "bracket hits exn: %s \n" (Printexc.to_string ex) + +(* +let with_ref_at x v f = + let oldv = !x in + bracket (fun _ -> x := v) (fun _ -> x := oldv) f +*) + +let with_ref_at x v f = + let oldv = !x in + let _ = x := v in + let res = f () in + let _ = x := oldv in + res + + + +let rec isPrefix = function + | ([], _) -> true + | (x::xs, y::ys) when x = y -> isPrefix (xs, ys) + | _ -> false + +let find_first_true f lo hi = + let rec go lo hi = + let mid = lo + ((hi - lo) / 2) in + match () with + | _ when lo >= hi -> None + | _ when lo = hi - 1 -> Some hi + | _ when f mid -> go lo mid + | _ -> go mid hi + in if f lo then Some lo + else if not (f hi) then None + else go lo hi + +let safeHead msg = function + | [x] -> x + | _ -> failwith ("ERROR: safeHead" ^ msg) + +let safeApply pp f x = match f x with + | Some y -> y + | None -> failwith ("ERROR: safeApply " ^ (pp x)) + +let stringIsUpper = function + | "" -> false + | s -> let c = s.[0] in c = Char.uppercase c + +let stringIsLower = function + | "" -> false + | s -> let c = s.[0] in c = Char.lowercase c + + + diff --git a/external/misc/heaps.ml b/external/misc/heaps.ml new file mode 100644 --- /dev/null +++ b/external/misc/heaps.ml @@ -0,0 +1,223 @@ +(**************************************************************************) +(* *) +(* Copyright (C) Jean-Christophe Filliatre *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(*s Heaps *) + +module type Ordered = sig + type t + val compare : t -> t -> int +end + +exception EmptyHeap + +(*s Imperative implementation *) + +module Imperative(X : Ordered) = struct + + (* The heap is encoded in the array [data], where elements are stored + from [0] to [size - 1]. From an element stored at [i], the left + (resp. right) subtree, if any, is rooted at [2*i+1] (resp. [2*i+2]). *) + + type t = { mutable size : int; mutable data : X.t array } + + (* When [create n] is called, we cannot allocate the array, since there is + no known value of type [X.t]; we'll wait for the first addition to + do it, and we remember this situation with a negative size. *) + + let create n = + if n <= 0 then invalid_arg "create"; + { size = -n; data = [||] } + + let is_empty h = h.size <= 0 + + (* [resize] doubles the size of [data] *) + + let resize h = + let n = h.size in + assert (n > 0); + let n' = 2 * n in + let d = h.data in + let d' = Array.create n' d.(0) in + Array.blit d 0 d' 0 n; + h.data <- d' + + let add h x = + (* first addition: we allocate the array *) + if h.size < 0 then begin + h.data <- Array.create (- h.size) x; h.size <- 0 + end; + let n = h.size in + (* resizing if needed *) + if n == Array.length h.data then resize h; + let d = h.data in + (* moving [x] up in the heap *) + let rec moveup i = + let fi = (i - 1) / 2 in + if i > 0 && X.compare d.(fi) x < 0 then begin + d.(i) <- d.(fi); + moveup fi + end else + d.(i) <- x + in + moveup n; + h.size <- n + 1 + + let maximum h = + if h.size <= 0 then raise EmptyHeap; + h.data.(0) + + let remove h = + if h.size <= 0 then raise EmptyHeap; + let n = h.size - 1 in + h.size <- n; + let d = h.data in + let x = d.(n) in + (* moving [x] down in the heap *) + let rec movedown i = + let j = 2 * i + 1 in + if j < n then + let j = + let j' = j + 1 in + if j' < n && X.compare d.(j') d.(j) > 0 then j' else j + in + if X.compare d.(j) x > 0 then begin + d.(i) <- d.(j); + movedown j + end else + d.(i) <- x + else + d.(i) <- x + in + movedown 0 + + let pop_maximum h = let m = maximum h in remove h; m + + let iter f h = + let d = h.data in + for i = 0 to h.size - 1 do f d.(i) done + + let fold f h x0 = + let n = h.size in + let d = h.data in + let rec foldrec x i = + if i >= n then x else foldrec (f d.(i) x) (succ i) + in + foldrec x0 0 + +end + + +(*s Functional implementation *) + +module type FunctionalSig = sig + type elt + type t + val empty : t + val add : elt -> t -> t + val maximum : t -> elt + val remove : t -> t + val iter : (elt -> unit) -> t -> unit + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a +end + +module Functional(X : Ordered) = struct + + (* Heaps are encoded as complete binary trees, i.e., binary trees + which are full expect, may be, on the bottom level. + These trees also enjoy the heap property, namely the value of any node + is greater or equal than those of its left and right subtrees. + + The representation invariant is the following: the number of nodes in + the left subtree is equal to the number of nodes in the right + subtree, or exceeds it by exactly once. In the first case, we use + the constructor [Same] and in the second the constructor [Diff]. + Then it can be proved that [2^(h-1) <= n <= 2^h] when [n] is the + number of elements and [h] the height of the tree. *) + + type elt = X.t + + type t = + | Empty + | Same of t * X.t * t (* same number of elements on both sides *) + | Diff of t * X.t * t (* left has [n+1] nodes and right has [n] *) + + let empty = Empty + + let rec add x = function + | Empty -> + Same (Empty, x, Empty) + (* insertion to the left *) + | Same (l, y, r) -> + if X.compare x y > 0 then Diff (add y l, x, r) else Diff (add x l, y,r) + (* insertion to the right *) + | Diff (l, y, r) -> + if X.compare x y > 0 then Same (l, x, add y r) else Same (l,y, add x r) + + let maximum = function + | Empty -> raise EmptyHeap + | Same (_, x, _) | Diff (_, x, _) -> x + + (* extracts one element on the bottom level of the tree, while + maintaining the representation invariant *) + let rec extract_last = function + | Empty -> raise EmptyHeap + | Same (Empty, x, Empty) -> x, Empty + | Same (l, x, r) -> let y,r' = extract_last r in y, Diff (l, x, r') + | Diff (l, x, r) -> let y,l' = extract_last l in y, Same (l', x, r) + + (* removes the topmost element of the tree and inserts a new element [x] *) + let rec descent x = function + | Empty -> + assert false + | Same (Empty, _, Empty) -> + Same (Empty, x, Empty) + | Diff (Same (_, z, _) as l, _, Empty) -> + if X.compare x z > 0 then Diff (l, x, Empty) + else Diff (Same (Empty, x, Empty), z, Empty) + | Same (l, _, r) -> + let ml = maximum l in + let mr = maximum r in + if X.compare x ml > 0 && X.compare x mr > 0 then + Same (l, x, r) + else + if X.compare ml mr > 0 then + Same (descent x l, ml, r) + else + Same (l, mr, descent x r) + | Diff (l, _, r) -> + let ml = maximum l in + let mr = maximum r in + if X.compare x ml > 0 && X.compare x mr > 0 then + Diff (l, x, r) + else + if X.compare ml mr > 0 then + Diff (descent x l, ml, r) + else + Diff (l, mr, descent x r) + + let remove = function + | Empty -> raise EmptyHeap + | Same (Empty, x, Empty) -> Empty + | h -> let y,h' = extract_last h in descent y h' + + let rec iter f = function + | Empty -> () + | Same (l, x, r) | Diff (l, x, r) -> iter f l; f x; iter f r + + let rec fold f h x0 = match h with + | Empty -> x0 + | Same (l, x, r) | Diff (l, x, r) -> fold f l (fold f r (f x x0)) + +end diff --git a/external/misc/heaps.mli b/external/misc/heaps.mli new file mode 100644 --- /dev/null +++ b/external/misc/heaps.mli @@ -0,0 +1,98 @@ +(**************************************************************************) +(* *) +(* Copyright (C) Jean-Christophe Filliatre *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* Heaps *) + +module type Ordered = sig + type t + val compare : t -> t -> int +end + +exception EmptyHeap + +(*S Imperative implementation. *) + +module Imperative(X: Ordered) : sig + + (* Type of imperative heaps. + (In the following [n] refers to the number of elements in the heap) *) + + type t + + (* [create c] creates a new heap, with initial capacity of [c] *) + val create : int -> t + + (* [is_empty h] checks the emptiness of [h] *) + val is_empty : t -> bool + + (* [add x h] adds a new element [x] in heap [h]; size of [h] is doubled + when maximum capacity is reached; complexity $O(log(n))$ *) + val add : t -> X.t -> unit + + (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] + when [h] is empty; complexity $O(1)$ *) + val maximum : t -> X.t + + (* [remove h] removes the maximum element of [h]; raises [EmptyHeap] + when [h] is empty; complexity $O(log(n))$ *) + val remove : t -> unit + + (* [pop_maximum h] removes the maximum element of [h] and returns it; + raises [EmptyHeap] when [h] is empty; complexity $O(log(n))$ *) + val pop_maximum : t -> X.t + + (* usual iterators and combinators; elements are presented in + arbitrary order *) + val iter : (X.t -> unit) -> t -> unit + + val fold : (X.t -> 'a -> 'a) -> t -> 'a -> 'a + +end + +(*S Functional implementation. *) + +module type FunctionalSig = sig + + (* heap elements *) + type elt + + (* Type of functional heaps *) + type t + + (* The empty heap *) + val empty : t + + (* [add x h] returns a new heap containing the elements of [h], plus [x]; + complexity $O(log(n))$ *) + val add : elt -> t -> t + + (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] + when [h] is empty; complexity $O(1)$ *) + val maximum : t -> elt + + (* [remove h] returns a new heap containing the elements of [h], except + the maximum of [h]; raises [EmptyHeap] when [h] is empty; + complexity $O(log(n))$ *) + val remove : t -> t + + (* usual iterators and combinators; elements are presented in + arbitrary order *) + val iter : (elt -> unit) -> t -> unit + + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + +end + +module Functional(X: Ordered) : FunctionalSig with type elt = X.t diff --git a/external/misc/misc.ml b/external/misc/misc.ml new file mode 100644 --- /dev/null +++ b/external/misc/misc.ml @@ -0,0 +1,1346 @@ +(* + * Copyright ? 1990-2007 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +(* $Id: misc.ml,v 1.14 2006/09/26 01:47:01 jhala Exp $ + * + * This file is part of the SIMPLE Project. + *) + +(** + * This module provides some miscellaneous useful helper functions. + *) + +module Ops = struct + + type ('a, 'b) either = Left of 'a | Right of 'b + + let (>|) _ x = x + + let (|>) x f = f x + + let (<|) f x = f x + + let (>>) x f = f x; x + + let (|>>) xo f = match xo with None -> None | Some x -> f x + + let (|>:) xs f = List.map f xs + + let (=+) x n = let v = !x in (x := v + n; v) + + let (+=) x n = x := !x + n; !x + + let (++) = List.rev_append + + let (+++)= fun (x1s, y1s) (x2s, y2s) -> (x1s ++ x2s, y1s ++ y2s) + + let id = fun x -> x + + let un = fun x -> () + + let const x = fun _ -> x + + let (<.>) f g = fun x -> x |> g |> f + + let (<+>) f g = fun x -> x |> f |> g + + let () b f = fun x -> if b then f x else x + + let wwhen b f = fun x -> if b then f x + + let (<*>) f g = fun x -> (f x, g x) + + let (<**>) f g = fun (x, y) -> (f x, g y) + + let (<&&>) f g = fun x -> f x && g x + + let failure fmt = Printf.ksprintf failwith fmt + + let foreach xs f = List.map f xs + + let asserts p fmt = + Printf.ksprintf (fun x -> if not p then failwith x) fmt + +let asserti = asserts + (* +let asserti p fmt = + Printf.ksprintf (fun x -> if not p then (print_string (x^"\n"); ignore(0/0)) else ()) fmt +*) + +let assertf fmt = + Printf.ksprintf failwith fmt + +let halt _ = + assert false + +let fst3 (x,_,_) = x +let snd3 (_,x,_) = x +let thd3 (_,_,x) = x + +let fst4 (x, _, _, _) = x +let snd4 (_, x, _, _) = x +let thd4 (_, _, x, _) = x +let fth4 (_, _, _, x) = x + +let withfst3 (_,y,z) x = (x,y,z) +let withsnd3 (x,_,z) y = (x,y,z) +let withthd3 (x,y,_) z = (x,y,z) + +let print_now s = + print_string s; + flush stdout + +let print_now_error msg = + prerr_string msg; + flush stderr + +let output_now c s = + output_string c s; + flush c + +let some = fun x -> Some x + +end + +open Ops + +let maybe_fold f b xs = + let fo = fun bo x -> match bo with Some b -> f b x | _ -> None in + List.fold_left fo (Some b) xs + +let maybe_map f = function Some x -> Some (f x) | None -> None + +let maybe_iter f = function Some x -> f x | None -> () + +let maybe = function Some x -> x | _ -> assertf "maybe called with None" + +let maybe_apply f xo v = match xo with Some x -> f x v | None -> v + +let maybe_default xo y = match xo with Some x -> x | None -> y + +let maybe_string f = function Some x -> "Some " ^ (f x) | None -> "None" + +let rec maybe_chain x d = function + | f::fs -> (match f x with + | Some y -> y + | None -> maybe_chain x d fs) + | [] -> d + + + + + +let trace s f x = + let _ = print_now <| Printf.sprintf "BEGIN: %s \n" s in + let r = f x in + let _ = print_now <| Printf.sprintf "END: %s \n" s in + r + +(* ORIG +let rec pprint_many_box s f ppf = function + | [] -> () + | x::[] -> Format.fprintf ppf "%a" f x + | x::xs' -> (Format.fprintf ppf "%a%s@\n" f x s; pprint_many_box s f ppf xs') +*) +let rec pprint_many_prefix sep base f ppf = function + | x::xs -> Format.fprintf ppf "(%s %a %a)" + sep f x (pprint_many_prefix sep base f) xs + | [] -> Format.fprintf ppf "%a" f base + + +let rec pprint_many_box brk s f ppf = function + | [] -> () + | [x] -> Format.fprintf ppf "%a" f x + | x::xs' when brk -> Format.fprintf ppf "%a@\n%s" f x s; + pprint_many_box brk s f ppf xs' + | x::xs' -> Format.fprintf ppf "%a@,%s" f x s; + pprint_many_box brk s f ppf xs' + +let pprint_many_box brk l s r f ppf = function + | [] -> Format.fprintf ppf "[]" + | xs -> Format.fprintf ppf "@[%s%a%s@]" l (pprint_many_box brk s f) xs r + +let pprint_many_brackets brk f ppf x = + Format.fprintf ppf "%a" (pprint_many_box brk "[ " "; " "]" f) x + +let rec pprint_many brk s f ppf = function + | [] -> () + | [x] -> Format.fprintf ppf "%a" f x + | x::xs' when brk -> Format.fprintf ppf "%a%s@," f x s; pprint_many brk s f ppf xs' + | x::xs' -> Format.fprintf ppf "%a%s" f x s ; pprint_many brk s f ppf xs' + +let pprint_maybe f ppf = function + | Some x -> Format.fprintf ppf "Some %a" f x + | None -> Format.fprintf ppf "None" + +let pprint_int ppf i = + Format.fprintf ppf "%d" i + +let pprint_int_o = pprint_maybe pprint_int +(* +let pprint_int_o ppf = function + | None -> Format.fprintf ppf "None" + | Some d -> Format.fprintf ppf "Some(%d)" d +*) + +let pprint_str ppf s = + Format.fprintf ppf "%s" s + +let pprint_ints ppf is = + pprint_many_brackets false (fun ppf i -> Format.fprintf ppf "%d" i) ppf is + +let pprint_pretty_ints ppf is = + is |> List.map string_of_int |> String.concat ";" |> Format.fprintf ppf "[%s]" + +let pprint_tuple pp1 pp2 ppf (x1, x2) = + Format.fprintf ppf "(%a, %a)" pp1 x1 pp2 x2 + +let rec subsets n = function + | _ when n <= 0 + -> [[]] + | xs when n > List.length xs-> + [] + | x::xs + -> (List.map (fun ys -> x :: ys) (subsets (n-1) xs)) + ++ (subsets n xs) + | _ -> assertf "Misc.subsets" + +let choose b f g = if b then f else g + +let liftfst2 (f: 'a -> 'a -> 'b) (x: 'a * 'c) (y: 'a * 'c): 'b = + f (fst x) (fst y) + +let curry = fun f x y -> f (x,y) +let uncurry = fun f (x,y) -> f x y +let flip = fun f x y -> f y x + +let maybe_bool = function + | Some _ -> true + | None -> false + +module type EMapType = sig + include Map.S + val extendWith : (key -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t + val extend : 'a t -> 'a t -> 'a t + val filter : (key -> 'a -> bool) -> 'a t -> 'a t + val of_list : (key * 'a) list -> 'a t + val to_list : 'a t -> (key * 'a) list + val length : 'a t -> int + val domain : 'a t -> key list + val range : 'a t -> 'a list + val join : 'a t -> 'b t -> ('a * 'b) t + val adds : key -> 'a list -> 'a list t -> 'a list t + val of_alist : (key * 'a) list -> 'a list t + val finds : key -> 'a list t -> 'a list + val safeFind : key -> 'a t -> string -> 'a + val safeAdd : key -> 'a -> 'a t -> string -> 'a t + val single : key -> 'a -> 'a t + val map_partial : ('a -> 'b option) -> 'a t -> 'b t + val maybe_find : key -> 'a t -> 'a option + val find_default : 'a -> key -> 'a t -> 'a + val frequency : key list -> int t +end + +module type ESetType = sig + include Set.S + val of_list : elt list -> t +end + +module ESet (K: Set.OrderedType) = + struct + include Set.Make(K) + let of_list = List.fold_left (flip add) empty +end + +module type EOrderedType = sig + include Map.OrderedType + val print : Format.formatter -> t -> unit +end + +(* module EMap (K: Map.OrderedType) = *) +module EMap (K: EOrderedType) = + struct + include Map.Make(K) + + let extendWith (f: key -> 'a -> 'a -> 'a) (m1: 'a t) (m2: 'a t) = + fold begin fun k v m -> + let v' = if mem k m then f k v (find k m) else v in + add k v' m + end m2 m1 + + let extend (m1: 'a t) (m2: 'a t) : 'a t = fold add m2 m1 + + (* in 3.12 *) + let filter (f: key -> 'a -> bool) (m: 'a t) : 'a t = + fold (fun x y m -> if f x y then add x y m else m) m empty + + let of_list (kvs : (key * 'a) list) = + List.fold_left (fun m (k, v) -> add k v m) empty kvs + + (* in 3.12 -- bindings *) + let to_list (m : 'a t) : (key * 'a) list = + fold (fun k v acc -> (k,v)::acc) m [] + + (* in 3.12 -- cardinality *) + let length (m : 'a t) : int = + fold (fun _ _ i -> i+1) m 0 + + (* in 3.12 -- singleton *) + let single k v = add k v empty + + let domain m = + fold (fun k _ acc -> k :: acc) m [] + + let range (m : 'a t) : 'a list = + fold (fun _ v acc -> v :: acc) m [] + + let join (m1 : 'a t) (m2 : 'b t) : ('a * 'b) t = + mapi begin fun k v1 -> + let _ = asserts (mem k m2) "EMap.join" in + (v1, find k m2) + end m1 + + let maybe_find k m = + try Some (find k m) with Not_found -> None + + let find_default d k m = + maybe_default (maybe_find k m) d + + (* let finds k m = try find k m with Not_found -> [] *) + let finds k m = find_default [] k m + + let adds (k: key) (vs: 'a list) (m : ('a list) t) : 'a list t = + add k (vs ++ find_default [] k m) m + + let of_alist (kvs : (key * 'a) list) = + List.fold_left (fun m (k, v) -> adds k [v] m) empty kvs + + let frequency (ks : key list) : int t = + List.fold_left (fun m k -> + add k (1 + (find_default 0 k m)) m + ) empty ks + + let safeFind k m msg = + try find k m with Not_found -> + let err = Format.fprintf Format.str_formatter + "ERROR: safeFind (%s): %a" msg K.print k; + Format.flush_str_formatter () + in failwith err + + let safeAdd k v m msg = + if mem k m then + let err = Format.fprintf Format.str_formatter + "ERROR: safeAdd (%s): %a" msg K.print k; + Format.flush_str_formatter () + in failwith err + else add k v m + + let map_partial f m = + fold (fun x yo m -> match yo with Some y -> add x y m | _ -> m) (map f m) empty + end + +module type KeyValType = + sig + type t + val compare : t -> t -> int + val print : Format.formatter -> t -> unit + + type v + val default : v + end + +module MapWithDefault (K: KeyValType) = + struct + include EMap(K) + let find (i: K.t) (m: K.v t): K.v = + try find i m with Not_found -> K.default + end + +module IntMap = + EMap + (struct + type t = int + let compare i1 i2 = compare i1 i2 + let print = pprint_int + end) + +module IntSet = + ESet + (struct + type t = int + let compare i1 i2 = + compare i1 i2 + end) + +module IntIntMap = + EMap + (struct + type t = int * int + let compare i1 i2 = compare i1 i2 + let print ppf (i1, i2) = Format.fprintf ppf "(%d, %d)" i1 i2 + end) + +module StringMap = + EMap + (struct + type t = string + let compare i1 i2 = compare i1 i2 + let print ppf s = Format.fprintf ppf "%s" s + end) + +module StringSet = + ESet + (struct + type t = string + let compare i1 i2 = compare i1 i2 + end) + +(* +let sm_join sm1 sm2 = + StringMap.mapi (fun k v1 -> + let v2 = asserts (StringMap.mem k sm2) "sm_join"; StringMap.find k sm2 in + (v1, v2) + ) sm1 + +let sm_extend sm1 sm2 = + StringMap.fold StringMap.add sm2 sm1 + +let sm_filter f sm = + StringMap.fold begin fun x y sm -> + if f x y then StringMap.add x y sm else sm + end sm StringMap.empty + +let sm_of_list kvs = + List.fold_left (fun sm (k,v) -> StringMap.add k v sm) StringMap.empty kvs + +let sm_to_list sm = + StringMap.fold (fun k v acc -> (k,v)::acc) sm [] + +let sm_to_range sm = + sm |> sm_to_list |> List.map snd +*) + +let sm_print_keys name sm = + sm |> StringMap.to_list + |> List.map fst + |> String.concat ", " + |> Printf.printf "%s : %s \n" name + +let foldn f n b = + let rec foo acc i = + if i >= n then acc else foo (f acc i) (i+1) + in foo b 0 + +let rec range i j = + if i >= j then [] else i::(range (i+1) j) + +let dump s = + print_string s; flush stdout + +let mapn f n = + foldn (fun acc i -> (f i) :: acc) n [] + |> List.rev + +let chop_last = function + | [] -> failure "ERROR: Misc.chop_last" + | xs -> xs |> List.rev |> List.tl |> List.rev + +let list_snoc xs = + match List.rev xs with + | [] -> assertf "list_snoc with empty list!" + | h::t -> h, List.rev t + +let negfilter f xs = + List.fold_left (fun acc x -> if f x then acc else x::acc) [] xs + |> List.rev + +let get_option d = function + | Some x -> x + | None -> d + +let list_somes xs = + xs |> List.fold_left begin fun acc -> function + | Some x -> x :: acc + | None -> acc + end [] + |> List.rev + +(* let map_partial f = list_somes <.> List.map f *) + +let map_partial f xs = + List.rev + (List.fold_left + (fun acc x -> + match f x with + | None -> acc + | Some z -> (z::acc)) [] xs) + + +let fold_left_partial f b xs = + List.fold_left begin fun b xo -> + match xo with + | Some x -> f b x + | None -> b + end b xs + +let list_reduce msg f = function + | [] -> assertf "ERROR: list_reduce with empty list: %s" msg + | x::xs -> List.fold_left f x xs + +let nonnull = function + | [] -> false + | _ -> true + +(* +let list_is_empty = function + | [] -> true + | _::_ -> false +*) + +let list_max x xs = + List.fold_left max x xs + +let list_min x xs = + List.fold_left min x xs + +let list_max_with msg f = function + | [] -> assertf "ERROR: list_max_with with empty list: %s" msg + | x::xs -> List.fold_left (fun acc x -> if f x > f acc then x else acc) x xs + +let rec take_max n = function + | x :: xs when n > 0 -> x :: take_max (n - 1) xs + | _ -> [] + +let rec drop n = function + | x :: xs when n > 0 -> drop (n - 1) xs + | [] when n > 0 -> assertf "ERROR: dropped too many" + | xs -> xs + +let getf a i fmt = + try a.(i) with ex -> assertf fmt + +let do_catchu f x g = + try f x with ex -> (g ex; raise ex) + +let do_catchf s f x = + try f x with ex -> + assertf "%s hits exn: %s \n" s (Printexc.to_string ex) + +let do_catch s f x = + try f x with ex -> + (Printf.printf "%s hits exn: %s \n" s (Printexc.to_string ex); raise ex) + +let do_catch_ret s f x y = + try f x with ex -> + (Printf.printf "%s hits exn: %s \n" s (Printexc.to_string ex); y) + +let do_memo memo f args key = + try Hashtbl.find memo key with Not_found -> + let rv = f args in + let _ = Hashtbl.replace memo key rv in + rv + +let do_bimemo fmemo rmemo f args key = + try Hashtbl.find fmemo key with Not_found -> + let rv = f args in + let _ = Hashtbl.replace fmemo key rv in + let _ = Hashtbl.replace rmemo rv key in + rv + +let rec exists_maybe f = function + | [] -> None + | x::xs -> (match f x with None -> exists_maybe f xs | z -> z) + +let map_pair = fun f (x1, x2) -> (f x1, f x2) +let map_triple = fun f (x1, x2, x3) -> (f x1, f x2, f x3) +let app_fst = fun f (a, b) -> (f a, b) +let app_snd = fun f (a, b) -> (a, f b) +let app_fst3 = fun f (a, b, c) -> (f a, b, c) + +let app_snd3 = fun f (a, b, c) -> (a, f b, c) + +let app_thd3 = fun f (a, b, c) -> (a, b, f c) +let pad_snd = fun f x -> (x, f x) +let pad_fst = fun f y -> (f y, y) +let tmap2 = fun (f, g) x -> (f x, g x) +let tmap3 = fun (f, g, h) x -> (f x, g x, h x) +let iter_fst = fun f (a, b) -> f a +let iter_snd = fun f (a, b) -> f b + +let split3 lst = + List.fold_right (fun (x, y, z) (xs, ys, zs) -> (x :: xs, y :: ys, z :: zs)) lst ([], [], []) + +let split4 lst = + List.fold_right (fun (w, x, y, z) (ws, xs, ys, zs) -> (w :: ws, x :: xs, y :: ys, z :: zs)) lst ([], [], [], []) + +let twrap s f x = + let _ = Printf.printf "calling %s \n" s in + let rv = f x in + let _ = Printf.printf "returned from %s \n" s in + rv + +let mapfold_rev f b xs = + List.fold_left begin fun (acc, ys) x -> + let (acc', y) = f acc x in + (acc', y::ys) + end (b, []) xs + +let mapfold f b xs = + mapfold_rev f b xs + |> app_snd List.rev + +let rootsBy leq xs = + let notDomBy x = not <.> (leq x) in + let rec loop acc = function + | [] -> + acc + | (x::xs) -> + let acc', xs' = map_pair (List.filter (notDomBy x)) (acc, xs) in + loop (x::acc') xs' + in loop [] xs + +let cov_filter cov f xs = + let rec loop acc = function + | [] -> + acc + | (x::xs) when f x -> + let covs, uncovs = List.partition (cov x) xs in + loop ((x, covs) :: acc) uncovs + | (_::xs) -> + loop acc xs + in loop [] xs + +let filter f xs = + List.fold_left (fun xs' x -> if f x then x::xs' else xs') [] xs + |> List.rev + +let iter f xs = + List.fold_left (fun () x -> f x) () xs + +let map2 f xs ys = + let _ = asserti (List.length xs = List.length ys) "Misc.map2" in + List.map2 f xs ys + +let map f xs = + List.rev_map f xs |> List.rev + +let flatten xss = + xss + |> List.fold_left (fun acc xs -> xs ++ acc) [] + |> List.rev + +let flatsingles xss = + xss |> List.fold_left (fun acc -> function [x] -> x::acc | _ -> assertf "flatsingles") [] + |> List.rev + +let splitflatten xsyss = + let xss, yss = List.split xsyss in + (flatten xss, flatten yss) + +let splitflatten3 xsyszss = + let xss, yss, zss = split3 xsyszss in + (flatten xss, flatten yss, flatten zss) + +let flap f xs = + xs |> List.rev_map f |> flatten |> List.rev + +let flap_pair f = splitflatten <.> map f + +let tr_rev_flatten xs = + List.fold_left (fun x xs -> x ++ xs) [] xs + +let tr_rev_flap f xs = + List.fold_left (fun xs x -> (f x) ++ xs) [] xs + +let rec fast_unflat ys = function + | x :: xs -> fast_unflat ([x] :: ys) xs + | [] -> ys + +let dup x = (x, x) + + +let rec rev_perms s = function + | [] -> s + | e :: es -> rev_perms + (tr_rev_flap (fun e -> List.rev_map (fun s -> e :: s) s) e) es + +let product = function + | e :: es -> rev_perms (fast_unflat [] e) es + | es -> es + +let pairs xs = + let rec pairs_aux ps = function + | [] -> ps + | x :: xs -> pairs_aux (List.fold_left (fun ps y -> (x, y) :: ps) ps xs) xs + in pairs_aux [] xs + +let cross_product xs ys = + map begin fun x -> + map begin fun y -> + (x,y) + end ys + end xs + |> flatten + +let rec cross_flatten = function + | [] -> + [[]] + | xs::xss -> + map begin fun x -> + map begin fun ys -> + (x::ys) + end (cross_flatten xss) + end xs + |> flatten + + +let append_pref p s = + (p ^ "." ^ s) + + +let fsort f xs = + let cmp = fun (k1,_) (k2,_) -> compare k1 k2 in + xs |> map (fun x -> ((f x), x)) + |> List.sort cmp + |> map snd + +let sort_and_compact ls = + let rec _sorted_compact l = + match l with + h1::h2::tl -> + let rest = _sorted_compact (h2::tl) in + if h1 = h2 then rest else h1::rest + | tl -> tl + in + _sorted_compact (List.sort compare ls) + +let sort_and_compact xs = + List.sort compare xs + |> List.fold_left + (fun ys x -> match ys with + | y::_ when x=y -> ys + | _::_ -> x::ys + | [] -> [x]) + [] + |> List.rev + +let hashtbl_to_list t = + Hashtbl.fold (fun x y l -> (x,y)::l) t [] + +let hashtbl_keys t = + Hashtbl.fold (fun x y l -> x::l) t [] + |> sort_and_compact + +let hashtbl_invert t = + let t' = Hashtbl.create 17 in + hashtbl_to_list t + |> List.iter (fun (x,y) -> Hashtbl.replace t' y x) + |> fun _ -> t' + + +let distinct xs = + List.length xs = List.length (sort_and_compact xs) + +(** repeats f: unit - > unit i times *) +let rec repeat_fn f i = + if i = 0 then () + else (f (); repeat_fn f (i-1)) + +(* chop s chopper returns ([x;y;z...]) if s = x.chopper.y.chopper ...*) +let chop s chopper = Str.split (Str.regexp chopper) s + +(* like chop only the chop is by chop+ *) +let chop_star chopper s = + Str.split (Str.regexp (Printf.sprintf "[%s+]" chopper)) s + +let bounded_chop s chopper i = Str.bounded_split (Str.regexp chopper) s i + +let is_prefix p s = + let (ls, lp) = (String.length s, String.length p) in + if ls < lp + then false + else + (String.sub s 0 lp) = p + +let is_substring s subs = + let reg = Str.regexp subs in + try ignore(Str.search_forward reg s 0); true + with Not_found -> false + +let replace_substring src dst s = + Str.global_replace (Str.regexp src) dst s + +let is_suffix suffix s = + let k = String.length suffix + and n = String.length s in + (n-k >= 0) && Str.string_match (Str.regexp suffix) s (n-k) + +let iteri f xs = + List.fold_left (fun i x -> f i x; i+1) 0 xs + |> ignore + +let numbered_list xs = + xs |> List.fold_left (fun (i, acc) x -> (i+1, (i,x)::acc)) (0,[]) + |> snd + |> List.rev + +exception FalseException + +let sm_protected_add fail k v sm = + if not (StringMap.mem k sm) then StringMap.add k v sm else + if not fail then sm else + assertf "protected_add: duplicate binding for %s \n" k + +let hashtbl_to_list_all t = + hashtbl_keys t |> map (Hashtbl.find_all t) + +let clone x n = + let rec f n xs = if n <= 0 then xs else f (n-1) (x::xs) in + f n [] + +let single x = [x] + +let distinct xs = + List.length (sort_and_compact xs) = List.length xs + +let trunc i j = + let (ai,aj) = (abs i, abs j) in + if aj <= ai then j else ai*j/aj + +let map_to_string f xs = + String.concat "," (List.map f xs) + +let suffix_of_string = fun s i -> String.sub s i (String.length s - 1) + +(* [count_map xs] = fun x -> number of times x appears in xs if non-zero *) +let count_map rs = + List.fold_left begin fun m r -> + let c = try IntMap.find r m with Not_found -> 0 in + IntMap.add r (c+1) m + end IntMap.empty rs + +let o2s f = function + | Some x -> "Some "^ (f x) + | None -> "None" + +let fixpoint f x = + let rec acf b x = + let x', b' = f x in + if b' then acf true x' else (x', b) in + acf false x + + +let fsprintf f p = + Format.fprintf Format.str_formatter "@[%a@]" f p; + Format.flush_str_formatter () + +let rec same_length l1 l2 = match l1, l2 with + | [], [] -> true + | _ :: xs, _ :: ys -> same_length xs ys + | _ -> false + +let ex_one s = function + | [x] -> x + | _ :: _ -> failwith s + | _ -> failwith (s ^ ". empty") + +let only_one s = function + x :: [] -> Some x + | _ :: _ -> failwith s + | [] -> None + +let maybe_one = function + | [x] -> Some x + | _ -> None + + +let int_of_bool b = if b then 1 else 0 + +(*****************************************************************) +(******************** Mem Management *****************************) +(*****************************************************************) + +open Gc +(* open Format *) + +let pprint_gc s = + (*printf "@[Gc@ Stats:@]@."; + printf "@[minor@ words:@ %f@]@." s.minor_words; + printf "@[promoted@ words:@ %f@]@." s.promoted_words; + printf "@[major@ words:@ %f@]@." s.major_words;*) + (*printf "@[total allocated:@ %fMB@]@." (floor ((s.major_words +. s.minor_words -. s.promoted_words) *. (4.0) /. (1024.0 *. 1024.0)));*) + + Format.printf "@[total allocated:@ %fMB@]@." (floor ((allocated_bytes ()) /. (1024.0 *. 1024.0))); + Format.printf "@[minor@ collections:@ %i@]@." s.minor_collections; + Format.printf "@[major@ collections:@ %i@]@." s.major_collections; + Format.printf "@[heap@ size:@ %iMB@]@." (s.heap_words * 4 / (1024 * 1024)); + (*printf "@[heap@ chunks:@ %i@]@." s.heap_chunks; + (*printf "@[live@ words:@ %i@]@." s.live_words; + printf "@[live@ blocks:@ %i@]@." s.live_blocks; + printf "@[free@ words:@ %i@]@." s.free_words; + printf "@[free@ blocks:@ %i@]@." s.free_blocks; + printf "@[largest@ free:@ %i@]@." s.largest_free; + printf "@[fragments:@ %i@]@." s.fragments;*)*) + Format.printf "@[compactions:@ %i@]@." s.compactions; + (*printf "@[top@ heap@ words:@ %i@]@." s.top_heap_words*) () + +let dump_gc s = + Format.printf "@[%s@]@." s; + pprint_gc (Gc.quick_stat ()) + + +let append_to_file f s = + let oc = Unix.openfile f [Unix.O_WRONLY; Unix.O_APPEND; Unix.O_CREAT] 420 in + ignore (Unix.write oc s 0 ((String.length s)-1) ); + Unix.close oc + +(* +let with_out_file file f = + let oc = open_out file in + f oc; + close_out oc +*) + +let display_tick = fun () -> print_now "." + +let display_tick = + let icona = [| "|"; "/" ; "-"; "\\" |] in + let pos = ref 0 in + fun () -> + let k = !pos in + let _ = print_now ("\b."^icona.(k)) in + let _ = pos := (k + 1) mod 4 in + () + +let with_out_file file f = file |> open_out >> f |> close_out + +let write_to_file f s = + with_out_file f (fun oc -> output_string oc s) + +let with_out_formatter file f = + with_out_file file (fun oc -> f (Format.formatter_of_out_channel oc)) + +let get_unique = + let cnt = ref 0 in + (fun () -> let rv = !cnt in incr cnt; rv) + +let lines_of_file filename = + let lines = ref [] in + let chan = open_in filename in + try + while true; do + lines := input_line chan :: !lines + done; [] + with End_of_file -> + close_in chan; + List.rev !lines + +let map_lines_of_file infile outfile f = + let ic = open_in infile in + let oc = open_out outfile in + try + while true; do + ic |> input_line |> f |> output_string oc + done; + with End_of_file -> + (close_in ic; close_out oc) + +let maybe_cons m xs = match m with + | None -> xs + | Some x -> x :: xs + +let maybe_list xs = + List.fold_right maybe_cons xs [] + +let rec list_first_maybe f = function + | x::xs -> begin match f x with + | Some y -> Some y + | _ -> list_first_maybe f xs + end + | [] -> None + +let list_find_maybe f xs = + try some <| List.find f xs with Not_found -> None + +let list_assoc_maybe k kvs = + try Some (List.assoc k kvs) with Not_found -> None + +let list_assoc_default d kvs k = + try List.assoc k kvs with Not_found -> d + +let list_assoc_flip xs = + let r (x, y) = (y, x) in + List.map r xs + +let fold_lefti f b xs = + List.fold_left (fun (i,b) x -> ((i+1), f i b x)) (0,b) xs + +let mapi f xs = + xs |> fold_lefti (fun i acc x -> (f i x) :: acc) [] + |> snd |> List.rev + +let index_from n xs = + let is = range n (n + List.length xs) in + List.combine is xs + +let fold_left_flip f b xs = + List.fold_left (flip f) b xs + +let fold_left_swap f xs b = + List.fold_left f b xs + +let rec map3 f xs ys zs = match (xs, ys, zs) with + | ([], [], []) -> [] + | (x :: xs, y :: ys, z :: zs) -> f x y z :: map3 f xs ys zs + | _ -> assert false + +let rec fold_right3 f xs ys zs acc = match xs, ys, zs with + | x :: xs, y :: ys, z :: zs -> f x y z (fold_right3 f xs ys zs acc) + | [], [], [] -> acc + | _ -> assert false + +let rec fold_left3 f acc xs ys zs = match xs, ys, zs with + | x :: xs, y :: ys, z :: zs -> fold_left3 f (f acc x y z) xs ys zs + | [], [], [] -> acc + | _ -> assert false + +let zip_partition xs bs = + let (xbs, xbs') = List.partition snd (List.combine xs bs) in + (List.map fst xbs, List.map fst xbs') + +let rec map4 f ws xs ys zs = match ws, xs, ys, zs with + | [], [], [], [] -> [] + | w :: ws, x :: xs, y :: ys, z :: zs -> f w x y z :: map4 f ws xs ys zs + | _ -> asserti false "map4"; assert false + + +let rec perms es = + match es with + | s :: [] -> + List.map (fun c -> [c]) s + | s :: es -> + flap (fun c -> List.map (fun d -> c :: d) (perms es)) s + | [] -> + [] + +let flap2 f xs ys = + List.flatten (List.map2 f xs ys) + +let flap3 f xs ys zs = + List.flatten (map3 f xs ys zs) + +let combine msg xs ys = + let _ = asserts (List.length xs = List.length ys) "%s" msg in + List.combine xs ys + +let combine3 xs ys zs = + map3 (fun x y z -> (x, y, z)) xs ys zs + +let combine4 ws xs ys zs = + map4 (fun w x y z -> (w, x, y, z)) ws xs ys zs + +let tr_partition f xs = + List.fold_left begin fun (xs,ys) z -> + if f z + then (z::xs, ys) + else (xs, z::ys) + end ([],[]) xs + +let either_partition f xs = + List.fold_left begin fun (xs, ys) z -> + match f z with + | Left x -> (x::xs, ys) + | Right y -> (xs, y::ys) + end ([], []) xs + +(* these do odd things with order for performance + * it is possible that fast is a misnomer *) +let fast_flatten xs = + List.fold_left (++) [] xs + +let fast_append v v' = + let (v, v') = if List.length v > List.length v' then (v', v) else (v, v') in + List.rev_append v v' + +let fast_flap f xs = + List.fold_left (fun xs x -> List.rev_append (f x) xs) [] xs + +let rec fast_unflat ys = function + | x :: xs -> fast_unflat ([x] :: ys) xs + | [] -> ys + +let rec rev_perms s = function + | [] -> s + | e :: es -> rev_perms + (fast_flap (fun e -> List.rev_map (fun s -> e :: s) s) e) es + +let rev_perms = function + | e :: es -> rev_perms (fast_unflat [] e) es + | es -> es + +let tflap2 (e1, e2) f = + List.fold_left (fun bs b -> List.fold_left (fun aas a -> f a b :: aas) bs e1) [] e2 + +let tflap3 (e1, e2, e3) f = + List.fold_left begin fun cs c -> + List.fold_left begin fun bs b -> + List.fold_left begin fun aas a -> + f a b c :: aas + end bs e1 + end cs e2 + end[] e3 + +let rec expand f xs ys = + match xs with + | [] -> ys + | x::xs -> let (xs', ys') = f x in + expand f (xs' ++ xs) (ys' ++ ys) + +let rec get_first f = function + | x::xs when f x -> Some x + | _::xs -> get_first f xs + | [] -> None + +let join f xs ys = + let rec fuse acc xs ys = + match xs, ys with + | [],_ | _, [] -> List.rev acc + | ((kx, _)::xs', (ky,_)::_ ) when kx < ky -> fuse acc xs' ys + | ((kx, _)::_ , (ky,_)::ys') when kx > ky -> fuse acc xs ys' + | ((kx, x)::xs', (ky,y)::ys') (* kx = ky *) -> fuse ((x,y)::acc) xs' ys' in + let xs' = List.map (fun x -> (f x, x)) xs |> List.sort compare in + let ys' = List.map (fun y -> (f y, y)) ys |> List.sort compare in + fuse [] xs' ys' + +let hashtbl_find_default d t x = + try Hashtbl.find t x with Not_found -> d + +let frequency (xs : 'a list) : ('a * int) list = + let t = Hashtbl.create 17 in + List.iter begin fun x -> + let n = hashtbl_find_default 0 t x in + Hashtbl.replace t x (n + 1) + end xs; + hashtbl_to_list t + +let kgroupby (f: 'a -> 'b) (xs: 'a list): ('b * 'a list) list = + let t = Hashtbl.create 17 in + let lookup x = try Hashtbl.find t x with Not_found -> [] in + (* build table *) + List.iter begin fun x -> + Hashtbl.replace t (f x) (x :: lookup (f x)) + end xs; + (* build cluster *) + Hashtbl.fold (fun k xs xxs -> (k, xs) :: xxs) t [] + + + +let groupby (f: 'a -> 'b) (xs: 'a list): 'a list list = + kgroupby f xs |> List.map (snd <+> List.rev) + +let full_join f xs ys = + (xs, ys) + |> map_pair (kgroupby f) + |> uncurry (join fst) + |> flap (map_pair snd <+> uncurry cross_product) + +let exists_pair (f: 'a -> 'a -> bool) (xs: 'a list): bool = + fst (List.fold_left (fun (b, ys) x -> (b || List.exists (f x) ys, x :: ys)) (false, []) xs) + +let rec find_pair (f: 'a -> 'a -> bool): 'a list -> 'a * 'a = function + | [] -> raise Not_found + | x::xs -> try (x, List.find (f x) xs) with Not_found -> find_pair f xs + +let rec is_unique = function + | [] -> true + | x :: xs -> if List.mem x xs then false else is_unique xs + +let map_opt f = function + | Some o -> Some (f o) + | None -> None + +let resl_opt f = function + | Some o -> f o + | None -> [] + +let resi_opt f = function + | Some o -> f o + | None -> () + +let opt_iter f l = + List.iter (resi_opt f) l + +let array_findi p arr = + let rec look i = + if i < 0 then raise Not_found else + if p arr.(i) then i else look i - 1 + in look (Array.length arr - 1) + +let array_to_index_list a = + Array.fold_left (fun (i, rv) v -> (i+1,(i,v)::rv)) (0,[]) a + |> snd + |> List.rev + + +let hashtbl_of_list xys = + let t = Hashtbl.create 37 in + let _ = List.iter (fun (x,y) -> Hashtbl.add t x y) xys in + t + +let hashtbl_of_list_with kf xs = + xs |>: pad_fst kf |> hashtbl_of_list + +let array_flapi f a = + Array.fold_left (fun (i, acc) x -> (i+1, (f i x) :: acc)) (0,[]) a + |> snd + |> List.rev + |> flatten + +let array_fold_lefti f acc a = + Array.fold_left (fun (i, acc) x -> (i + 1, f i acc x)) (0, acc) a |> snd + +let array_map2 f xa ya = + Array.mapi (fun i x -> f x (ya.(i))) xa + +let array_rev_iteri f a = + for i = Array.length a - 1 downto 0 do + f i a.(i) + done + +exception NotForall + +let array_forall f a = + try + Array.iter (fun e -> if f e then () else raise NotForall) a; true + with NotForall -> + false + +let array_combine a1 a2 = + asserts (Array.length a1 = Array.length a2) "array_combine"; + Array.init (Array.length a1) (fun i -> (a1.(i), a2.(i))) + + +let compose f g a = f (g a) + + +let rec gcd (a: int) (b: int): int = + if b = 0 then a else gcd b (a mod b) + +let lcm (a: int) (b: int): int = + if a = 0 then a else (abs (a * b)) / (gcd a b) + +let mk_int_factory () = + let id = ref (-1) in + ((fun () -> incr id; !id), (fun () -> id := -1)) + +let mk_char_factory () = + let (fresh_int, reset_fresh_int) = mk_int_factory () in + ((fun () -> Char.chr (fresh_int () + Char.code 'a')), reset_fresh_int) + +let mk_string_factory s = + let (fresh_int, reset_fresh_int) = mk_int_factory () in + ((fun () -> s^(string_of_int (fresh_int ()))), reset_fresh_int) + +let swap (x,y) = (y,x) + +(* ('a * (int * 'b) list) list -> (int * ('a * 'b) list) list *) +let transpose x_iys_s = + let t = Hashtbl.create 17 in + List.iter begin fun (x, iys) -> + List.iter begin fun (i, y) -> + Hashtbl.add t i (x,y) + end iys + end x_iys_s; + hashtbl_keys t |> List.map (fun i -> (i, Hashtbl.find_all t i)) + +let basename_no_extension fname = + fname |> Filename.basename |> Filename.chop_extension + +let absolute_name name = + if not (Filename.is_relative name) then name else + let b = Filename.basename name in + let d = Filename.dirname name in + let dir = Sys.getcwd () in + let _ = Sys.chdir (Filename.concat dir d) in + let dir' = Sys.getcwd () in + let rv = Filename.concat dir' b in + let _ = Sys.chdir dir in + rv + +let cardinality = fun xs -> xs |> sort_and_compact |> List.length +let disjoint = fun xs ys -> cardinality xs + cardinality ys = cardinality (xs ++ ys) + +let bracket (l : unit -> unit) (r : unit -> unit) (f : unit -> 'a) : 'a = + try l () |> f >> (fun _ -> r ()) + with ex -> assertf "bracket hits exn: %s \n" (Printexc.to_string ex) + +(* +let with_ref_at x v f = + let oldv = !x in + bracket (fun _ -> x := v) (fun _ -> x := oldv) f +*) + +let with_ref_at x v f = + let oldv = !x in + let _ = x := v in + let res = f () in + let _ = x := oldv in + res + + + +let rec isPrefix = function + | ([], _) -> true + | (x::xs, y::ys) when x = y -> isPrefix (xs, ys) + | _ -> false + +let find_first_true f lo hi = + let rec go lo hi = + let mid = lo + ((hi - lo) / 2) in + match () with + | _ when lo >= hi -> None + | _ when lo = hi - 1 -> Some hi + | _ when f mid -> go lo mid + | _ -> go mid hi + in if f lo then Some lo + else if not (f hi) then None + else go lo hi + +let safeHead msg = function + | [x] -> x + | _ -> failwith ("ERROR: safeHead" ^ msg) + +let safeApply pp f x = match f x with + | Some y -> y + | None -> failwith ("ERROR: safeApply " ^ (pp x)) + +let stringIsUpper = function + | "" -> false + | s -> let c = s.[0] in c = Char.uppercase c + +let stringIsLower = function + | "" -> false + | s -> let c = s.[0] in c = Char.lowercase c + + + diff --git a/external/misc/tagtime.ml b/external/misc/tagtime.ml new file mode 100644 --- /dev/null +++ b/external/misc/tagtime.ml @@ -0,0 +1,125 @@ +(* + * + * Copyright (c) 2001 by + * George C. Necula necula@cs.berkeley.edu + * Scott McPeak smcpeak@cs.berkeley.edu + * Wes Weimer weimer@cs.berkeley.edu + * + * All rights reserved. Permission to use, copy, modify and distribute + * this software for research purposes only is hereby granted, + * provided that the following conditions are met: + * 1. XSRedistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * 3. The name of the authors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * DISCLAIMER: + * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +open Misc.Ops + +(******************************************************************) +(************************* Definitions ****************************) +(******************************************************************) + + (* A hierarchy of timings *) +type t = { name : string * (string list); + mutable time : float; + mutable sub : t list} + + (* Create the top level *) +let top = { name = "TOTAL", []; + time = 0.0; + sub = []; } + + (* The stack of current path through + * the hierarchy. The head is the + * leaf. *) +let current : t list ref = ref [top] + +let subtime x = + x.sub |> List.map (fun y -> y.time) + |> List.fold_left (+.) 0.0 + +(******************************************************************) +(************************* Printing *******************************) +(******************************************************************) + +let _print x chn msg = + x.time <- subtime x; + let rec prTree ind node = + Printf.fprintf chn "%s%-20s %6.3f s\n" + (String.make ind ' ') (fst node.name) node.time ; + List.iter (prTree (ind + 2)) node.sub + in Printf.fprintf chn "%s" msg; prTree 0 x + +let collapse (x: t) : t = failwith "TBD: Tagtime.collapse" + +(* API *) +let print chn msg = _print (collapse top) chn msg + +(******************************************************************) +(************************* Timing *********************************) +(******************************************************************) + +let restore_stat (oldcurrent, start, stat) = + let stop = Unix.times () in + let diff = stop.Unix.tms_utime -. start in + stat.time <- stat.time +. diff; + current := oldcurrent + +let find_stat stags = + let curr = (match !current with h :: _ -> h | _ -> assert false) in + let rec loop = function + | h :: _ when h.name = stags -> h + | _ :: rest -> loop rest + | [] -> let nw = {name = stags; time = 0.0; sub = []} in + curr.sub <- nw :: curr.sub; + nw + in loop curr.sub + +(* API *) +let time (str, tags) f arg = + let stat = find_stat (str, List.sort compare tags) in + let oldcurrent = !current in + let _ = current := stat :: oldcurrent in + let start = (Unix.times ()).Unix.tms_utime in + try + let res = f arg in + restore_stat (oldcurrent, start, stat); + res + with x -> begin + restore_stat (oldcurrent, start, stat); + raise x + end + +(******************************************************************) +(************************* Logging ********************************) +(******************************************************************) + +let dump_to_channel chn = + top.time <- subtime top; + let rec prTree tags node = + let s, ts = node.name in + let tags' = [s] ++ ts ++ tags in + let time' = max 0.0 (node.time -. (subtime node)) in + Printf.fprintf chn "%s,%6.3f\n" (String.concat "," tags') time'; + List.iter (prTree tags') node.sub + in prTree [] top + +(* API *) +let dump = fun fn -> fn |> open_out >> dump_to_channel |> close_out diff --git a/external/misc/tagtime.mli b/external/misc/tagtime.mli new file mode 100644 --- /dev/null +++ b/external/misc/tagtime.mli @@ -0,0 +1,37 @@ +(* + * Copyright ? 1990-2007 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +(* Based on "Stats" by George Necula, Westley Weimer and Scott McPeak *) + +(** Time a function and associate the time with the given + (key) string and the list of (tags) strings. If some + timing information is already associated with the key + string, then accumulate the times. If this function is + invoked within another timed function then you can have + a hierarchy of timings *) +val time : string * string list -> ('a -> 'b) -> 'a -> 'b + +(** [dump fname] saves the tagged profile to file *) +val dump : string -> unit + +val print: out_channel -> string -> unit diff --git a/external/misc/timer.ml b/external/misc/timer.ml new file mode 100644 --- /dev/null +++ b/external/misc/timer.ml @@ -0,0 +1,59 @@ +(* + * Copyright ? 1990-2010 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + *) + +open FixMisc.Ops + +type t = { + name : string; + mutable last : float; + mutable events: (int * string option * float) list; +} + +let get_time = fun _ -> (Unix.times ()).Unix.tms_utime + +let create n = + let now = get_time () in + { name = n; + events = [(0, None, 0.0)]; + last = now; + } + +let log_event t so = + match t.events with + | [] -> assertf "impossible" + | (i,_,_)::_ -> let now = get_time () in + t.events <- (i+1, so, now -. t.last)::t.events; + t.last <- now + +let to_events = fun t -> List.rev t.events +let to_name = fun t -> t.name + +let print_event ppf = function + | (i, Some s, f) -> Format.fprintf ppf "<%6d, %6.3f, %s>@\n" i f s + | (i, None , f) -> Format.fprintf ppf "<%6d, %6.3f, *>@\n" i f + +let print ppf t = + Format.fprintf ppf "Timer %s :: @[%a@] \n" + t.name + (FixMisc.pprint_many false "" print_event) (to_events t) + + diff --git a/external/misc/timer.mli b/external/misc/timer.mli new file mode 100644 --- /dev/null +++ b/external/misc/timer.mli @@ -0,0 +1,28 @@ +(* + * Copyright ? 1990-2010 The Regents of the University of California. All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + *) + +type t +val create : string -> t +val log_event: t -> string option -> unit +val print : Format.formatter -> t -> unit + diff --git a/external/misc/timetest.ml b/external/misc/timetest.ml new file mode 100644 --- /dev/null +++ b/external/misc/timetest.ml @@ -0,0 +1,29 @@ +(**************************************************************) +(*************** Unit Test For Time Modules *******************) +(**************************************************************) + +open Misc.Ops + +let rec repeat f n = if n > 0 then (f (); repeat f (n-1)) + +let pause_1_sec () = repeat (fun () -> ()) 112516096 +let pause_n_sec n = repeat pause_1_sec n + +let rec sim n c b t = + if n > 0 then begin + let id = "downtick "^(string_of_int n) in + let _ = Printf.printf "%s \n" id in + Timer.log_event t (Some id); + Tagtime.time ("pause",[id]) pause_n_sec b; + sim (n-1) c (c*b) t + end + +let sim n c b t = + sim n c b t; + Timer.log_event t None + +let c = try Sys.argv.(1) |> int_of_string with _ -> 1 +let _ = Timer.create "boo" + >> (fun t -> Tagtime.time ("sim", []) (sim 4 c 1) t) + |> Format.printf "%a" Timer.print +let _ = Tagtime.dump "timetest.stat" diff --git a/external/ocamlgraph/.depend b/external/ocamlgraph/.depend new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/.depend @@ -0,0 +1,128 @@ +lib/bitv.cmo: lib/bitv.cmi +lib/bitv.cmx: lib/bitv.cmi +lib/heap.cmo: lib/heap.cmi +lib/heap.cmx: lib/heap.cmi +lib/unionfind.cmo: lib/unionfind.cmi +lib/unionfind.cmx: lib/unionfind.cmi +lib/bitv.cmi: +lib/heap.cmi: +lib/unionfind.cmi: +src/blocks.cmo: src/util.cmi src/sig.cmi +src/blocks.cmx: src/util.cmx src/sig.cmi +src/builder.cmo: src/sig.cmi src/builder.cmi +src/builder.cmx: src/sig.cmi src/builder.cmi +src/classic.cmo: src/sig.cmi src/builder.cmi src/classic.cmi +src/classic.cmx: src/sig.cmi src/builder.cmx src/classic.cmi +src/cliquetree.cmo: src/util.cmi src/sig.cmi src/persistent.cmi src/oper.cmi \ + src/gmap.cmi src/builder.cmi src/cliquetree.cmi +src/cliquetree.cmx: src/util.cmx src/sig.cmi src/persistent.cmx src/oper.cmx \ + src/gmap.cmx src/builder.cmx src/cliquetree.cmi +src/components.cmo: src/util.cmi src/sig.cmi src/components.cmi +src/components.cmx: src/util.cmx src/sig.cmi src/components.cmi +src/delaunay.cmo: src/delaunay.cmi +src/delaunay.cmx: src/delaunay.cmi +src/dot.cmo: src/dot_parser.cmi src/dot_lexer.cmo src/dot_ast.cmi \ + src/builder.cmi src/dot.cmi +src/dot.cmx: src/dot_parser.cmx src/dot_lexer.cmx src/dot_ast.cmi \ + src/builder.cmx src/dot.cmi +src/dot_lexer.cmo: src/dot_parser.cmi src/dot_ast.cmi +src/dot_lexer.cmx: src/dot_parser.cmx src/dot_ast.cmi +src/dot_parser.cmo: src/dot_ast.cmi src/dot_parser.cmi +src/dot_parser.cmx: src/dot_ast.cmi src/dot_parser.cmi +src/flow.cmo: src/util.cmi src/sig.cmi src/flow.cmi +src/flow.cmx: src/util.cmx src/sig.cmi src/flow.cmi +src/gcoloring.cmo: src/traverse.cmi src/sig.cmi src/gcoloring.cmi +src/gcoloring.cmx: src/traverse.cmx src/sig.cmi src/gcoloring.cmi +src/gmap.cmo: src/sig.cmi src/gmap.cmi +src/gmap.cmx: src/sig.cmi src/gmap.cmi +src/gml.cmo: src/builder.cmi src/gml.cmi +src/gml.cmx: src/builder.cmx src/gml.cmi +src/gpath.cmo: src/util.cmi src/sig.cmi lib/heap.cmi src/gpath.cmi +src/gpath.cmx: src/util.cmx src/sig.cmi lib/heap.cmx src/gpath.cmi +src/graphviz.cmo: src/graphviz.cmi +src/graphviz.cmx: src/graphviz.cmi +src/imperative.cmo: src/sig.cmi src/blocks.cmo lib/bitv.cmi \ + src/imperative.cmi +src/imperative.cmx: src/sig.cmi src/blocks.cmx lib/bitv.cmx \ + src/imperative.cmi +src/kruskal.cmo: src/util.cmi lib/unionfind.cmi src/sig.cmi src/kruskal.cmi +src/kruskal.cmx: src/util.cmx lib/unionfind.cmx src/sig.cmi src/kruskal.cmi +src/mcs_m.cmo: src/util.cmi src/sig.cmi src/persistent.cmi src/oper.cmi \ + src/imperative.cmi src/gmap.cmi src/builder.cmi src/mcs_m.cmi +src/mcs_m.cmx: src/util.cmx src/sig.cmi src/persistent.cmx src/oper.cmx \ + src/imperative.cmx src/gmap.cmx src/builder.cmx src/mcs_m.cmi +src/md.cmo: src/sig.cmi src/oper.cmi src/gmap.cmi src/cliquetree.cmi \ + src/builder.cmi src/md.cmi +src/md.cmx: src/sig.cmi src/oper.cmx src/gmap.cmx src/cliquetree.cmx \ + src/builder.cmx src/md.cmi +src/minsep.cmo: src/sig.cmi src/oper.cmi src/components.cmi src/minsep.cmi +src/minsep.cmx: src/sig.cmi src/oper.cmx src/components.cmx src/minsep.cmi +src/oper.cmo: src/sig.cmi src/builder.cmi src/oper.cmi +src/oper.cmx: src/sig.cmi src/builder.cmx src/oper.cmi +src/pack.cmo: src/traverse.cmi src/topological.cmi src/sig.cmi src/rand.cmi \ + src/oper.cmi src/kruskal.cmi src/imperative.cmi src/graphviz.cmi \ + src/gpath.cmi src/gml.cmi src/flow.cmi src/dot.cmi src/components.cmi \ + src/classic.cmi src/builder.cmi src/pack.cmi +src/pack.cmx: src/traverse.cmx src/topological.cmx src/sig.cmi src/rand.cmx \ + src/oper.cmx src/kruskal.cmx src/imperative.cmx src/graphviz.cmx \ + src/gpath.cmx src/gml.cmx src/flow.cmx src/dot.cmx src/components.cmx \ + src/classic.cmx src/builder.cmx src/pack.cmi +src/persistent.cmo: src/util.cmi src/sig.cmi src/blocks.cmo \ + src/persistent.cmi +src/persistent.cmx: src/util.cmx src/sig.cmi src/blocks.cmx \ + src/persistent.cmi +src/rand.cmo: src/sig.cmi src/delaunay.cmi src/builder.cmi src/rand.cmi +src/rand.cmx: src/sig.cmi src/delaunay.cmx src/builder.cmx src/rand.cmi +src/strat.cmo: src/sig.cmi src/strat.cmi +src/strat.cmx: src/sig.cmi src/strat.cmi +src/topological.cmo: src/sig.cmi src/topological.cmi +src/topological.cmx: src/sig.cmi src/topological.cmi +src/traverse.cmo: src/sig.cmi src/traverse.cmi +src/traverse.cmx: src/sig.cmi src/traverse.cmi +src/util.cmo: src/sig.cmi src/util.cmi +src/util.cmx: src/sig.cmi src/util.cmi +src/version.cmo: +src/version.cmx: +src/builder.cmi: src/sig.cmi +src/classic.cmi: src/sig.cmi +src/cliquetree.cmi: src/sig.cmi +src/components.cmi: src/util.cmi src/sig.cmi +src/delaunay.cmi: +src/dot.cmi: src/dot_ast.cmi src/builder.cmi +src/dot_ast.cmi: +src/dot_parser.cmi: src/dot_ast.cmi +src/flow.cmi: src/sig.cmi +src/gcoloring.cmi: src/sig.cmi +src/gmap.cmi: src/sig.cmi +src/gml.cmi: src/builder.cmi +src/gpath.cmi: src/sig.cmi +src/graphviz.cmi: +src/imperative.cmi: src/sig.cmi +src/kruskal.cmi: src/sig.cmi +src/mcs_m.cmi: src/sig.cmi +src/md.cmi: src/sig.cmi +src/minsep.cmi: src/sig.cmi +src/oper.cmi: src/sig.cmi src/builder.cmi +src/pack.cmi: src/sig_pack.cmi +src/persistent.cmi: src/sig.cmi +src/rand.cmi: src/sig.cmi src/builder.cmi +src/sig.cmi: +src/sig_pack.cmi: +src/strat.cmi: src/sig.cmi +src/topological.cmi: src/sig.cmi +src/traverse.cmi: src/sig.cmi +src/util.cmi: src/sig.cmi +editor/ed_display.cmo: +editor/ed_display.cmx: +editor/ed_draw.cmo: src/components.cmi +editor/ed_draw.cmx: src/components.cmx +editor/ed_graph.cmo: src/traverse.cmi src/imperative.cmi src/graphviz.cmi \ + src/gml.cmi src/dot_ast.cmi src/dot.cmi src/components.cmi \ + src/builder.cmi +editor/ed_graph.cmx: src/traverse.cmx src/imperative.cmx src/graphviz.cmx \ + src/gml.cmx src/dot_ast.cmi src/dot.cmx src/components.cmx \ + src/builder.cmx +editor/ed_hyper.cmo: +editor/ed_hyper.cmx: +editor/ed_main.cmo: +editor/ed_main.cmx: diff --git a/external/ocamlgraph/META b/external/ocamlgraph/META new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/META @@ -0,0 +1,5 @@ +version = "0.99b" +description = "Generic Graph Library" +requires="" +archive(byte) = "graph.cma" +archive(native) = "graph.cmxa" diff --git a/external/ocamlgraph/META.in b/external/ocamlgraph/META.in new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/META.in @@ -0,0 +1,5 @@ +version = "VERSION" +description = "Generic Graph Library" +requires="" +archive(byte) = "CMA" +archive(native) = "CMXA" diff --git a/external/ocamlgraph/Makefile b/external/ocamlgraph/Makefile new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/Makefile @@ -0,0 +1,386 @@ +########################################################################## +# # +# Ocamlgraph: a generic graph library for OCaml # +# Copyright (C) 2004-2007 # +# Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles # +# # +# This software is free software; you can redistribute it and/or # +# modify it under the terms of the GNU Library General Public # +# License version 2, with the special exception on linking # +# described in file LICENSE. # +# # +# This software is distributed in the hope that it will be useful, # +# but WITHOUT ANY WARRANTY; without even the implied warranty of # +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. # +# # +########################################################################## + +# Where to install the binaries +prefix=/usr/local +exec_prefix=${prefix} +BINDIR=${exec_prefix}/bin + +# Where to install the man page +MANDIR=${prefix}/share/man + +# Other variables set by ./configure +OCAMLC = ocamlc +OCAMLOPT = ocamlopt +OCAMLDEP = ocamldep +OCAMLDOC = ocamldoc +OCAMLLEX = ocamllex +OCAMLYACC= ocamlyacc +OCAMLLIB = /usr/lib/ocaml +OCAMLBEST= opt +OCAMLVERSION = 3.12.1 +OCAMLWEB = true +OCAMLWIN32 = no +OCAMLFIND = +EXE = +LIBEXT = .a +OBJEXT = .o + +# Others global variables +SRCDIR = src +LIBDIR = lib + +INCLUDES= -I $(SRCDIR) -I $(LIBDIR) +BFLAGS = $(INCLUDES) +OFLAGS = $(INCLUDES) -for-pack Graph + +# main target +############# + +NAME=ocamlgraph + +all: byte $(OCAMLBEST) +#all: byte $(OCAMLBEST) editor-no + +# bytecode and native-code compilation +###################################### + +LIB= unionfind heap bitv +LIB:=$(patsubst %, $(LIBDIR)/%.cmo, $(LIB)) + +CMO = util blocks persistent imperative \ + delaunay builder classic rand oper \ + gpath traverse gcoloring topological components kruskal flow \ + graphviz gml dot_parser dot_lexer dot pack \ + gmap minsep cliquetree mcs_m md strat +CMO := $(LIB) $(patsubst %, $(SRCDIR)/%.cmo, $(CMO)) + +CMX = $(CMO:.cmo=.cmx) +CMA = graph.cma +CMXA = graph.cmxa + +CMI = sig dot_ast sig_pack +CMI := $(patsubst %, src/%.cmi, $(CMI)) + +GENERATED = META \ + src/gml.ml src/version.ml \ + src/dot_parser.ml src/dot_parser.mli src/dot_lexer.ml + +byte: $(CMA) +opt: $(CMXA) + +graph.cma: graph.cmo + $(OCAMLC) $(INCLUDES) -a -o $@ $^ + +graph.cmxa: graph.cmx + $(OCAMLOPT) $(INCLUDES) -a -o $@ $^ + +graph.cmo: $(CMI) $(CMO) + $(OCAMLC) $(INCLUDES) -pack -o $@ $^ + +graph.cmx: $(CMI) $(CMX) + $(OCAMLOPT) $(INCLUDES) -pack -o $@ $^ + +EXAMPLESBIN=bin/demo.$(OCAMLBEST) bin/demo_planar.$(OCAMLBEST) \ + bin/bench.$(OCAMLBEST) bin/color.$(OCAMLBEST) bin/sudoku.$(OCAMLBEST) \ + bin/test.$(OCAMLBEST) + +.PHONY: examples +examples: $(EXAMPLESBIN) + +.PHONY: demo +demo: bin/demo.$(OCAMLBEST) + +bin/demo.byte: $(CMA) examples/demo.cmo + $(OCAMLC) -o $@ $^ + +bin/demo.opt: $(CMXA) examples/demo.cmx + $(OCAMLOPT) -o $@ $^ + +bin/demo_planar.byte: $(CMA) examples/demo_planar.cmo + $(OCAMLC) -o $@ graphics.cma unix.cma $^ + +bin/demo_planar.opt: $(CMXA) examples/demo_planar.cmx + $(OCAMLOPT) -o $@ graphics.cmxa unix.cmxa $^ + +bin/color.byte: $(CMA) examples/color.cmo + $(OCAMLC) -o $@ graphics.cma unix.cma $^ + +bin/color.opt: $(CMXA) examples/color.cmx + $(OCAMLOPT) -o $@ graphics.cmxa unix.cmxa $^ + +bin/sudoku.byte: $(CMA) examples/sudoku.cmo + $(OCAMLC) -o $@ graphics.cma unix.cma $^ + +bin/sudoku.opt: $(CMXA) examples/sudoku.cmx + $(OCAMLOPT) -o $@ graphics.cmxa unix.cmxa $^ + +test: $(CMA) tests/test.ml + ocaml unix.cma graphics.cma $^ + +bin/test.byte: $(CMA) tests/test.cmo + $(OCAMLC) -g -unsafe -o $@ unix.cma graphics.cma $^ + +bin/test.opt: $(CMXA) tests/test.cmx + $(OCAMLOPT) -unsafe -inline 100 -o $@ unix.cmxa graphics.cmxa $^ + +bench: bin/bench.$(OCAMLBEST) + bin/bench.opt + +bin/bench.opt: $(CMXA) tests/bench.ml + $(OCAMLOPT) -unsafe -inline 100 -o $@ unix.cmxa $^ + +check: $(CMA) tests/check.ml + ocaml $^ + +# gtk2 graph editor + +ED_DIR=editor + +editor-no: +editor-yes: $(ED_DIR)/editor.$(OCAMLBEST) + +editor: $(ED_DIR)/editor.byte editor-yes + +ED_CMO = ed_hyper ed_graph ed_draw ed_display ed_main +ED_CMO:= $(patsubst %, $(ED_DIR)/%.cmo, $(ED_CMO)) +ED_CMX = $(ED_CMO:.cmo=.cmx) + +ED_INCLUDES = -I +threads -I $(ED_DIR) + +$(ED_CMO): BFLAGS+= $(ED_INCLUDES) +$(ED_CMX): OFLAGS+= $(ED_INCLUDES) + +$(ED_DIR)/editor.byte: $(CMA) $(ED_CMO) + $(OCAMLC) -g -o $@ \ + lablgtk.cma lablgnomecanvas.cma unix.cma $^ + +$(ED_DIR)/editor.opt: $(CMXA) $(ED_CMX) + $(OCAMLOPT) -o $@ \ + lablgtk.cmxa lablgnomecanvas.cmxa unix.cmxa $^ + +VERSION=0.99b + +src/version.ml: Makefile + echo "let version = \""$(VERSION)"\"" > $@ + echo "let date = \""`date`"\"" >> $@ + +META: META.in Makefile + sed -e s/VERSION/$(VERSION)/ -e s/CMA/$(CMA)/ -e s/CMXA/$(CMXA)/ \ + $@.in > $@ + +# Additional rules +################## + +EXAMPLES = demo color demo_planar sudoku +EXAMPLES:= $(patsubst %, examples/%.ml, $(EXAMPLES)) + +TESTS = test check +TESTS := $(patsubst %, tests/%.ml, $(TESTS)) + +DPD_GRAPH_ML= $(TESTS) $(EXAMPLES) + +$(DPD_GRAPH_ML:.ml=.cmo): $(CMA) +$(DPD_GRAPH_ML:.ml=.cmx): $(CMXA) + +# installation +############## + +install: install-$(OCAMLBEST) install-byte + +install-byte: + cp -f graph.cmo graph.cmi $(CMA) "$(OCAMLLIB)" + +install-opt: install-byte + cp -f graph$(LIBEXT) graph.cmx $(CMXA) "$(OCAMLLIB)" + +install-findlib: META +ifdef OCAMLFIND + $(OCAMLFIND) install ocamlgraph META *.mli \ + graph$(LIBEXT) graph.cmx graph.cmo graph.cmi $(CMA) $(CMXA) +endif + +# documentation +############### + +DOCFILES=$(NAME).ps $(NAME).html + +NODOC = util blocks dot_parser dot_lexer +NODOC := $(patsubst %, $(SRCDIR)/%.cmo, $(NODOC)) +DOC_CMO = $(filter-out $(NODOC) $(LIB), $(CMO)) +DOC_SRC = $(CMI:.cmi=.mli) $(DOC_CMO:.cmo=.mli) $(DOC_CMO:.cmo=.ml) + +.PHONY: doc +doc: $(DOC_CMO) + mkdir -p doc + rm -f doc/* + $(OCAMLDOC) -d doc -html $(INCLUDES) $(DOC_SRC) + +# literate programming +$(NAME).tex: $(DOC_SRC) + $(OCAMLWEB) -o $@ $^ + +wc: + ocamlwc -p $(SRCDIRC)/*.mli $(SRCDIRC)/*.ml + +# file headers +############## +headers: + headache -c misc/headache_config.txt -h misc/header.txt \ + Makefile.in configure.in README \ + $(LIBDIR)*.ml $(LIBDIR)*.ml[ily] \ + $(SRCDIR)*.ml $(SRCDIR)*.ml[ily] \ + $(ED_DIR)/*.ml $(ED_DIR)/*.mli \ + +# export +######## + +EXPORTDIR=$(NAME)-$(VERSION) +TAR=$(EXPORTDIR).tar + +FTP = $$HOME/ftp/$(NAME) +WWW = $$HOME/WWW/$(NAME) + +FILES = src/*.ml* lib/*.ml* Makefile.in configure configure.in META.in \ + .depend editor/ed_*.ml* editor/Makefile \ + editor/tests/*.dot editor/tests/*.gml \ + examples/*.ml tests/*.ml \ + .depend README FAQ CREDITS INSTALL COPYING LICENSE CHANGES + +export: source export-doc export-web export-delaunay + +source: + mkdir -p export + cd export; rm -rf $(EXPORTDIR) + mkdir -p export/$(EXPORTDIR)/bin + cp --parents $(FILES) export/$(EXPORTDIR) + cd export ; tar cf $(TAR) $(EXPORTDIR) ; gzip -f --best $(TAR) + cp export/$(TAR).gz $(FTP) + cp README FAQ CREDITS COPYING LICENSE CHANGES $(EXAMPLES) $(FTP) + +www/version.prehtml: Makefile.in + echo "<#def version>$(VERSION)" > www/version.prehtml + +export-web: www/version.prehtml + make -C www install + +export-doc: $(DOC_CMO) + rm -f $(WWW)/doc/* + -$(OCAMLDOC) -d $(WWW)/doc -html $(INCLUDES) $(DOC_SRC) + +MISCFTP = $(HOME)/WWW/ftp/ocaml/misc +DELAUNAY=delaunay.ml delaunay.mli +export-delaunay: + cd src; cp -f $(DELAUNAY) $(MISCFTP) + cd src; caml2html -d $(MISCFTP) $(DELAUNAY) + +# generic rules +############### + +.SUFFIXES: .mli .ml .cmi .cmo .cmx .mll .mly .tex .dvi .ps .html + +.mli.cmi: + $(OCAMLC) -c $(BFLAGS) $< + +.ml.cmo: + $(OCAMLC) -c $(BFLAGS) $< + +.ml.o: + $(OCAMLOPT) -c $(OFLAGS) $< + +.ml.cmx: + $(OCAMLOPT) -c $(OFLAGS) $< + +.mll.ml: + $(OCAMLLEX) $< + +.mly.ml: + $(OCAMLYACC) -v $< + +.mly.mli: + $(OCAMLYACC) -v $< + +.tex.dvi: + latex $< && latex $< + +.dvi.ps: + dvips $< -o $@ + +.tex.html: + hevea $< + +# Emacs tags +############ + +otags: + otags -r src editor + +tags: + find . -name "*.ml*" | sort -r | xargs \ + etags "--regex=/let[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/and[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/type[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/exception[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/val[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/module[ \t]+\([^ \t]+\)/\1/" + +# Makefile is rebuilt whenever Makefile.in or configure.in is modified +###################################################################### + +Makefile: Makefile.in config.status + if test -e $@; then chmod a+w $@; fi + ./config.status + chmod a-w $@ + +config.status: configure + ./config.status --recheck + +configure: configure.in + autoconf + +# clean +####### + +clean: + rm -f *~ + for d in $(SRCDIR) $(LIBDIR) $(ED_DIR) tests examples; do \ + rm -f $$d/*.cm[iox] $$d/*$(OBJEXT) $$d/*~; \ + done + rm -f $(GENERATED) $(SRCDIR)/dot_parser.output + rm -f graph.*a graph$(LIBEXT) bin/$(NAME).byte bin/$(NAME).opt + rm -f *.haux *.aux *.log $(NAME).tex $(NAME).dvi $(DOCFILES) + rm -f $(EXAMPLESBIN) + +dist-clean distclean:: clean + rm -f Makefile config.cache config.log config.status *.byte *.opt + +svnclean svn-clean:: dist-clean + rm -f config.* configure configure.lineno + +# depend +######## + +.PHONY: depend +.depend depend: $(GENERATED) + rm -f .depend + $(OCAMLDEP) $(INCLUDES) \ + $(LIBDIR)/*.ml $(LIBDIR)/*.mli \ + $(SRCDIR)/*.ml $(SRCDIR)/*.mli \ + $(ED_DIR)/*.mli $(ED_DIR)/*.ml > .depend + +include .depend diff --git a/external/ocamlgraph/Makefile.in b/external/ocamlgraph/Makefile.in new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/Makefile.in @@ -0,0 +1,386 @@ +########################################################################## +# # +# Ocamlgraph: a generic graph library for OCaml # +# Copyright (C) 2004-2007 # +# Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles # +# # +# This software is free software; you can redistribute it and/or # +# modify it under the terms of the GNU Library General Public # +# License version 2, with the special exception on linking # +# described in file LICENSE. # +# # +# This software is distributed in the hope that it will be useful, # +# but WITHOUT ANY WARRANTY; without even the implied warranty of # +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. # +# # +########################################################################## + +# Where to install the binaries +prefix=@prefix@ +exec_prefix=@exec_prefix@ +BINDIR=@bindir@ + +# Where to install the man page +MANDIR=@mandir@ + +# Other variables set by ./configure +OCAMLC = @OCAMLC@ +OCAMLOPT = @OCAMLOPT@ +OCAMLDEP = @OCAMLDEP@ +OCAMLDOC = @OCAMLDOC@ +OCAMLLEX = @OCAMLLEX@ +OCAMLYACC= @OCAMLYACC@ +OCAMLLIB = @OCAMLLIB@ +OCAMLBEST= @OCAMLBEST@ +OCAMLVERSION = @OCAMLVERSION@ +OCAMLWEB = @OCAMLWEB@ +OCAMLWIN32 = @OCAMLWIN32@ +OCAMLFIND = @OCAMLFIND@ +EXE = @EXE@ +LIBEXT = @LIBEXT@ +OBJEXT = @OBJEXT@ + +# Others global variables +SRCDIR = src +LIBDIR = lib + +INCLUDES= -I $(SRCDIR) -I $(LIBDIR) +BFLAGS = $(INCLUDES) +OFLAGS = $(INCLUDES) @FORPACK@ + +# main target +############# + +NAME=ocamlgraph + +all: byte $(OCAMLBEST) +#all: byte $(OCAMLBEST) editor-@LABLGTK2@ + +# bytecode and native-code compilation +###################################### + +LIB= unionfind heap bitv +LIB:=$(patsubst %, $(LIBDIR)/%.cmo, $(LIB)) + +CMO = util blocks persistent imperative \ + delaunay builder classic rand oper \ + gpath traverse gcoloring topological components kruskal flow \ + graphviz gml dot_parser dot_lexer dot pack \ + gmap minsep cliquetree mcs_m md strat +CMO := $(LIB) $(patsubst %, $(SRCDIR)/%.cmo, $(CMO)) + +CMX = $(CMO:.cmo=.cmx) +CMA = graph.cma +CMXA = graph.cmxa + +CMI = sig dot_ast sig_pack +CMI := $(patsubst %, src/%.cmi, $(CMI)) + +GENERATED = META \ + src/gml.ml src/version.ml \ + src/dot_parser.ml src/dot_parser.mli src/dot_lexer.ml + +byte: $(CMA) +opt: $(CMXA) + +graph.cma: graph.cmo + $(OCAMLC) $(INCLUDES) -a -o $@ $^ + +graph.cmxa: graph.cmx + $(OCAMLOPT) $(INCLUDES) -a -o $@ $^ + +graph.cmo: $(CMI) $(CMO) + $(OCAMLC) $(INCLUDES) -pack -o $@ $^ + +graph.cmx: $(CMI) $(CMX) + $(OCAMLOPT) $(INCLUDES) -pack -o $@ $^ + +EXAMPLESBIN=bin/demo.$(OCAMLBEST) bin/demo_planar.$(OCAMLBEST) \ + bin/bench.$(OCAMLBEST) bin/color.$(OCAMLBEST) bin/sudoku.$(OCAMLBEST) \ + bin/test.$(OCAMLBEST) + +.PHONY: examples +examples: $(EXAMPLESBIN) + +.PHONY: demo +demo: bin/demo.$(OCAMLBEST) + +bin/demo.byte: $(CMA) examples/demo.cmo + $(OCAMLC) -o $@ $^ + +bin/demo.opt: $(CMXA) examples/demo.cmx + $(OCAMLOPT) -o $@ $^ + +bin/demo_planar.byte: $(CMA) examples/demo_planar.cmo + $(OCAMLC) -o $@ graphics.cma unix.cma $^ + +bin/demo_planar.opt: $(CMXA) examples/demo_planar.cmx + $(OCAMLOPT) -o $@ graphics.cmxa unix.cmxa $^ + +bin/color.byte: $(CMA) examples/color.cmo + $(OCAMLC) -o $@ graphics.cma unix.cma $^ + +bin/color.opt: $(CMXA) examples/color.cmx + $(OCAMLOPT) -o $@ graphics.cmxa unix.cmxa $^ + +bin/sudoku.byte: $(CMA) examples/sudoku.cmo + $(OCAMLC) -o $@ graphics.cma unix.cma $^ + +bin/sudoku.opt: $(CMXA) examples/sudoku.cmx + $(OCAMLOPT) -o $@ graphics.cmxa unix.cmxa $^ + +test: $(CMA) tests/test.ml + ocaml unix.cma graphics.cma $^ + +bin/test.byte: $(CMA) tests/test.cmo + $(OCAMLC) -g -unsafe -o $@ unix.cma graphics.cma $^ + +bin/test.opt: $(CMXA) tests/test.cmx + $(OCAMLOPT) -unsafe -inline 100 -o $@ unix.cmxa graphics.cmxa $^ + +bench: bin/bench.$(OCAMLBEST) + bin/bench.opt + +bin/bench.opt: $(CMXA) tests/bench.ml + $(OCAMLOPT) -unsafe -inline 100 -o $@ unix.cmxa $^ + +check: $(CMA) tests/check.ml + ocaml $^ + +# gtk2 graph editor + +ED_DIR=editor + +editor-no: +editor-yes: $(ED_DIR)/editor.$(OCAMLBEST) + +editor: $(ED_DIR)/editor.byte editor-yes + +ED_CMO = ed_hyper ed_graph ed_draw ed_display ed_main +ED_CMO:= $(patsubst %, $(ED_DIR)/%.cmo, $(ED_CMO)) +ED_CMX = $(ED_CMO:.cmo=.cmx) + +ED_INCLUDES = @INCLUDEGTK2@ -I +threads -I $(ED_DIR) + +$(ED_CMO): BFLAGS+= $(ED_INCLUDES) +$(ED_CMX): OFLAGS+= $(ED_INCLUDES) + +$(ED_DIR)/editor.byte: $(CMA) $(ED_CMO) + $(OCAMLC) -g -o $@ @INCLUDEGTK2@ \ + lablgtk.cma lablgnomecanvas.cma unix.cma $^ + +$(ED_DIR)/editor.opt: $(CMXA) $(ED_CMX) + $(OCAMLOPT) -o $@ @INCLUDEGTK2@ \ + lablgtk.cmxa lablgnomecanvas.cmxa unix.cmxa $^ + +VERSION=0.99b + +src/version.ml: Makefile + echo "let version = \""$(VERSION)"\"" > $@ + echo "let date = \""`date`"\"" >> $@ + +META: META.in Makefile + sed -e s/VERSION/$(VERSION)/ -e s/CMA/$(CMA)/ -e s/CMXA/$(CMXA)/ \ + $@.in > $@ + +# Additional rules +################## + +EXAMPLES = demo color demo_planar sudoku +EXAMPLES:= $(patsubst %, examples/%.ml, $(EXAMPLES)) + +TESTS = test check +TESTS := $(patsubst %, tests/%.ml, $(TESTS)) + +DPD_GRAPH_ML= $(TESTS) $(EXAMPLES) + +$(DPD_GRAPH_ML:.ml=.cmo): $(CMA) +$(DPD_GRAPH_ML:.ml=.cmx): $(CMXA) + +# installation +############## + +install: install-$(OCAMLBEST) install-byte + +install-byte: + cp -f graph.cmo graph.cmi $(CMA) "$(OCAMLLIB)" + +install-opt: install-byte + cp -f graph$(LIBEXT) graph.cmx $(CMXA) "$(OCAMLLIB)" + +install-findlib: META +ifdef OCAMLFIND + $(OCAMLFIND) install ocamlgraph META *.mli \ + graph$(LIBEXT) graph.cmx graph.cmo graph.cmi $(CMA) $(CMXA) +endif + +# documentation +############### + +DOCFILES=$(NAME).ps $(NAME).html + +NODOC = util blocks dot_parser dot_lexer +NODOC := $(patsubst %, $(SRCDIR)/%.cmo, $(NODOC)) +DOC_CMO = $(filter-out $(NODOC) $(LIB), $(CMO)) +DOC_SRC = $(CMI:.cmi=.mli) $(DOC_CMO:.cmo=.mli) $(DOC_CMO:.cmo=.ml) + +.PHONY: doc +doc: $(DOC_CMO) + mkdir -p doc + rm -f doc/* + $(OCAMLDOC) -d doc -html $(INCLUDES) $(DOC_SRC) + +# literate programming +$(NAME).tex: $(DOC_SRC) + $(OCAMLWEB) -o $@ $^ + +wc: + ocamlwc -p $(SRCDIRC)/*.mli $(SRCDIRC)/*.ml + +# file headers +############## +headers: + headache -c misc/headache_config.txt -h misc/header.txt \ + Makefile.in configure.in README \ + $(LIBDIR)*.ml $(LIBDIR)*.ml[ily] \ + $(SRCDIR)*.ml $(SRCDIR)*.ml[ily] \ + $(ED_DIR)/*.ml $(ED_DIR)/*.mli \ + +# export +######## + +EXPORTDIR=$(NAME)-$(VERSION) +TAR=$(EXPORTDIR).tar + +FTP = $$HOME/ftp/$(NAME) +WWW = $$HOME/WWW/$(NAME) + +FILES = src/*.ml* lib/*.ml* Makefile.in configure configure.in META.in \ + .depend editor/ed_*.ml* editor/Makefile \ + editor/tests/*.dot editor/tests/*.gml \ + examples/*.ml tests/*.ml \ + .depend README FAQ CREDITS INSTALL COPYING LICENSE CHANGES + +export: source export-doc export-web export-delaunay + +source: + mkdir -p export + cd export; rm -rf $(EXPORTDIR) + mkdir -p export/$(EXPORTDIR)/bin + cp --parents $(FILES) export/$(EXPORTDIR) + cd export ; tar cf $(TAR) $(EXPORTDIR) ; gzip -f --best $(TAR) + cp export/$(TAR).gz $(FTP) + cp README FAQ CREDITS COPYING LICENSE CHANGES $(EXAMPLES) $(FTP) + +www/version.prehtml: Makefile.in + echo "<#def version>$(VERSION)" > www/version.prehtml + +export-web: www/version.prehtml + make -C www install + +export-doc: $(DOC_CMO) + rm -f $(WWW)/doc/* + -$(OCAMLDOC) -d $(WWW)/doc -html $(INCLUDES) $(DOC_SRC) + +MISCFTP = $(HOME)/WWW/ftp/ocaml/misc +DELAUNAY=delaunay.ml delaunay.mli +export-delaunay: + cd src; cp -f $(DELAUNAY) $(MISCFTP) + cd src; caml2html -d $(MISCFTP) $(DELAUNAY) + +# generic rules +############### + +.SUFFIXES: .mli .ml .cmi .cmo .cmx .mll .mly .tex .dvi .ps .html + +.mli.cmi: + $(OCAMLC) -c $(BFLAGS) $< + +.ml.cmo: + $(OCAMLC) -c $(BFLAGS) $< + +.ml.o: + $(OCAMLOPT) -c $(OFLAGS) $< + +.ml.cmx: + $(OCAMLOPT) -c $(OFLAGS) $< + +.mll.ml: + $(OCAMLLEX) $< + +.mly.ml: + $(OCAMLYACC) -v $< + +.mly.mli: + $(OCAMLYACC) -v $< + +.tex.dvi: + latex $< && latex $< + +.dvi.ps: + dvips $< -o $@ + +.tex.html: + hevea $< + +# Emacs tags +############ + +otags: + otags -r src editor + +tags: + find . -name "*.ml*" | sort -r | xargs \ + etags "--regex=/let[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/and[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/type[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/exception[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/val[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/module[ \t]+\([^ \t]+\)/\1/" + +# Makefile is rebuilt whenever Makefile.in or configure.in is modified +###################################################################### + +Makefile: Makefile.in config.status + if test -e $@; then chmod a+w $@; fi + ./config.status + chmod a-w $@ + +config.status: configure + ./config.status --recheck + +configure: configure.in + autoconf + +# clean +####### + +clean: + rm -f *~ + for d in $(SRCDIR) $(LIBDIR) $(ED_DIR) tests examples; do \ + rm -f $$d/*.cm[iox] $$d/*$(OBJEXT) $$d/*~; \ + done + rm -f $(GENERATED) $(SRCDIR)/dot_parser.output + rm -f graph.*a graph$(LIBEXT) bin/$(NAME).byte bin/$(NAME).opt + rm -f *.haux *.aux *.log $(NAME).tex $(NAME).dvi $(DOCFILES) + rm -f $(EXAMPLESBIN) + +dist-clean distclean:: clean + rm -f Makefile config.cache config.log config.status *.byte *.opt + +svnclean svn-clean:: dist-clean + rm -f config.* configure configure.lineno + +# depend +######## + +.PHONY: depend +.depend depend: $(GENERATED) + rm -f .depend + $(OCAMLDEP) $(INCLUDES) \ + $(LIBDIR)/*.ml $(LIBDIR)/*.mli \ + $(SRCDIR)/*.ml $(SRCDIR)/*.mli \ + $(ED_DIR)/*.mli $(ED_DIR)/*.ml > .depend + +include .depend diff --git a/external/ocamlgraph/configure b/external/ocamlgraph/configure new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/configure @@ -0,0 +1,3485 @@ +#! /bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated by GNU Autoconf 2.68. +# +# +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, +# 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software +# Foundation, Inc. +# +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + +as_nl=' +' +export as_nl +# Printing a long string crashes Solaris 7 /usr/bin/printf. +as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='printf %s\n' + as_echo_n='printf %s' +else + if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then + as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' + as_echo_n='/usr/ucb/echo -n' + else + as_echo_body='eval expr "X$1" : "X\\(.*\\)"' + as_echo_n_body='eval + arg=$1; + case $arg in #( + *"$as_nl"*) + expr "X$arg" : "X\\(.*\\)$as_nl"; + arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; + esac; + expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" + ' + export as_echo_n_body + as_echo_n='sh -c $as_echo_n_body as_echo' + fi + export as_echo_body + as_echo='sh -c $as_echo_body as_echo' +fi + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + +if test "x$CONFIG_SHELL" = x; then + as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which + # is contrary to our usage. Disable this feature. + alias -g '\${1+\"\$@\"}'='\"\$@\"' + setopt NO_GLOB_SUBST +else + case \`(set -o) 2>/dev/null\` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi +" + as_required="as_fn_return () { (exit \$1); } +as_fn_success () { as_fn_return 0; } +as_fn_failure () { as_fn_return 1; } +as_fn_ret_success () { return 0; } +as_fn_ret_failure () { return 1; } + +exitcode=0 +as_fn_success || { exitcode=1; echo as_fn_success failed.; } +as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } +as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } +as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } +if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : + +else + exitcode=1; echo positional parameters were not saved. +fi +test x\$exitcode = x0 || exit 1" + as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO + as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO + eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && + test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" + if (eval "$as_required") 2>/dev/null; then : + as_have_required=yes +else + as_have_required=no +fi + if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : + +else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_found=false +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + as_found=: + case $as_dir in #( + /*) + for as_base in sh bash ksh sh5; do + # Try only shells that exist, to save several forks. + as_shell=$as_dir/$as_base + if { test -f "$as_shell" || test -f "$as_shell.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : + CONFIG_SHELL=$as_shell as_have_required=yes + if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : + break 2 +fi +fi + done;; + esac + as_found=false +done +$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : + CONFIG_SHELL=$SHELL as_have_required=yes +fi; } +IFS=$as_save_IFS + + + if test "x$CONFIG_SHELL" != x; then : + # We cannot yet assume a decent shell, so we have to provide a + # neutralization value for shells without unset; and this also + # works around shells that cannot unset nonexistent variables. + # Preserve -v and -x to the replacement shell. + BASH_ENV=/dev/null + ENV=/dev/null + (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV + export CONFIG_SHELL + case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; + esac + exec "$CONFIG_SHELL" $as_opts "$as_myself" ${1+"$@"} +fi + + if test x$as_have_required = xno; then : + $as_echo "$0: This script requires a shell more modern than all" + $as_echo "$0: the shells that I found on your system." + if test x${ZSH_VERSION+set} = xset ; then + $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" + $as_echo "$0: be upgraded to zsh 4.3.4 or later." + else + $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, +$0: including any error possibly output before this +$0: message. Then install a modern shell, or manually run +$0: the script under such a shell if you do have one." + fi + exit 1 +fi +fi +fi +SHELL=${CONFIG_SHELL-/bin/sh} +export SHELL +# Unset more variables known to interfere with behavior of common tools. +CLICOLOR_FORCE= GREP_OPTIONS= +unset CLICOLOR_FORCE GREP_OPTIONS + +## --------------------- ## +## M4sh Shell Functions. ## +## --------------------- ## +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + + + as_lineno_1=$LINENO as_lineno_1a=$LINENO + as_lineno_2=$LINENO as_lineno_2a=$LINENO + eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && + test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { + # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) + sed -n ' + p + /[$]LINENO/= + ' <$as_myself | + sed ' + s/[$]LINENO.*/&-/ + t lineno + b + :lineno + N + :loop + s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ + t loop + s/-\n.*// + ' >$as_me.lineno && + chmod +x "$as_me.lineno" || + { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } + + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensitive to this). + . "./$as_me.lineno" + # Exit status is that of the last command. + exit +} + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -p'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -p' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -p' + fi +else + as_ln_s='cp -p' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + +if test -x / >/dev/null 2>&1; then + as_test_x='test -x' +else + if ls -dL / >/dev/null 2>&1; then + as_ls_L_option=L + else + as_ls_L_option= + fi + as_test_x=' + eval sh -c '\'' + if test -d "$1"; then + test -d "$1/."; + else + case $1 in #( + -*)set "./$1";; + esac; + case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( + ???[sx]*):;;*)false;;esac;fi + '\'' sh + ' +fi +as_executable_p=$as_test_x + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +test -n "$DJDIR" || exec 7<&0 &1 + +# Name of the host. +# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, +# so uname gets run too. +ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` + +# +# Initializations. +# +ac_default_prefix=/usr/local +ac_clean_files= +ac_config_libobj_dir=. +LIBOBJS= +cross_compiling=no +subdirs= +MFLAGS= +MAKEFLAGS= + +# Identity of this package. +PACKAGE_NAME= +PACKAGE_TARNAME= +PACKAGE_VERSION= +PACKAGE_STRING= +PACKAGE_BUGREPORT= +PACKAGE_URL= + +ac_unique_file="src/sig.mli" +ac_subst_vars='LTLIBOBJS +LIBOBJS +INCLUDEGTK2 +FORPACK +OBJEXT +LIBEXT +EXE +OCAMLWIN32 +OCAMLLIB +OCAMLVERSION +OCAMLBEST +LABLGTK2 +OCAMLFIND +OCAMLWEB +OCAMLDOCOPT +OCAMLDOC +OCAMLYACC +OCAMLLEXDOTOPT +OCAMLLEX +OCAMLDEP +OCAMLOPTDOTOPT +OCAMLCDOTOPT +OCAMLOPT +OCAMLC +target_alias +host_alias +build_alias +LIBS +ECHO_T +ECHO_N +ECHO_C +DEFS +mandir +localedir +libdir +psdir +pdfdir +dvidir +htmldir +infodir +docdir +oldincludedir +includedir +localstatedir +sharedstatedir +sysconfdir +datadir +datarootdir +libexecdir +sbindir +bindir +program_transform_name +prefix +exec_prefix +PACKAGE_URL +PACKAGE_BUGREPORT +PACKAGE_STRING +PACKAGE_VERSION +PACKAGE_TARNAME +PACKAGE_NAME +PATH_SEPARATOR +SHELL' +ac_subst_files='' +ac_user_opts=' +enable_option_checking +' + ac_precious_vars='build_alias +host_alias +target_alias' + + +# Initialize some variables set by options. +ac_init_help= +ac_init_version=false +ac_unrecognized_opts= +ac_unrecognized_sep= +# The variables have the same names as the options, with +# dashes changed to underlines. +cache_file=/dev/null +exec_prefix=NONE +no_create= +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +verbose= +x_includes=NONE +x_libraries=NONE + +# Installation directory options. +# These are left unexpanded so users can "make install exec_prefix=/foo" +# and all the variables that are supposed to be based on exec_prefix +# by default will actually change. +# Use braces instead of parens because sh, perl, etc. also accept them. +# (The list follows the same order as the GNU Coding Standards.) +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datarootdir='${prefix}/share' +datadir='${datarootdir}' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +includedir='${prefix}/include' +oldincludedir='/usr/include' +docdir='${datarootdir}/doc/${PACKAGE}' +infodir='${datarootdir}/info' +htmldir='${docdir}' +dvidir='${docdir}' +pdfdir='${docdir}' +psdir='${docdir}' +libdir='${exec_prefix}/lib' +localedir='${datarootdir}/locale' +mandir='${datarootdir}/man' + +ac_prev= +ac_dashdash= +for ac_option +do + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval $ac_prev=\$ac_option + ac_prev= + continue + fi + + case $ac_option in + *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; + *=) ac_optarg= ;; + *) ac_optarg=yes ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case $ac_dashdash$ac_option in + --) + ac_dashdash=yes ;; + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir=$ac_optarg ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build_alias ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build_alias=$ac_optarg ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file=$ac_optarg ;; + + --config-cache | -C) + cache_file=config.cache ;; + + -datadir | --datadir | --datadi | --datad) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=*) + datadir=$ac_optarg ;; + + -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ + | --dataroo | --dataro | --datar) + ac_prev=datarootdir ;; + -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ + | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) + datarootdir=$ac_optarg ;; + + -disable-* | --disable-*) + ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=no ;; + + -docdir | --docdir | --docdi | --doc | --do) + ac_prev=docdir ;; + -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) + docdir=$ac_optarg ;; + + -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) + ac_prev=dvidir ;; + -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) + dvidir=$ac_optarg ;; + + -enable-* | --enable-*) + ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=\$ac_optarg ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix=$ac_optarg ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he | -h) + ac_init_help=long ;; + -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) + ac_init_help=recursive ;; + -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) + ac_init_help=short ;; + + -host | --host | --hos | --ho) + ac_prev=host_alias ;; + -host=* | --host=* | --hos=* | --ho=*) + host_alias=$ac_optarg ;; + + -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) + ac_prev=htmldir ;; + -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ + | --ht=*) + htmldir=$ac_optarg ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir=$ac_optarg ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir=$ac_optarg ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir=$ac_optarg ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir=$ac_optarg ;; + + -localedir | --localedir | --localedi | --localed | --locale) + ac_prev=localedir ;; + -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) + localedir=$ac_optarg ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst | --locals) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) + localstatedir=$ac_optarg ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir=$ac_optarg ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c | -n) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir=$ac_optarg ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix=$ac_optarg ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix=$ac_optarg ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix=$ac_optarg ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name=$ac_optarg ;; + + -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) + ac_prev=pdfdir ;; + -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) + pdfdir=$ac_optarg ;; + + -psdir | --psdir | --psdi | --psd | --ps) + ac_prev=psdir ;; + -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) + psdir=$ac_optarg ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir=$ac_optarg ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir=$ac_optarg ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site=$ac_optarg ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir=$ac_optarg ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir=$ac_optarg ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target_alias ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target_alias=$ac_optarg ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers | -V) + ac_init_version=: ;; + + -with-* | --with-*) + ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=\$ac_optarg ;; + + -without-* | --without-*) + ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=no ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes=$ac_optarg ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries=$ac_optarg ;; + + -*) as_fn_error $? "unrecognized option: \`$ac_option' +Try \`$0 --help' for more information" + ;; + + *=*) + ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` + # Reject names that are not valid shell variable names. + case $ac_envvar in #( + '' | [0-9]* | *[!_$as_cr_alnum]* ) + as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; + esac + eval $ac_envvar=\$ac_optarg + export $ac_envvar ;; + + *) + # FIXME: should be removed in autoconf 3.0. + $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 + expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && + $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 + : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" + ;; + + esac +done + +if test -n "$ac_prev"; then + ac_option=--`echo $ac_prev | sed 's/_/-/g'` + as_fn_error $? "missing argument to $ac_option" +fi + +if test -n "$ac_unrecognized_opts"; then + case $enable_option_checking in + no) ;; + fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; + *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; + esac +fi + +# Check all directory arguments for consistency. +for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ + datadir sysconfdir sharedstatedir localstatedir includedir \ + oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ + libdir localedir mandir +do + eval ac_val=\$$ac_var + # Remove trailing slashes. + case $ac_val in + */ ) + ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` + eval $ac_var=\$ac_val;; + esac + # Be sure to have absolute directory names. + case $ac_val in + [\\/$]* | ?:[\\/]* ) continue;; + NONE | '' ) case $ac_var in *prefix ) continue;; esac;; + esac + as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" +done + +# There might be people who depend on the old broken behavior: `$host' +# used to hold the argument of --host etc. +# FIXME: To remove some day. +build=$build_alias +host=$host_alias +target=$target_alias + +# FIXME: To remove some day. +if test "x$host_alias" != x; then + if test "x$build_alias" = x; then + cross_compiling=maybe + $as_echo "$as_me: WARNING: if you wanted to set the --build type, don't use --host. + If a cross compiler is detected then cross compile mode will be used" >&2 + elif test "x$build_alias" != "x$host_alias"; then + cross_compiling=yes + fi +fi + +ac_tool_prefix= +test -n "$host_alias" && ac_tool_prefix=$host_alias- + +test "$silent" = yes && exec 6>/dev/null + + +ac_pwd=`pwd` && test -n "$ac_pwd" && +ac_ls_di=`ls -di .` && +ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || + as_fn_error $? "working directory cannot be determined" +test "X$ac_ls_di" = "X$ac_pwd_ls_di" || + as_fn_error $? "pwd does not report name of working directory" + + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then the parent directory. + ac_confdir=`$as_dirname -- "$as_myself" || +$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_myself" : 'X\(//\)[^/]' \| \ + X"$as_myself" : 'X\(//\)$' \| \ + X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_myself" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + srcdir=$ac_confdir + if test ! -r "$srcdir/$ac_unique_file"; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r "$srcdir/$ac_unique_file"; then + test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." + as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" +fi +ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" +ac_abs_confdir=`( + cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" + pwd)` +# When building in place, set srcdir=. +if test "$ac_abs_confdir" = "$ac_pwd"; then + srcdir=. +fi +# Remove unnecessary trailing slashes from srcdir. +# Double slashes in file names in object file debugging info +# mess up M-x gdb in Emacs. +case $srcdir in +*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; +esac +for ac_var in $ac_precious_vars; do + eval ac_env_${ac_var}_set=\${${ac_var}+set} + eval ac_env_${ac_var}_value=\$${ac_var} + eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} + eval ac_cv_env_${ac_var}_value=\$${ac_var} +done + +# +# Report the --help message. +# +if test "$ac_init_help" = "long"; then + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat <<_ACEOF +\`configure' configures this package to adapt to many kinds of systems. + +Usage: $0 [OPTION]... [VAR=VALUE]... + +To assign environment variables (e.g., CC, CFLAGS...), specify them as +VAR=VALUE. See below for descriptions of some of the useful variables. + +Defaults for the options are specified in brackets. + +Configuration: + -h, --help display this help and exit + --help=short display options specific to this package + --help=recursive display the short help of all the included packages + -V, --version display version information and exit + -q, --quiet, --silent do not print \`checking ...' messages + --cache-file=FILE cache test results in FILE [disabled] + -C, --config-cache alias for \`--cache-file=config.cache' + -n, --no-create do not create output files + --srcdir=DIR find the sources in DIR [configure dir or \`..'] + +Installation directories: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [PREFIX] + +By default, \`make install' will install all the files in +\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify +an installation prefix other than \`$ac_default_prefix' using \`--prefix', +for instance \`--prefix=\$HOME'. + +For better control, use the options below. + +Fine tuning of the installation directories: + --bindir=DIR user executables [EPREFIX/bin] + --sbindir=DIR system admin executables [EPREFIX/sbin] + --libexecdir=DIR program executables [EPREFIX/libexec] + --sysconfdir=DIR read-only single-machine data [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] + --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --libdir=DIR object code libraries [EPREFIX/lib] + --includedir=DIR C header files [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc [/usr/include] + --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] + --datadir=DIR read-only architecture-independent data [DATAROOTDIR] + --infodir=DIR info documentation [DATAROOTDIR/info] + --localedir=DIR locale-dependent data [DATAROOTDIR/locale] + --mandir=DIR man documentation [DATAROOTDIR/man] + --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] + --htmldir=DIR html documentation [DOCDIR] + --dvidir=DIR dvi documentation [DOCDIR] + --pdfdir=DIR pdf documentation [DOCDIR] + --psdir=DIR ps documentation [DOCDIR] +_ACEOF + + cat <<\_ACEOF +_ACEOF +fi + +if test -n "$ac_init_help"; then + + cat <<\_ACEOF + +Report bugs to the package provider. +_ACEOF +ac_status=$? +fi + +if test "$ac_init_help" = "recursive"; then + # If there are subdirs, report their specific --help. + for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue + test -d "$ac_dir" || + { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || + continue + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + cd "$ac_dir" || { ac_status=$?; continue; } + # Check for guested configure. + if test -f "$ac_srcdir/configure.gnu"; then + echo && + $SHELL "$ac_srcdir/configure.gnu" --help=recursive + elif test -f "$ac_srcdir/configure"; then + echo && + $SHELL "$ac_srcdir/configure" --help=recursive + else + $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 + fi || ac_status=$? + cd "$ac_pwd" || { ac_status=$?; break; } + done +fi + +test -n "$ac_init_help" && exit $ac_status +if $ac_init_version; then + cat <<\_ACEOF +configure +generated by GNU Autoconf 2.68 + +Copyright (C) 2010 Free Software Foundation, Inc. +This configure script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it. +_ACEOF + exit +fi + +## ------------------------ ## +## Autoconf initialization. ## +## ------------------------ ## +cat >config.log <<_ACEOF +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. + +It was created by $as_me, which was +generated by GNU Autoconf 2.68. Invocation command line was + + $ $0 $@ + +_ACEOF +exec 5>>config.log +{ +cat <<_ASUNAME +## --------- ## +## Platform. ## +## --------- ## + +hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` + +/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` +/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` +/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` +/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` + +_ASUNAME + +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + $as_echo "PATH: $as_dir" + done +IFS=$as_save_IFS + +} >&5 + +cat >&5 <<_ACEOF + + +## ----------- ## +## Core tests. ## +## ----------- ## + +_ACEOF + + +# Keep a trace of the command line. +# Strip out --no-create and --no-recursion so they do not pile up. +# Strip out --silent because we don't want to record it for future runs. +# Also quote any args containing shell meta-characters. +# Make two passes to allow for proper duplicate-argument suppression. +ac_configure_args= +ac_configure_args0= +ac_configure_args1= +ac_must_keep_next=false +for ac_pass in 1 2 +do + for ac_arg + do + case $ac_arg in + -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + continue ;; + *\'*) + ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + case $ac_pass in + 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; + 2) + as_fn_append ac_configure_args1 " '$ac_arg'" + if test $ac_must_keep_next = true; then + ac_must_keep_next=false # Got value, back to normal. + else + case $ac_arg in + *=* | --config-cache | -C | -disable-* | --disable-* \ + | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ + | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ + | -with-* | --with-* | -without-* | --without-* | --x) + case "$ac_configure_args0 " in + "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; + esac + ;; + -* ) ac_must_keep_next=true ;; + esac + fi + as_fn_append ac_configure_args " '$ac_arg'" + ;; + esac + done +done +{ ac_configure_args0=; unset ac_configure_args0;} +{ ac_configure_args1=; unset ac_configure_args1;} + +# When interrupted or exit'd, cleanup temporary files, and complete +# config.log. We remove comments because anyway the quotes in there +# would cause problems or look ugly. +# WARNING: Use '\'' to represent an apostrophe within the trap. +# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. +trap 'exit_status=$? + # Save into config.log some information that might help in debugging. + { + echo + + $as_echo "## ---------------- ## +## Cache variables. ## +## ---------------- ##" + echo + # The following way of writing the cache mishandles newlines in values, +( + for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + (set) 2>&1 | + case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + sed -n \ + "s/'\''/'\''\\\\'\'''\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" + ;; #( + *) + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) + echo + + $as_echo "## ----------------- ## +## Output variables. ## +## ----------------- ##" + echo + for ac_var in $ac_subst_vars + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + $as_echo "$ac_var='\''$ac_val'\''" + done | sort + echo + + if test -n "$ac_subst_files"; then + $as_echo "## ------------------- ## +## File substitutions. ## +## ------------------- ##" + echo + for ac_var in $ac_subst_files + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + $as_echo "$ac_var='\''$ac_val'\''" + done | sort + echo + fi + + if test -s confdefs.h; then + $as_echo "## ----------- ## +## confdefs.h. ## +## ----------- ##" + echo + cat confdefs.h + echo + fi + test "$ac_signal" != 0 && + $as_echo "$as_me: caught signal $ac_signal" + $as_echo "$as_me: exit $exit_status" + } >&5 + rm -f core *.core core.conftest.* && + rm -f -r conftest* confdefs* conf$$* $ac_clean_files && + exit $exit_status +' 0 +for ac_signal in 1 2 13 15; do + trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal +done +ac_signal=0 + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -f -r conftest* confdefs.h + +$as_echo "/* confdefs.h */" > confdefs.h + +# Predefined preprocessor variables. + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_NAME "$PACKAGE_NAME" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_TARNAME "$PACKAGE_TARNAME" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_VERSION "$PACKAGE_VERSION" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_STRING "$PACKAGE_STRING" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_URL "$PACKAGE_URL" +_ACEOF + + +# Let the site file select an alternate cache file if it wants to. +# Prefer an explicitly selected file to automatically selected ones. +ac_site_file1=NONE +ac_site_file2=NONE +if test -n "$CONFIG_SITE"; then + # We do not want a PATH search for config.site. + case $CONFIG_SITE in #(( + -*) ac_site_file1=./$CONFIG_SITE;; + */*) ac_site_file1=$CONFIG_SITE;; + *) ac_site_file1=./$CONFIG_SITE;; + esac +elif test "x$prefix" != xNONE; then + ac_site_file1=$prefix/share/config.site + ac_site_file2=$prefix/etc/config.site +else + ac_site_file1=$ac_default_prefix/share/config.site + ac_site_file2=$ac_default_prefix/etc/config.site +fi +for ac_site_file in "$ac_site_file1" "$ac_site_file2" +do + test "x$ac_site_file" = xNONE && continue + if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 +$as_echo "$as_me: loading site script $ac_site_file" >&6;} + sed 's/^/| /' "$ac_site_file" >&5 + . "$ac_site_file" \ + || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "failed to load site script $ac_site_file +See \`config.log' for more details" "$LINENO" 5; } + fi +done + +if test -r "$cache_file"; then + # Some versions of bash will fail to source /dev/null (special files + # actually), so we avoid doing that. DJGPP emulates it as a regular file. + if test /dev/null != "$cache_file" && test -f "$cache_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 +$as_echo "$as_me: loading cache $cache_file" >&6;} + case $cache_file in + [\\/]* | ?:[\\/]* ) . "$cache_file";; + *) . "./$cache_file";; + esac + fi +else + { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 +$as_echo "$as_me: creating cache $cache_file" >&6;} + >$cache_file +fi + +# Check that the precious variables saved in the cache have kept the same +# value. +ac_cache_corrupted=false +for ac_var in $ac_precious_vars; do + eval ac_old_set=\$ac_cv_env_${ac_var}_set + eval ac_new_set=\$ac_env_${ac_var}_set + eval ac_old_val=\$ac_cv_env_${ac_var}_value + eval ac_new_val=\$ac_env_${ac_var}_value + case $ac_old_set,$ac_new_set in + set,) + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 +$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,set) + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 +$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,);; + *) + if test "x$ac_old_val" != "x$ac_new_val"; then + # differences in whitespace do not lead to failure. + ac_old_val_w=`echo x $ac_old_val` + ac_new_val_w=`echo x $ac_new_val` + if test "$ac_old_val_w" != "$ac_new_val_w"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 +$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} + ac_cache_corrupted=: + else + { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 +$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} + eval $ac_var=\$ac_old_val + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 +$as_echo "$as_me: former value: \`$ac_old_val'" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 +$as_echo "$as_me: current value: \`$ac_new_val'" >&2;} + fi;; + esac + # Pass precious variables to config.status. + if test "$ac_new_set" = set; then + case $ac_new_val in + *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; + *) ac_arg=$ac_var=$ac_new_val ;; + esac + case " $ac_configure_args " in + *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. + *) as_fn_append ac_configure_args " '$ac_arg'" ;; + esac + fi +done +if $ac_cache_corrupted; then + { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 +$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} + as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 +fi +## -------------------- ## +## Main body of script. ## +## -------------------- ## + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + +# Check for Ocaml compilers + +# we first look for ocamlc in the path; if not present, we fail +# Extract the first word of "ocamlc", so it can be a program name with args. +set dummy ocamlc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_OCAMLC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$OCAMLC"; then + ac_cv_prog_OCAMLC="$OCAMLC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_OCAMLC="ocamlc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_prog_OCAMLC" && ac_cv_prog_OCAMLC="no" +fi +fi +OCAMLC=$ac_cv_prog_OCAMLC +if test -n "$OCAMLC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLC" >&5 +$as_echo "$OCAMLC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +if test "$OCAMLC" = no ; then + as_fn_error $? "Cannot find ocamlc." "$LINENO" 5 +fi + +# we extract Ocaml version number and library path +OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` +echo "ocaml version is $OCAMLVERSION" + +case $OCAMLVERSION in + 0.*|1.*|2.*|3.00*|3.01*|3.02*|3.03*|3.04*|3.05*|3.06*|3.07*) + as_fn_error $? "ocamlgraph needs ocaml version 3.08.0 or higher" "$LINENO" 5;; + 3.08*) + FORPACK="";; + *) + FORPACK="-for-pack Graph";; +esac + +# OCAMLLIB=`$OCAMLC -v | tail -n 1 | cut -f 4 -d " "` +# OCAMLLIB=`$OCAMLC -v | tail -n 1 | sed -e 's|[[^:]]*: \(.*\)|\1|' ` +OCAMLLIB=`$OCAMLC -where` +echo "ocaml library path is $OCAMLLIB" + +# then we look for ocamlopt; if not present, we issue a warning +# if the version is not the same, we also discard it +# we set OCAMLBEST to "opt" or "byte", whether ocamlopt is available or not +# Extract the first word of "ocamlopt", so it can be a program name with args. +set dummy ocamlopt; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_OCAMLOPT+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$OCAMLOPT"; then + ac_cv_prog_OCAMLOPT="$OCAMLOPT" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_OCAMLOPT="ocamlopt" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_prog_OCAMLOPT" && ac_cv_prog_OCAMLOPT="no" +fi +fi +OCAMLOPT=$ac_cv_prog_OCAMLOPT +if test -n "$OCAMLOPT"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLOPT" >&5 +$as_echo "$OCAMLOPT" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +OCAMLBEST=byte +if test "$OCAMLOPT" = no ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Cannot find ocamlopt; bytecode compilation only." >&5 +$as_echo "$as_me: WARNING: Cannot find ocamlopt; bytecode compilation only." >&2;} +else + { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlopt version" >&5 +$as_echo_n "checking ocamlopt version... " >&6; } + TMPVERSION=`$OCAMLOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` + if test "$TMPVERSION" != "$OCAMLVERSION" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: differs from ocamlc; ocamlopt discarded." >&5 +$as_echo "differs from ocamlc; ocamlopt discarded." >&6; } + OCAMLOPT=no + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 +$as_echo "ok" >&6; } + OCAMLBEST=opt + fi +fi + +# checking for ocamlc.opt +# Extract the first word of "ocamlc.opt", so it can be a program name with args. +set dummy ocamlc.opt; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_OCAMLCDOTOPT+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$OCAMLCDOTOPT"; then + ac_cv_prog_OCAMLCDOTOPT="$OCAMLCDOTOPT" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_OCAMLCDOTOPT="ocamlc.opt" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_prog_OCAMLCDOTOPT" && ac_cv_prog_OCAMLCDOTOPT="no" +fi +fi +OCAMLCDOTOPT=$ac_cv_prog_OCAMLCDOTOPT +if test -n "$OCAMLCDOTOPT"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLCDOTOPT" >&5 +$as_echo "$OCAMLCDOTOPT" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +if test "$OCAMLCDOTOPT" != no ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlc.opt version" >&5 +$as_echo_n "checking ocamlc.opt version... " >&6; } + TMPVERSION=`$OCAMLCDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` + if test "$TMPVERSION" != "$OCAMLVERSION" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: differs from ocamlc; ocamlc.opt discarded." >&5 +$as_echo "differs from ocamlc; ocamlc.opt discarded." >&6; } + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 +$as_echo "ok" >&6; } + OCAMLC=$OCAMLCDOTOPT + fi +fi + +# checking for ocamlopt.opt +if test "$OCAMLOPT" != no ; then + # Extract the first word of "ocamlopt.opt", so it can be a program name with args. +set dummy ocamlopt.opt; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_OCAMLOPTDOTOPT+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$OCAMLOPTDOTOPT"; then + ac_cv_prog_OCAMLOPTDOTOPT="$OCAMLOPTDOTOPT" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_OCAMLOPTDOTOPT="ocamlopt.opt" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_prog_OCAMLOPTDOTOPT" && ac_cv_prog_OCAMLOPTDOTOPT="no" +fi +fi +OCAMLOPTDOTOPT=$ac_cv_prog_OCAMLOPTDOTOPT +if test -n "$OCAMLOPTDOTOPT"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLOPTDOTOPT" >&5 +$as_echo "$OCAMLOPTDOTOPT" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + if test "$OCAMLOPTDOTOPT" != no ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlc.opt version" >&5 +$as_echo_n "checking ocamlc.opt version... " >&6; } + TMPVER=`$OCAMLOPTDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` + if test "$TMPVER" != "$OCAMLVERSION" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: differs from ocamlc; ocamlopt.opt discarded." >&5 +$as_echo "differs from ocamlc; ocamlopt.opt discarded." >&6; } + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 +$as_echo "ok" >&6; } + OCAMLOPT=$OCAMLOPTDOTOPT + fi + fi +fi + +# ocamldep, ocamllex and ocamlyacc should also be present in the path +# Extract the first word of "ocamldep", so it can be a program name with args. +set dummy ocamldep; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_OCAMLDEP+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$OCAMLDEP"; then + ac_cv_prog_OCAMLDEP="$OCAMLDEP" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_OCAMLDEP="ocamldep" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_prog_OCAMLDEP" && ac_cv_prog_OCAMLDEP="no" +fi +fi +OCAMLDEP=$ac_cv_prog_OCAMLDEP +if test -n "$OCAMLDEP"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLDEP" >&5 +$as_echo "$OCAMLDEP" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +if test "$OCAMLDEP" = no ; then + as_fn_error $? "Cannot find ocamldep." "$LINENO" 5 +fi + +# Extract the first word of "ocamllex", so it can be a program name with args. +set dummy ocamllex; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_OCAMLLEX+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$OCAMLLEX"; then + ac_cv_prog_OCAMLLEX="$OCAMLLEX" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_OCAMLLEX="ocamllex" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_prog_OCAMLLEX" && ac_cv_prog_OCAMLLEX="no" +fi +fi +OCAMLLEX=$ac_cv_prog_OCAMLLEX +if test -n "$OCAMLLEX"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLLEX" >&5 +$as_echo "$OCAMLLEX" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +if test "$OCAMLLEX" = no ; then + as_fn_error $? "Cannot find ocamllex." "$LINENO" 5 +else + # Extract the first word of "ocamllex.opt", so it can be a program name with args. +set dummy ocamllex.opt; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_OCAMLLEXDOTOPT+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$OCAMLLEXDOTOPT"; then + ac_cv_prog_OCAMLLEXDOTOPT="$OCAMLLEXDOTOPT" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_OCAMLLEXDOTOPT="ocamllex.opt" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_prog_OCAMLLEXDOTOPT" && ac_cv_prog_OCAMLLEXDOTOPT="no" +fi +fi +OCAMLLEXDOTOPT=$ac_cv_prog_OCAMLLEXDOTOPT +if test -n "$OCAMLLEXDOTOPT"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLLEXDOTOPT" >&5 +$as_echo "$OCAMLLEXDOTOPT" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + if test "$OCAMLLEXDOTOPT" != no ; then + OCAMLLEX=$OCAMLLEXDOTOPT + fi +fi + +# Extract the first word of "ocamlyacc", so it can be a program name with args. +set dummy ocamlyacc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_OCAMLYACC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$OCAMLYACC"; then + ac_cv_prog_OCAMLYACC="$OCAMLYACC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_OCAMLYACC="ocamlyacc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_prog_OCAMLYACC" && ac_cv_prog_OCAMLYACC="no" +fi +fi +OCAMLYACC=$ac_cv_prog_OCAMLYACC +if test -n "$OCAMLYACC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLYACC" >&5 +$as_echo "$OCAMLYACC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +if test "$OCAMLYACC" = no ; then + as_fn_error $? "Cannot find ocamlyacc." "$LINENO" 5 +fi + +# Extract the first word of "ocamldoc", so it can be a program name with args. +set dummy ocamldoc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_OCAMLDOC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$OCAMLDOC"; then + ac_cv_prog_OCAMLDOC="$OCAMLDOC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_OCAMLDOC="ocamldoc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_prog_OCAMLDOC" && ac_cv_prog_OCAMLDOC="true" +fi +fi +OCAMLDOC=$ac_cv_prog_OCAMLDOC +if test -n "$OCAMLDOC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLDOC" >&5 +$as_echo "$OCAMLDOC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +if test "$OCAMLDOC" = true ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Cannot find ocamldoc" >&5 +$as_echo "$as_me: WARNING: Cannot find ocamldoc" >&2;} +else + # Extract the first word of "ocamldoc.opt", so it can be a program name with args. +set dummy ocamldoc.opt; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_OCAMLDOCOPT+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$OCAMLDOCOPT"; then + ac_cv_prog_OCAMLDOCOPT="$OCAMLDOCOPT" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_OCAMLDOCOPT="ocamldoc.opt" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_prog_OCAMLDOCOPT" && ac_cv_prog_OCAMLDOCOPT="no" +fi +fi +OCAMLDOCOPT=$ac_cv_prog_OCAMLDOCOPT +if test -n "$OCAMLDOCOPT"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLDOCOPT" >&5 +$as_echo "$OCAMLDOCOPT" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + if test "$OCAMLDOCOPT" != no ; then + OCAMLDOC=$OCAMLDOCOPT + fi +fi + +# Extract the first word of "ocamlweb", so it can be a program name with args. +set dummy ocamlweb; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_OCAMLWEB+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$OCAMLWEB"; then + ac_cv_prog_OCAMLWEB="$OCAMLWEB" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_OCAMLWEB="ocamlweb" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_prog_OCAMLWEB" && ac_cv_prog_OCAMLWEB="true" +fi +fi +OCAMLWEB=$ac_cv_prog_OCAMLWEB +if test -n "$OCAMLWEB"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLWEB" >&5 +$as_echo "$OCAMLWEB" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + +# Extract the first word of "ocamlfind", so it can be a program name with args. +set dummy ocamlfind; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_OCAMLFIND+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$OCAMLFIND"; then + ac_cv_prog_OCAMLFIND="$OCAMLFIND" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_OCAMLFIND="ocamlfind" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +OCAMLFIND=$ac_cv_prog_OCAMLFIND +if test -n "$OCAMLFIND"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLFIND" >&5 +$as_echo "$OCAMLFIND" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + +# checking for lablgtk2 +# Extract the first word of "lablgtk2", so it can be a program name with args. +set dummy lablgtk2; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_LABLGTK2+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$LABLGTK2"; then + ac_cv_prog_LABLGTK2="$LABLGTK2" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_LABLGTK2="yes" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_prog_LABLGTK2" && ac_cv_prog_LABLGTK2="no" +fi +fi +LABLGTK2=$ac_cv_prog_LABLGTK2 +if test -n "$LABLGTK2"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $LABLGTK2" >&5 +$as_echo "$LABLGTK2" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +if test "$LABLGTK2" = yes ; then + if test -d "$OCAMLLIB/lablgtk2" ; then + INCLUDEGTK2="-I +lablgtk2" + else + LABLGTK2=no + fi +fi + +# platform +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking Win32 platform" >&5 +$as_echo_n "checking Win32 platform... " >&6; } +if echo "let _ = Sys.os_type;;" | ocaml | grep -q Win32; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + OCAMLWIN32=yes + EXE=.exe + LIBEXT=.lib + OBJEXT=.obj +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + OCAMLWIN32=no + EXE= + LIBEXT=.a + OBJEXT=.o +fi + +# substitutions to perform + + + + + + + + + + + + + + + + + + +# Finally create the Makefile from Makefile.in +ac_config_files="$ac_config_files Makefile" + +cat >confcache <<\_ACEOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs, see configure's option --config-cache. +# It is not useful on other systems. If it contains results you don't +# want to keep, you may remove or edit it. +# +# config.status only pays attention to the cache file if you give it +# the --recheck option to rerun configure. +# +# `ac_cv_env_foo' variables (set or unset) will be overridden when +# loading this file, other *unset* `ac_cv_foo' will be assigned the +# following values. + +_ACEOF + +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, we kill variables containing newlines. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +( + for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + + (set) 2>&1 | + case $as_nl`(ac_space=' '; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + # `set' does not quote correctly, so add quotes: double-quote + # substitution turns \\\\ into \\, and sed turns \\ into \. + sed -n \ + "s/'/'\\\\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" + ;; #( + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) | + sed ' + /^ac_cv_env_/b end + t clear + :clear + s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ + t end + s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ + :end' >>confcache +if diff "$cache_file" confcache >/dev/null 2>&1; then :; else + if test -w "$cache_file"; then + if test "x$cache_file" != "x/dev/null"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 +$as_echo "$as_me: updating cache $cache_file" >&6;} + if test ! -f "$cache_file" || test -h "$cache_file"; then + cat confcache >"$cache_file" + else + case $cache_file in #( + */* | ?:*) + mv -f confcache "$cache_file"$$ && + mv -f "$cache_file"$$ "$cache_file" ;; #( + *) + mv -f confcache "$cache_file" ;; + esac + fi + fi + else + { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 +$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} + fi +fi +rm -f confcache + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# Transform confdefs.h into DEFS. +# Protect against shell expansion while executing Makefile rules. +# Protect against Makefile macro expansion. +# +# If the first sed substitution is executed (which looks for macros that +# take arguments), then branch to the quote section. Otherwise, +# look for a macro that doesn't take arguments. +ac_script=' +:mline +/\\$/{ + N + s,\\\n,, + b mline +} +t clear +:clear +s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g +t quote +s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g +t quote +b any +:quote +s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g +s/\[/\\&/g +s/\]/\\&/g +s/\$/$$/g +H +:any +${ + g + s/^\n// + s/\n/ /g + p +} +' +DEFS=`sed -n "$ac_script" confdefs.h` + + +ac_libobjs= +ac_ltlibobjs= +U= +for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue + # 1. Remove the extension, and $U if already installed. + ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' + ac_i=`$as_echo "$ac_i" | sed "$ac_script"` + # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR + # will be set to the directory where LIBOBJS objects are built. + as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" + as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' +done +LIBOBJS=$ac_libobjs + +LTLIBOBJS=$ac_ltlibobjs + + + +: "${CONFIG_STATUS=./config.status}" +ac_write_fail=0 +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files $CONFIG_STATUS" +{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 +$as_echo "$as_me: creating $CONFIG_STATUS" >&6;} +as_write_fail=0 +cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 +#! $SHELL +# Generated by $as_me. +# Run this file to recreate the current configuration. +# Compiler output produced by configure, useful for debugging +# configure, is in config.log if it exists. + +debug=false +ac_cs_recheck=false +ac_cs_silent=false + +SHELL=\${CONFIG_SHELL-$SHELL} +export SHELL +_ASEOF +cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + +as_nl=' +' +export as_nl +# Printing a long string crashes Solaris 7 /usr/bin/printf. +as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='printf %s\n' + as_echo_n='printf %s' +else + if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then + as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' + as_echo_n='/usr/ucb/echo -n' + else + as_echo_body='eval expr "X$1" : "X\\(.*\\)"' + as_echo_n_body='eval + arg=$1; + case $arg in #( + *"$as_nl"*) + expr "X$arg" : "X\\(.*\\)$as_nl"; + arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; + esac; + expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" + ' + export as_echo_n_body + as_echo_n='sh -c $as_echo_n_body as_echo' + fi + export as_echo_body + as_echo='sh -c $as_echo_body as_echo' +fi + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -p'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -p' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -p' + fi +else + as_ln_s='cp -p' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + +if test -x / >/dev/null 2>&1; then + as_test_x='test -x' +else + if ls -dL / >/dev/null 2>&1; then + as_ls_L_option=L + else + as_ls_L_option= + fi + as_test_x=' + eval sh -c '\'' + if test -d "$1"; then + test -d "$1/."; + else + case $1 in #( + -*)set "./$1";; + esac; + case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( + ???[sx]*):;;*)false;;esac;fi + '\'' sh + ' +fi +as_executable_p=$as_test_x + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +exec 6>&1 +## ----------------------------------- ## +## Main body of $CONFIG_STATUS script. ## +## ----------------------------------- ## +_ASEOF +test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# Save the log message, to keep $0 and so on meaningful, and to +# report actual input values of CONFIG_FILES etc. instead of their +# values after options handling. +ac_log=" +This file was extended by $as_me, which was +generated by GNU Autoconf 2.68. Invocation command line was + + CONFIG_FILES = $CONFIG_FILES + CONFIG_HEADERS = $CONFIG_HEADERS + CONFIG_LINKS = $CONFIG_LINKS + CONFIG_COMMANDS = $CONFIG_COMMANDS + $ $0 $@ + +on `(hostname || uname -n) 2>/dev/null | sed 1q` +" + +_ACEOF + +case $ac_config_files in *" +"*) set x $ac_config_files; shift; ac_config_files=$*;; +esac + + + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +# Files that config.status was made for. +config_files="$ac_config_files" + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +ac_cs_usage="\ +\`$as_me' instantiates files and other configuration actions +from templates according to the current configuration. Unless the files +and actions are specified as TAGs, all are instantiated by default. + +Usage: $0 [OPTION]... [TAG]... + + -h, --help print this help, then exit + -V, --version print version number and configuration settings, then exit + --config print configuration, then exit + -q, --quiet, --silent + do not print progress messages + -d, --debug don't remove temporary files + --recheck update $as_me by reconfiguring in the same conditions + --file=FILE[:TEMPLATE] + instantiate the configuration file FILE + +Configuration files: +$config_files + +Report bugs to the package provider." + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" +ac_cs_version="\\ +config.status +configured by $0, generated by GNU Autoconf 2.68, + with options \\"\$ac_cs_config\\" + +Copyright (C) 2010 Free Software Foundation, Inc. +This config.status script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it." + +ac_pwd='$ac_pwd' +srcdir='$srcdir' +test -n "\$AWK" || AWK=awk +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# The default lists apply if the user does not specify any file. +ac_need_defaults=: +while test $# != 0 +do + case $1 in + --*=?*) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` + ac_shift=: + ;; + --*=) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg= + ac_shift=: + ;; + *) + ac_option=$1 + ac_optarg=$2 + ac_shift=shift + ;; + esac + + case $ac_option in + # Handling of the options. + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + ac_cs_recheck=: ;; + --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) + $as_echo "$ac_cs_version"; exit ;; + --config | --confi | --conf | --con | --co | --c ) + $as_echo "$ac_cs_config"; exit ;; + --debug | --debu | --deb | --de | --d | -d ) + debug=: ;; + --file | --fil | --fi | --f ) + $ac_shift + case $ac_optarg in + *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; + '') as_fn_error $? "missing file argument" ;; + esac + as_fn_append CONFIG_FILES " '$ac_optarg'" + ac_need_defaults=false;; + --he | --h | --help | --hel | -h ) + $as_echo "$ac_cs_usage"; exit ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil | --si | --s) + ac_cs_silent=: ;; + + # This is an error. + -*) as_fn_error $? "unrecognized option: \`$1' +Try \`$0 --help' for more information." ;; + + *) as_fn_append ac_config_targets " $1" + ac_need_defaults=false ;; + + esac + shift +done + +ac_configure_extra_args= + +if $ac_cs_silent; then + exec 6>/dev/null + ac_configure_extra_args="$ac_configure_extra_args --silent" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +if \$ac_cs_recheck; then + set X '$SHELL' '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion + shift + \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 + CONFIG_SHELL='$SHELL' + export CONFIG_SHELL + exec "\$@" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +exec 5>>config.log +{ + echo + sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX +## Running $as_me. ## +_ASBOX + $as_echo "$ac_log" +} >&5 + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + +# Handling of arguments. +for ac_config_target in $ac_config_targets +do + case $ac_config_target in + "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; + + *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; + esac +done + + +# If the user did not use the arguments to specify the items to instantiate, +# then the envvar interface is used. Set only those that are not. +# We use the long form for the default assignment because of an extremely +# bizarre bug on SunOS 4.1.3. +if $ac_need_defaults; then + test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files +fi + +# Have a temporary directory for convenience. Make it in the build tree +# simply because there is no reason against having it here, and in addition, +# creating and moving files from /tmp can sometimes cause problems. +# Hook for its removal unless debugging. +# Note that there is a small window in which the directory will not be cleaned: +# after its creation but before its name has been assigned to `$tmp'. +$debug || +{ + tmp= ac_tmp= + trap 'exit_status=$? + : "${ac_tmp:=$tmp}" + { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status +' 0 + trap 'as_fn_exit 1' 1 2 13 15 +} +# Create a (secure) tmp directory for tmp files. + +{ + tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && + test -d "$tmp" +} || +{ + tmp=./conf$$-$RANDOM + (umask 077 && mkdir "$tmp") +} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 +ac_tmp=$tmp + +# Set up the scripts for CONFIG_FILES section. +# No need to generate them if there are no CONFIG_FILES. +# This happens for instance with `./config.status config.h'. +if test -n "$CONFIG_FILES"; then + + +ac_cr=`echo X | tr X '\015'` +# On cygwin, bash can eat \r inside `` if the user requested igncr. +# But we know of no other shell where ac_cr would be empty at this +# point, so we can use a bashism as a fallback. +if test "x$ac_cr" = x; then + eval ac_cr=\$\'\\r\' +fi +ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` +if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then + ac_cs_awk_cr='\\r' +else + ac_cs_awk_cr=$ac_cr +fi + +echo 'BEGIN {' >"$ac_tmp/subs1.awk" && +_ACEOF + + +{ + echo "cat >conf$$subs.awk <<_ACEOF" && + echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && + echo "_ACEOF" +} >conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 +ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` +ac_delim='%!_!# ' +for ac_last_try in false false false false false :; do + . ./conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + + ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` + if test $ac_delim_n = $ac_delim_num; then + break + elif $ac_last_try; then + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +done +rm -f conf$$subs.sh + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && +_ACEOF +sed -n ' +h +s/^/S["/; s/!.*/"]=/ +p +g +s/^[^!]*!// +:repl +t repl +s/'"$ac_delim"'$// +t delim +:nl +h +s/\(.\{148\}\)..*/\1/ +t more1 +s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ +p +n +b repl +:more1 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t nl +:delim +h +s/\(.\{148\}\)..*/\1/ +t more2 +s/["\\]/\\&/g; s/^/"/; s/$/"/ +p +b +:more2 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t delim +' >$CONFIG_STATUS || ac_write_fail=1 +rm -f conf$$subs.awk +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACAWK +cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && + for (key in S) S_is_set[key] = 1 + FS = "" + +} +{ + line = $ 0 + nfields = split(line, field, "@") + substed = 0 + len = length(field[1]) + for (i = 2; i < nfields; i++) { + key = field[i] + keylen = length(key) + if (S_is_set[key]) { + value = S[key] + line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) + len += length(value) + length(field[++i]) + substed = 1 + } else + len += 1 + keylen + } + + print line +} + +_ACAWK +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then + sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" +else + cat +fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ + || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 +_ACEOF + +# VPATH may cause trouble with some makes, so we remove sole $(srcdir), +# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and +# trailing colons and then remove the whole line if VPATH becomes empty +# (actually we leave an empty line to preserve line numbers). +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ +h +s/// +s/^/:/ +s/[ ]*$/:/ +s/:\$(srcdir):/:/g +s/:\${srcdir}:/:/g +s/:@srcdir@:/:/g +s/^:*// +s/:*$// +x +s/\(=[ ]*\).*/\1/ +G +s/\n// +s/^[^=]*=[ ]*$// +}' +fi + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +fi # test -n "$CONFIG_FILES" + + +eval set X " :F $CONFIG_FILES " +shift +for ac_tag +do + case $ac_tag in + :[FHLC]) ac_mode=$ac_tag; continue;; + esac + case $ac_mode$ac_tag in + :[FHL]*:*);; + :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; + :[FH]-) ac_tag=-:-;; + :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; + esac + ac_save_IFS=$IFS + IFS=: + set x $ac_tag + IFS=$ac_save_IFS + shift + ac_file=$1 + shift + + case $ac_mode in + :L) ac_source=$1;; + :[FH]) + ac_file_inputs= + for ac_f + do + case $ac_f in + -) ac_f="$ac_tmp/stdin";; + *) # Look for the file first in the build tree, then in the source tree + # (if the path is not absolute). The absolute path cannot be DOS-style, + # because $ac_f cannot contain `:'. + test -f "$ac_f" || + case $ac_f in + [\\/$]*) false;; + *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; + esac || + as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; + esac + case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac + as_fn_append ac_file_inputs " '$ac_f'" + done + + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + configure_input='Generated from '` + $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' + `' by configure.' + if test x"$ac_file" != x-; then + configure_input="$ac_file. $configure_input" + { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 +$as_echo "$as_me: creating $ac_file" >&6;} + fi + # Neutralize special characters interpreted by sed in replacement strings. + case $configure_input in #( + *\&* | *\|* | *\\* ) + ac_sed_conf_input=`$as_echo "$configure_input" | + sed 's/[\\\\&|]/\\\\&/g'`;; #( + *) ac_sed_conf_input=$configure_input;; + esac + + case $ac_tag in + *:-:* | *:-) cat >"$ac_tmp/stdin" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; + esac + ;; + esac + + ac_dir=`$as_dirname -- "$ac_file" || +$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_file" : 'X\(//\)[^/]' \| \ + X"$ac_file" : 'X\(//\)$' \| \ + X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + as_dir="$ac_dir"; as_fn_mkdir_p + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + + case $ac_mode in + :F) + # + # CONFIG_FILE + # + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# If the template does not know about datarootdir, expand it. +# FIXME: This hack should be removed a few years after 2.60. +ac_datarootdir_hack=; ac_datarootdir_seen= +ac_sed_dataroot=' +/datarootdir/ { + p + q +} +/@datadir@/p +/@docdir@/p +/@infodir@/p +/@localedir@/p +/@mandir@/p' +case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in +*datarootdir*) ac_datarootdir_seen=yes;; +*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 +$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 + ac_datarootdir_hack=' + s&@datadir@&$datadir&g + s&@docdir@&$docdir&g + s&@infodir@&$infodir&g + s&@localedir@&$localedir&g + s&@mandir@&$mandir&g + s&\\\${datarootdir}&$datarootdir&g' ;; +esac +_ACEOF + +# Neutralize VPATH when `$srcdir' = `.'. +# Shell code in configure.ac might set extrasub. +# FIXME: do we really want to maintain this feature? +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_sed_extra="$ac_vpsub +$extrasub +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +:t +/@[a-zA-Z_][a-zA-Z_0-9]*@/!b +s|@configure_input@|$ac_sed_conf_input|;t t +s&@top_builddir@&$ac_top_builddir_sub&;t t +s&@top_build_prefix@&$ac_top_build_prefix&;t t +s&@srcdir@&$ac_srcdir&;t t +s&@abs_srcdir@&$ac_abs_srcdir&;t t +s&@top_srcdir@&$ac_top_srcdir&;t t +s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t +s&@builddir@&$ac_builddir&;t t +s&@abs_builddir@&$ac_abs_builddir&;t t +s&@abs_top_builddir@&$ac_abs_top_builddir&;t t +$ac_datarootdir_hack +" +eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ + >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + +test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && + { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && + { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ + "$ac_tmp/out"`; test -z "$ac_out"; } && + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&5 +$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&2;} + + rm -f "$ac_tmp/stdin" + case $ac_file in + -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; + *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; + esac \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + ;; + + + + esac + +done # for ac_tag + + +as_fn_exit 0 +_ACEOF +ac_clean_files=$ac_clean_files_save + +test $ac_write_fail = 0 || + as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 + + +# configure is writing to config.log, and then calls config.status. +# config.status does its own redirection, appending to config.log. +# Unfortunately, on DOS this fails, as config.log is still kept open +# by configure, so config.status won't be able to write to it; its +# output is simply discarded. So we exec the FD to /dev/null, +# effectively closing config.log, so it can be properly (re)opened and +# appended to by config.status. When coming back to configure, we +# need to make the FD available again. +if test "$no_create" != yes; then + ac_cs_success=: + ac_config_status_args= + test "$silent" = yes && + ac_config_status_args="$ac_config_status_args --quiet" + exec 5>/dev/null + $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false + exec 5>>config.log + # Use ||, not &&, to avoid exiting from the if with $? = 1, which + # would make configure fail if this is the last instruction. + $ac_cs_success || as_fn_exit 1 +fi +if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 +$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} +fi + +chmod a-w Makefile diff --git a/external/ocamlgraph/configure.in b/external/ocamlgraph/configure.in new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/configure.in @@ -0,0 +1,193 @@ +########################################################################## +# # +# Ocamlgraph: a generic graph library for OCaml # +# Copyright (C) 2004-2007 # +# Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles # +# # +# This software is free software; you can redistribute it and/or # +# modify it under the terms of the GNU Library General Public # +# License version 2, with the special exception on linking # +# described in file LICENSE. # +# # +# This software is distributed in the hope that it will be useful, # +# but WITHOUT ANY WARRANTY; without even the implied warranty of # +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. # +# # +########################################################################## + +# the script generated by autoconf from this input will set the following +# variables: +# OCAMLC "ocamlc" if present in the path, or a failure +# or "ocamlc.opt" if present with same version number as ocamlc +# OCAMLOPT "ocamlopt" (or "ocamlopt.opt" if present), or "no" +# OCAMLBEST either "byte" if no native compiler was found, +# or "opt" otherwise +# OCAMLDEP "ocamldep" +# OCAMLLEX "ocamllex" (or "ocamllex.opt" if present) +# OCAMLYACC "ocamlyac" +# OCAMLLIB the path to the ocaml standard library +# OCAMLVERSION the ocaml version number +# OCAMLWEB "ocamlweb" (not mandatory) +# OCAMLWIN32 "yes"/"no" depending on Sys.os_type = "Win32" +# EXE ".exe" if OCAMLWIN32=yes, "" otherwise + +# check for one particular file of the sources +# ADAPT THE FOLLOWING LINE TO YOUR SOURCES! +AC_INIT(src/sig.mli) + +# Check for Ocaml compilers + +# we first look for ocamlc in the path; if not present, we fail +AC_CHECK_PROG(OCAMLC,ocamlc,ocamlc,no) +if test "$OCAMLC" = no ; then + AC_MSG_ERROR(Cannot find ocamlc.) +fi + +# we extract Ocaml version number and library path +OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` +echo "ocaml version is $OCAMLVERSION" + +case $OCAMLVERSION in + 0.*|1.*|2.*|3.00*|3.01*|3.02*|3.03*|3.04*|3.05*|3.06*|3.07*) + AC_MSG_ERROR(ocamlgraph needs ocaml version 3.08.0 or higher);; + 3.08*) + FORPACK="";; + *) + FORPACK="-for-pack Graph";; +esac + +# OCAMLLIB=`$OCAMLC -v | tail -n 1 | cut -f 4 -d " "` +# OCAMLLIB=`$OCAMLC -v | tail -n 1 | sed -e 's|[[^:]]*: \(.*\)|\1|' ` +OCAMLLIB=`$OCAMLC -where` +echo "ocaml library path is $OCAMLLIB" + +# then we look for ocamlopt; if not present, we issue a warning +# if the version is not the same, we also discard it +# we set OCAMLBEST to "opt" or "byte", whether ocamlopt is available or not +AC_CHECK_PROG(OCAMLOPT,ocamlopt,ocamlopt,no) +OCAMLBEST=byte +if test "$OCAMLOPT" = no ; then + AC_MSG_WARN(Cannot find ocamlopt; bytecode compilation only.) +else + AC_MSG_CHECKING(ocamlopt version) + TMPVERSION=`$OCAMLOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` + if test "$TMPVERSION" != "$OCAMLVERSION" ; then + AC_MSG_RESULT(differs from ocamlc; ocamlopt discarded.) + OCAMLOPT=no + else + AC_MSG_RESULT(ok) + OCAMLBEST=opt + fi +fi + +# checking for ocamlc.opt +AC_CHECK_PROG(OCAMLCDOTOPT,ocamlc.opt,ocamlc.opt,no) +if test "$OCAMLCDOTOPT" != no ; then + AC_MSG_CHECKING(ocamlc.opt version) + TMPVERSION=`$OCAMLCDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` + if test "$TMPVERSION" != "$OCAMLVERSION" ; then + AC_MSG_RESULT(differs from ocamlc; ocamlc.opt discarded.) + else + AC_MSG_RESULT(ok) + OCAMLC=$OCAMLCDOTOPT + fi +fi + +# checking for ocamlopt.opt +if test "$OCAMLOPT" != no ; then + AC_CHECK_PROG(OCAMLOPTDOTOPT,ocamlopt.opt,ocamlopt.opt,no) + if test "$OCAMLOPTDOTOPT" != no ; then + AC_MSG_CHECKING(ocamlc.opt version) + TMPVER=`$OCAMLOPTDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` + if test "$TMPVER" != "$OCAMLVERSION" ; then + AC_MSG_RESULT(differs from ocamlc; ocamlopt.opt discarded.) + else + AC_MSG_RESULT(ok) + OCAMLOPT=$OCAMLOPTDOTOPT + fi + fi +fi + +# ocamldep, ocamllex and ocamlyacc should also be present in the path +AC_CHECK_PROG(OCAMLDEP,ocamldep,ocamldep,no) +if test "$OCAMLDEP" = no ; then + AC_MSG_ERROR(Cannot find ocamldep.) +fi + +AC_CHECK_PROG(OCAMLLEX,ocamllex,ocamllex,no) +if test "$OCAMLLEX" = no ; then + AC_MSG_ERROR(Cannot find ocamllex.) +else + AC_CHECK_PROG(OCAMLLEXDOTOPT,ocamllex.opt,ocamllex.opt,no) + if test "$OCAMLLEXDOTOPT" != no ; then + OCAMLLEX=$OCAMLLEXDOTOPT + fi +fi + +AC_CHECK_PROG(OCAMLYACC,ocamlyacc,ocamlyacc,no) +if test "$OCAMLYACC" = no ; then + AC_MSG_ERROR(Cannot find ocamlyacc.) +fi + +AC_CHECK_PROG(OCAMLDOC,ocamldoc,ocamldoc,true) +if test "$OCAMLDOC" = true ; then + AC_MSG_WARN(Cannot find ocamldoc) +else + AC_CHECK_PROG(OCAMLDOCOPT,ocamldoc.opt,ocamldoc.opt,no) + if test "$OCAMLDOCOPT" != no ; then + OCAMLDOC=$OCAMLDOCOPT + fi +fi + +AC_CHECK_PROG(OCAMLWEB,ocamlweb,ocamlweb,true) + +AC_CHECK_PROG(OCAMLFIND,ocamlfind,ocamlfind) + +# checking for lablgtk2 +AC_CHECK_PROG(LABLGTK2,lablgtk2,yes,no) +if test "$LABLGTK2" = yes ; then + if test -d "$OCAMLLIB/lablgtk2" ; then + INCLUDEGTK2="-I +lablgtk2" + else + LABLGTK2=no + fi +fi + +# platform +AC_MSG_CHECKING(Win32 platform) +if echo "let _ = Sys.os_type;;" | ocaml | grep -q Win32; then + AC_MSG_RESULT(yes) + OCAMLWIN32=yes + EXE=.exe + LIBEXT=.lib + OBJEXT=.obj +else + AC_MSG_RESULT(no) + OCAMLWIN32=no + EXE= + LIBEXT=.a + OBJEXT=.o +fi + +# substitutions to perform +AC_SUBST(OCAMLC) +AC_SUBST(OCAMLOPT) +AC_SUBST(OCAMLDEP) +AC_SUBST(OCAMLLEX) +AC_SUBST(OCAMLDOC) +AC_SUBST(OCAMLYACC) +AC_SUBST(OCAMLBEST) +AC_SUBST(OCAMLVERSION) +AC_SUBST(OCAMLLIB) +AC_SUBST(OCAMLWEB) +AC_SUBST(LABLGTK2) +AC_SUBST(OCAMLWIN32) +AC_SUBST(EXE) +AC_SUBST(LIBEXT) +AC_SUBST(OBJEXT) +AC_SUBST(FORPACK) +AC_SUBST(INCLUDEGTK2) + +# Finally create the Makefile from Makefile.in +AC_OUTPUT(Makefile) +chmod a-w Makefile diff --git a/external/ocamlgraph/lib/bitv.ml b/external/ocamlgraph/lib/bitv.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/lib/bitv.ml @@ -0,0 +1,610 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(*i $Id: bitv.ml,v 1.3 2004-07-13 12:54:42 filliatr Exp $ i*) + +(*s Bit vectors. The interface and part of the code are borrowed from the + [Array] module of the ocaml standard library (but things are simplified + here since we can always initialize a bit vector). This module also + provides bitwise operations. *) + +(*s We represent a bit vector by a vector of integers (field [bits]), + and we keep the information of the size of the bit vector since it + can not be found out with the size of the array (field [length]). *) + +type t = { + length : int; + bits : int array } + +let length v = v.length + +(*s Each element of the array is an integer containing [bpi] bits, where + [bpi] is determined according to the machine word size. Since we do not + use the sign bit, [bpi] is 30 on a 32-bits machine and 62 on a 64-bits + machines. We maintain the following invariant: + {\em The unused bits of the last integer are always + zeros.} This is ensured by [create] and maintained in other functions + using [normalize]. [bit_j], [bit_not_j], [low_mask] and [up_mask] + are arrays used to extract and mask bits in a single integer. *) + +let bpi = Sys.word_size - 2 + +let max_length = Sys.max_array_length * bpi + +let bit_j = Array.init bpi (fun j -> 1 lsl j) +let bit_not_j = Array.init bpi (fun j -> max_int - bit_j.(j)) + +let low_mask = Array.create (succ bpi) 0 +let _ = + for i = 1 to bpi do low_mask.(i) <- low_mask.(i-1) lor bit_j.(pred i) done + +let keep_lowest_bits a j = a land low_mask.(j) + +let high_mask = Array.init (succ bpi) (fun j -> low_mask.(j) lsl (bpi-j)) + +let keep_highest_bits a j = a land high_mask.(j) + +(*s Creating and normalizing a bit vector is easy: it is just a matter of + taking care of the invariant. Copy is immediate. *) + +let create n b = + let initv = if b then max_int else 0 in + let r = n mod bpi in + if r = 0 then + { length = n; bits = Array.create (n / bpi) initv } + else begin + let s = n / bpi in + let b = Array.create (succ s) initv in + b.(s) <- b.(s) land low_mask.(r); + { length = n; bits = b } + end + +let normalize v = + let r = v.length mod bpi in + if r > 0 then + let b = v.bits in + let s = Array.length b in + b.(s-1) <- b.(s-1) land low_mask.(r) + +let copy v = { length = v.length; bits = Array.copy v.bits } + +(*s Access and assignment. The [n]th bit of a bit vector is the [j]th + bit of the [i]th integer, where [i = n / bpi] and [j = n mod + bpi]. Both [i] and [j] and computed by the function [pos]. + Accessing a bit is testing whether the result of the corresponding + mask operation is non-zero, and assigning it is done with a + bitwiwe operation: an {\em or} with [bit_j] to set it, and an {\em + and} with [bit_not_j] to unset it. *) + +let pos n = + let i = n / bpi and j = n mod bpi in + if j < 0 then (i - 1, j + bpi) else (i,j) + +let unsafe_get v n = + let (i,j) = pos n in + ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_j j)) > 0 + +let unsafe_set v n b = + let (i,j) = pos n in + if b then + Array.unsafe_set v.bits i + ((Array.unsafe_get v.bits i) lor (Array.unsafe_get bit_j j)) + else + Array.unsafe_set v.bits i + ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_not_j j)) + +(*s The corresponding safe operations test the validiy of the access. *) + +let get v n = + if n < 0 or n >= v.length then invalid_arg "Bitv.get"; + let (i,j) = pos n in + ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_j j)) > 0 + +let set v n b = + if n < 0 or n >= v.length then invalid_arg "Bitv.set"; + let (i,j) = pos n in + if b then + Array.unsafe_set v.bits i + ((Array.unsafe_get v.bits i) lor (Array.unsafe_get bit_j j)) + else + Array.unsafe_set v.bits i + ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_not_j j)) + +(*s [init] is implemented naively using [unsafe_set]. *) + +let init n f = + let v = create n false in + for i = 0 to pred n do + unsafe_set v i (f i) + done; + v + +(*s Handling bits by packets is the key for efficiency of functions + [append], [concat], [sub] and [blit]. + We start by a very general function [blit_bits a i m v n] which blits + the bits [i] to [i+m-1] of a native integer [a] + onto the bit vector [v] at index [n]. It assumes that [i..i+m-1] and + [n..n+m-1] are respectively valid subparts of [a] and [v]. + It is optimized when the bits fit the lowest boundary of an integer + (case [j == 0]). *) + +let blit_bits a i m v n = + let (i',j) = pos n in + if j == 0 then + Array.unsafe_set v i' + ((keep_lowest_bits (a lsr i) m) lor + (keep_highest_bits (Array.unsafe_get v i') (bpi - m))) + else + let d = m + j - bpi in + if d > 0 then begin + Array.unsafe_set v i' + (((keep_lowest_bits (a lsr i) (bpi - j)) lsl j) lor + (keep_lowest_bits (Array.unsafe_get v i') j)); + Array.unsafe_set v (succ i') + ((keep_lowest_bits (a lsr (i + bpi - j)) d) lor + (keep_highest_bits (Array.unsafe_get v (succ i')) (bpi - d))) + end else + Array.unsafe_set v i' + (((keep_lowest_bits (a lsr i) m) lsl j) lor + ((Array.unsafe_get v i') land (low_mask.(j) lor high_mask.(-d)))) + +(*s [blit_int] implements [blit_bits] in the particular case when + [i=0] and [m=bpi] i.e. when we blit all the bits of [a]. *) + +let blit_int a v n = + let (i,j) = pos n in + if j == 0 then + Array.unsafe_set v i a + else begin + Array.unsafe_set v i + ( (keep_lowest_bits (Array.unsafe_get v i) j) lor + ((keep_lowest_bits a (bpi - j)) lsl j)); + Array.unsafe_set v (succ i) + ((keep_highest_bits (Array.unsafe_get v (succ i)) (bpi - j)) lor + (a lsr (bpi - j))) + end + +(*s When blitting a subpart of a bit vector into another bit vector, there + are two possible cases: (1) all the bits are contained in a single integer + of the first bit vector, and a single call to [blit_bits] is the + only thing to do, or (2) the source bits overlap on several integers of + the source array, and then we do a loop of [blit_int], with two calls + to [blit_bits] for the two bounds. *) + +let unsafe_blit v1 ofs1 v2 ofs2 len = + let (bi,bj) = pos ofs1 in + let (ei,ej) = pos (ofs1 + len - 1) in + if bi == ei then + blit_bits (Array.unsafe_get v1 bi) bj len v2 ofs2 + else begin + blit_bits (Array.unsafe_get v1 bi) bj (bpi - bj) v2 ofs2; + let n = ref (ofs2 + bpi - bj) in + for i = succ bi to pred ei do + blit_int (Array.unsafe_get v1 i) v2 !n; + n := !n + bpi + done; + blit_bits (Array.unsafe_get v1 ei) 0 (succ ej) v2 !n + end + +let blit v1 ofs1 v2 ofs2 len = + if len < 0 or ofs1 < 0 or ofs1 + len > v1.length + or ofs2 < 0 or ofs2 + len > v2.length + then invalid_arg "Bitv.blit"; + unsafe_blit v1.bits ofs1 v2.bits ofs2 len + +(*s Extracting the subvector [ofs..ofs+len-1] of [v] is just creating a + new vector of length [len] and blitting the subvector of [v] inside. *) + +let sub v ofs len = + if ofs < 0 or len < 0 or ofs + len > v.length then invalid_arg "Bitv.sub"; + let r = create len false in + unsafe_blit v.bits ofs r.bits 0 len; + r + +(*s The concatenation of two bit vectors [v1] and [v2] is obtained by + creating a vector for the result and blitting inside the two vectors. + [v1] is copied directly. *) + +let append v1 v2 = + let l1 = v1.length + and l2 = v2.length in + let r = create (l1 + l2) false in + let b1 = v1.bits in + let b2 = v2.bits in + let b = r.bits in + for i = 0 to Array.length b1 - 1 do + Array.unsafe_set b i (Array.unsafe_get b1 i) + done; + unsafe_blit b2 0 b l1 l2; + r + +(*s The concatenation of a list of bit vectors is obtained by iterating + [unsafe_blit]. *) + +let concat vl = + let size = List.fold_left (fun sz v -> sz + v.length) 0 vl in + let res = create size false in + let b = res.bits in + let pos = ref 0 in + List.iter + (fun v -> + let n = v.length in + unsafe_blit v.bits 0 b !pos n; + pos := !pos + n) + vl; + res + +(*s Filling is a particular case of blitting with a source made of all + ones or all zeros. Thus we instanciate [unsafe_blit], with 0 and + [max_int]. *) + +let blit_zeros v ofs len = + let (bi,bj) = pos ofs in + let (ei,ej) = pos (ofs + len - 1) in + if bi == ei then + blit_bits 0 bj len v ofs + else begin + blit_bits 0 bj (bpi - bj) v ofs; + let n = ref (ofs + bpi - bj) in + for i = succ bi to pred ei do + blit_int 0 v !n; + n := !n + bpi + done; + blit_bits 0 0 (succ ej) v !n + end + +let blit_ones v ofs len = + let (bi,bj) = pos ofs in + let (ei,ej) = pos (ofs + len - 1) in + if bi == ei then + blit_bits max_int bj len v ofs + else begin + blit_bits max_int bj (bpi - bj) v ofs; + let n = ref (ofs + bpi - bj) in + for i = succ bi to pred ei do + blit_int max_int v !n; + n := !n + bpi + done; + blit_bits max_int 0 (succ ej) v !n + end + +let fill v ofs len b = + if ofs < 0 or len < 0 or ofs + len > v.length then invalid_arg "Bitv.fill"; + if b then blit_ones v.bits ofs len else blit_zeros v.bits ofs len + +(*s All the iterators are implemented as for traditional arrays, using + [unsafe_get]. For [iter] and [map], we do not precompute [(f + true)] and [(f false)] since [f] is likely to have + side-effects. *) + +let iter f v = + for i = 0 to v.length - 1 do f (unsafe_get v i) done + +let map f v = + let l = v.length in + let r = create l false in + for i = 0 to l - 1 do + unsafe_set r i (f (unsafe_get v i)) + done; + r + +let iteri f v = + for i = 0 to v.length - 1 do f i (unsafe_get v i) done + +let mapi f v = + let l = v.length in + let r = create l false in + for i = 0 to l - 1 do + unsafe_set r i (f i (unsafe_get v i)) + done; + r + +let fold_left f x v = + let r = ref x in + for i = 0 to v.length - 1 do + r := f !r (unsafe_get v i) + done; + !r + +let fold_right f v x = + let r = ref x in + for i = v.length - 1 downto 0 do + r := f (unsafe_get v i) !r + done; + !r + +let foldi_left f x v = + let r = ref x in + for i = 0 to v.length - 1 do + r := f !r i (unsafe_get v i) + done; + !r + +let foldi_right f v x = + let r = ref x in + for i = v.length - 1 downto 0 do + r := f i (unsafe_get v i) !r + done; + !r + +(*s Bitwise operations. It is straigthforward, since bitwise operations + can be realized by the corresponding bitwise operations over integers. + However, one has to take care of normalizing the result of [bwnot] + which introduces ones in highest significant positions. *) + +let bw_and v1 v2 = + let l = v1.length in + if l <> v2.length then invalid_arg "Bitv.bw_and"; + let b1 = v1.bits + and b2 = v2.bits in + let n = Array.length b1 in + let a = Array.create n 0 in + for i = 0 to n - 1 do + a.(i) <- b1.(i) land b2.(i) + done; + { length = l; bits = a } + +let bw_or v1 v2 = + let l = v1.length in + if l <> v2.length then invalid_arg "Bitv.bw_or"; + let b1 = v1.bits + and b2 = v2.bits in + let n = Array.length b1 in + let a = Array.create n 0 in + for i = 0 to n - 1 do + a.(i) <- b1.(i) lor b2.(i) + done; + { length = l; bits = a } + +let bw_xor v1 v2 = + let l = v1.length in + if l <> v2.length then invalid_arg "Bitv.bw_xor"; + let b1 = v1.bits + and b2 = v2.bits in + let n = Array.length b1 in + let a = Array.create n 0 in + for i = 0 to n - 1 do + a.(i) <- b1.(i) lxor b2.(i) + done; + { length = l; bits = a } + +let bw_not v = + let b = v.bits in + let n = Array.length b in + let a = Array.create n 0 in + for i = 0 to n - 1 do + a.(i) <- max_int land (lnot b.(i)) + done; + let r = { length = v.length; bits = a } in + normalize r; + r + +(*s Shift operations. It is easy to reuse [unsafe_blit], although it is + probably slightly less efficient than a ad-hoc piece of code. *) + +let rec shiftl v d = + if d == 0 then + copy v + else if d < 0 then + shiftr v (-d) + else begin + let n = v.length in + let r = create n false in + if d < n then unsafe_blit v.bits 0 r.bits d (n - d); + r + end + +and shiftr v d = + if d == 0 then + copy v + else if d < 0 then + shiftl v (-d) + else begin + let n = v.length in + let r = create n false in + if d < n then unsafe_blit v.bits d r.bits 0 (n - d); + r + end + +(*s Testing for all zeros and all ones. *) + +let all_zeros v = + let b = v.bits in + let n = Array.length b in + let rec test i = + (i == n) || ((Array.unsafe_get b i == 0) && test (succ i)) + in + test 0 + +let all_ones v = + let b = v.bits in + let n = Array.length b in + let rec test i = + if i == n - 1 then + let m = v.length mod bpi in + (Array.unsafe_get b i) == (if m == 0 then max_int else low_mask.(m)) + else + ((Array.unsafe_get b i) == max_int) && test (succ i) + in + test 0 + +(*s Conversions to and from strings. *) + +let to_string v = + let n = v.length in + let s = String.make n '0' in + for i = 0 to n - 1 do + if unsafe_get v i then s.[i] <- '1' + done; + s + +let print fmt v = Format.pp_print_string fmt (to_string v) + +let of_string s = + let n = String.length s in + let v = create n false in + for i = 0 to n - 1 do + let c = String.unsafe_get s i in + if c = '1' then + unsafe_set v i true + else + if c <> '0' then invalid_arg "Bitv.of_string" + done; + v + +(*s Iteration on all bit vectors of length [n] using a Gray code. *) + +let first_set v n = + let rec lookup i = + if i = n then raise Not_found ; + if unsafe_get v i then i else lookup (i + 1) + in + lookup 0 + +let gray_iter f n = + let bv = create n false in + let rec iter () = + f bv; + unsafe_set bv 0 (not (unsafe_get bv 0)); + f bv; + let pos = succ (first_set bv n) in + if pos < n then begin + unsafe_set bv pos (not (unsafe_get bv pos)); + iter () + end + in + if n > 0 then iter () + + +(*s Coercions to/from lists of integers *) + +let of_list l = + let n = List.fold_left max 0 l in + let b = create (succ n) false in + let add_element i = + (* negative numbers are invalid *) + if i < 0 then invalid_arg "Bitv.of_list"; + unsafe_set b i true + in + List.iter add_element l; + b + +let of_list_with_length l len = + let b = create len false in + let add_element i = + if i < 0 || i >= len then invalid_arg "Bitv.of_list_with_length"; + unsafe_set b i true + in + List.iter add_element l; + b + +let to_list b = + let n = length b in + let rec make i acc = + if i < 0 then acc + else make (pred i) (if unsafe_get b i then i :: acc else acc) + in + make (pred n) [] + + +(*s To/from integers. *) + +(* [int] *) +let of_int_us i = + { length = bpi; bits = [| i land max_int |] } +let to_int_us v = + if v.length < bpi then invalid_arg "Bitv.to_int_us"; + v.bits.(0) + +let of_int_s i = + { length = succ bpi; bits = [| i land max_int; (i lsr bpi) land 1 |] } +let to_int_s v = + if v.length < succ bpi then invalid_arg "Bitv.to_int_s"; + v.bits.(0) lor (v.bits.(1) lsl bpi) + +(* [Int32] *) +let of_int32_us i = match Sys.word_size with + | 32 -> { length = 31; + bits = [| (Int32.to_int i) land max_int; + let hi = Int32.shift_right_logical i 30 in + (Int32.to_int hi) land 1 |] } + | 64 -> { length = 31; bits = [| (Int32.to_int i) land 0x7fffffff |] } + | _ -> assert false +let to_int32_us v = + if v.length < 31 then invalid_arg "Bitv.to_int32_us"; + match Sys.word_size with + | 32 -> + Int32.logor (Int32.of_int v.bits.(0)) + (Int32.shift_left (Int32.of_int (v.bits.(1) land 1)) 30) + | 64 -> + Int32.of_int (v.bits.(0) land 0x7fffffff) + | _ -> assert false + +(* this is 0xffffffff (ocaml >= 3.08 checks for literal overflow) *) +let ffffffff = (0xffff lsl 16) lor 0xffff + +let of_int32_s i = match Sys.word_size with + | 32 -> { length = 32; + bits = [| (Int32.to_int i) land max_int; + let hi = Int32.shift_right_logical i 30 in + (Int32.to_int hi) land 3 |] } + | 64 -> { length = 32; bits = [| (Int32.to_int i) land ffffffff |] } + | _ -> assert false + +let to_int32_s v = + if v.length < 32 then invalid_arg "Bitv.to_int32_s"; + match Sys.word_size with + | 32 -> + Int32.logor (Int32.of_int v.bits.(0)) + (Int32.shift_left (Int32.of_int (v.bits.(1) land 3)) 30) + | 64 -> + Int32.of_int (v.bits.(0) land ffffffff) + | _ -> assert false + +(* [Int64] *) +let of_int64_us i = match Sys.word_size with + | 32 -> { length = 63; + bits = [| (Int64.to_int i) land max_int; + (let mi = Int64.shift_right_logical i 30 in + (Int64.to_int mi) land max_int); + let hi = Int64.shift_right_logical i 60 in + (Int64.to_int hi) land 1 |] } + | 64 -> { length = 63; + bits = [| (Int64.to_int i) land max_int; + let hi = Int64.shift_right_logical i 62 in + (Int64.to_int hi) land 1 |] } + | _ -> assert false +let to_int64_us v = failwith "todo" + +let of_int64_s i = failwith "todo" +let to_int64_s v = failwith "todo" + +(* [Nativeint] *) +let select_of f32 f64 = match Sys.word_size with + | 32 -> (fun i -> f32 (Nativeint.to_int32 i)) + | 64 -> (fun i -> f64 (Int64.of_nativeint i)) + | _ -> assert false +let of_nativeint_s = select_of of_int32_s of_int64_s +let of_nativeint_us = select_of of_int32_us of_int64_us +let select_to f32 f64 = match Sys.word_size with + | 32 -> (fun i -> Nativeint.of_int32 (f32 i)) + | 64 -> (fun i -> Int64.to_nativeint (f64 i)) + | _ -> assert false +let to_nativeint_s = select_to to_int32_s to_int64_s +let to_nativeint_us = select_to to_int32_us to_int64_us + + diff --git a/external/ocamlgraph/lib/bitv.mli b/external/ocamlgraph/lib/bitv.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/lib/bitv.mli @@ -0,0 +1,195 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(*s {\bf Module Bitv}. + This module implements bit vectors, as an abstract datatype [t]. + Since bit vectors are particular cases of arrays, this module provides + the same operations as the module [Array] (Sections~\ref{barray} + up to \ref{earray}). It also provides bitwise operations + (Section~\ref{bitwise}). In the following, [false] stands for the bit 0 + and [true] for the bit 1. *) + +type t + +(*s {\bf Creation, access and assignment.} \label{barray} + [(Bitv.create n b)] creates a new bit vector of length [n], + initialized with [b]. + [(Bitv.init n f)] returns a fresh vector of length [n], + with bit number [i] initialized to the result of [(f i)]. + [(Bitv.set v n b)] sets the [n]th bit of [v] to the value [b]. + [(Bitv.get v n)] returns the [n]th bit of [v]. + [Bitv.length] returns the length (number of elements) of the given + vector. *) + +val create : int -> bool -> t + +val init : int -> (int -> bool) -> t + +val set : t -> int -> bool -> unit + +val get : t -> int -> bool + +val length : t -> int + +(*s [max_length] is the maximum length of a bit vector (System dependent). *) + +val max_length : int + +(*s {\bf Copies and concatenations.} + [(Bitv.copy v)] returns a copy of [v], + that is, a fresh vector containing the same elements as + [v]. [(Bitv.append v1 v2)] returns a fresh vector containing the + concatenation of the vectors [v1] and [v2]. [Bitv.concat] is + similar to [Bitv.append], but catenates a list of vectors. *) + +val copy : t -> t + +val append : t -> t -> t + +val concat : t list -> t + +(*s {\bf Sub-vectors and filling.} + [(Bitv.sub v start len)] returns a fresh + vector of length [len], containing the bits number [start] to + [start + len - 1] of vector [v]. Raise [Invalid_argument + "Bitv.sub"] if [start] and [len] do not designate a valid + subvector of [v]; that is, if [start < 0], or [len < 0], or [start + + len > Bitv.length a]. + + [(Bitv.fill v ofs len b)] modifies the vector [v] in place, + storing [b] in elements number [ofs] to [ofs + len - 1]. Raise + [Invalid_argument "Bitv.fill"] if [ofs] and [len] do not designate + a valid subvector of [v]. + + [(Bitv.blit v1 o1 v2 o2 len)] copies [len] elements from vector + [v1], starting at element number [o1], to vector [v2], starting at + element number [o2]. It {\em does not work} correctly if [v1] and [v2] are + the same vector with the source and destination chunks overlapping. + Raise [Invalid_argument "Bitv.blit"] if [o1] and [len] do not + designate a valid subvector of [v1], or if [o2] and [len] do not + designate a valid subvector of [v2]. *) + +val sub : t -> int -> int -> t + +val fill : t -> int -> int -> bool -> unit + +val blit : t -> int -> t -> int -> int -> unit + +(*s {\bf Iterators.} \label{earray} + [(Bitv.iter f v)] applies function [f] in turn to all + the elements of [v]. Given a function [f], [(Bitv.map f v)] applies + [f] to all + the elements of [v], and builds a vector with the results returned + by [f]. [Bitv.iteri] and [Bitv.mapi] are similar to [Bitv.iter] + and [Bitv.map] respectively, but the function is applied to the + index of the element as first argument, and the element itself as + second argument. + + [(Bitv.fold_left f x v)] computes [f (... (f (f x (get v 0)) (get + v 1)) ...) (get v (n-1))], where [n] is the length of the vector + [v]. + + [(Bitv.fold_right f a x)] computes [f (get v 0) (f (get v 1) + ( ... (f (get v (n-1)) x) ...))], where [n] is the length of the + vector [v]. *) + +val iter : (bool -> unit) -> t -> unit +val map : (bool -> bool) -> t -> t + +val iteri : (int -> bool -> unit) -> t -> unit +val mapi : (int -> bool -> bool) -> t -> t + +val fold_left : ('a -> bool -> 'a) -> 'a -> t -> 'a +val fold_right : (bool -> 'a -> 'a) -> t -> 'a -> 'a +val foldi_left : ('a -> int -> bool -> 'a) -> 'a -> t -> 'a +val foldi_right : (int -> bool -> 'a -> 'a) -> t -> 'a -> 'a + +(*s [gray_iter f n] iterates function [f] on all bit vectors + of length [n], once each, using a Gray code. The order in which + bit vectors are processed is unspecified. *) + +val gray_iter : (t -> unit) -> int -> unit + +(*s {\bf Bitwise operations.} \label{bitwise} [bwand], [bwor] and + [bwxor] implement logical and, or and exclusive or. They return + fresh vectors and raise [Invalid_argument "Bitv.xxx"] if the two + vectors do not have the same length (where \texttt{xxx} is the + name of the function). [bwnot] implements the logical negation. + It returns a fresh vector. + [shiftl] and [shiftr] implement shifts. They return fresh vectors. + [shiftl] moves bits from least to most significant, and [shiftr] + from most to least significant (think [lsl] and [lsr]). + [all_zeros] and [all_ones] respectively test for a vector only + containing zeros and only containing ones. *) + +val bw_and : t -> t -> t +val bw_or : t -> t -> t +val bw_xor : t -> t -> t +val bw_not : t -> t + +val shiftl : t -> int -> t +val shiftr : t -> int -> t + +val all_zeros : t -> bool +val all_ones : t -> bool + +(*s {\bf Conversions to and from strings.} + Least significant bit comes first. *) + +val to_string : t -> string +val of_string : string -> t +val print : Format.formatter -> t -> unit + +(*s {\bf Conversions to and from lists of integers.} + The list gives the indices of bits which are set (ie [true]). *) + +val to_list : t -> int list +val of_list : int list -> t +val of_list_with_length : int list -> int -> t + +(*s Interpretation of bit vectors as integers. Least significant bit + comes first (ie is at index 0 in the bit vector). + [to_xxx] functions truncate when the bit vector is too wide, + and raise [Invalid_argument] when it is too short. + Suffix [_s] indicates that sign bit is kept, + and [_us] that it is discarded. *) + +(* type [int] (length 31/63 with sign, 30/62 without) *) +val of_int_s : int -> t +val to_int_s : t -> int +val of_int_us : int -> t +val to_int_us : t -> int +(* type [Int32.t] (length 32 with sign, 31 without) *) +val of_int32_s : Int32.t -> t +val to_int32_s : t -> Int32.t +val of_int32_us : Int32.t -> t +val to_int32_us : t -> Int32.t +(* type [Int64.t] (length 64 with sign, 63 without) *) +val of_int64_s : Int64.t -> t +val to_int64_s : t -> Int64.t +val of_int64_us : Int64.t -> t +val to_int64_us : t -> Int64.t +(* type [Nativeint.t] (length 32/64 with sign, 31/63 without) *) +val of_nativeint_s : Nativeint.t -> t +val to_nativeint_s : t -> Nativeint.t +val of_nativeint_us : Nativeint.t -> t +val to_nativeint_us : t -> Nativeint.t + +(*s Only if you know what you are doing... *) + +val unsafe_set : t -> int -> bool -> unit +val unsafe_get : t -> int -> bool diff --git a/external/ocamlgraph/lib/heap.ml b/external/ocamlgraph/lib/heap.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/lib/heap.ml @@ -0,0 +1,236 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id:$ *) + +module type Ordered = sig + type t + val compare : t -> t -> int +end + +exception EmptyHeap + +(*s Imperative implementation *) + +module Imperative(X : Ordered) = struct + + (* The heap is encoded in the array [data], where elements are stored + from [0] to [size - 1]. From an element stored at [i], the left + (resp. right) subtree, if any, is rooted at [2*i+1] (resp. [2*i+2]). *) + + type t = { mutable size : int; mutable data : X.t array } + + (* When [create n] is called, we cannot allocate the array, since there is + no known value of type [X.t]; we'll wait for the first addition to + do it, and we remember this situation with a negative size. *) + + let create n = + if n <= 0 then invalid_arg "create"; + { size = -n; data = [||] } + + let is_empty h = h.size <= 0 + + (* [resize] doubles the size of [data] *) + + let resize h = + let n = h.size in + assert (n > 0); + let n' = 2 * n in + let d = h.data in + let d' = Array.create n' d.(0) in + Array.blit d 0 d' 0 n; + h.data <- d' + + let add h x = + (* first addition: we allocate the array *) + if h.size < 0 then begin + h.data <- Array.create (- h.size) x; h.size <- 0 + end; + let n = h.size in + (* resizing if needed *) + if n == Array.length h.data then resize h; + let d = h.data in + (* moving [x] up in the heap *) + let rec moveup i = + let fi = (i - 1) / 2 in + if i > 0 && X.compare d.(fi) x < 0 then begin + d.(i) <- d.(fi); + moveup fi + end else + d.(i) <- x + in + moveup n; + h.size <- n + 1 + + let maximum h = + if h.size <= 0 then raise EmptyHeap; + h.data.(0) + + let remove h = + if h.size <= 0 then raise EmptyHeap; + let n = h.size - 1 in + h.size <- n; + let d = h.data in + let x = d.(n) in + (* moving [x] down in the heap *) + let rec movedown i = + let j = 2 * i + 1 in + if j < n then + let j = + let j' = j + 1 in + if j' < n && X.compare d.(j') d.(j) > 0 then j' else j + in + if X.compare d.(j) x > 0 then begin + d.(i) <- d.(j); + movedown j + end else + d.(i) <- x + else + d.(i) <- x + in + movedown 0 + + let pop_maximum h = let m = maximum h in remove h; m + + let iter f h = + let d = h.data in + for i = 0 to h.size - 1 do f d.(i) done + + let fold f h x0 = + let n = h.size in + let d = h.data in + let rec foldrec x i = + if i >= n then x else foldrec (f d.(i) x) (succ i) + in + foldrec x0 0 + +end + + +(*s Functional implementation *) + +module type FunctionalSig = sig + type elt + type t + val empty : t + val add : elt -> t -> t + val maximum : t -> elt + val remove : t -> t + val iter : (elt -> unit) -> t -> unit + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a +end + +module Functional(X : Ordered) = struct + + (* Heaps are encoded as complete binary trees, i.e., binary trees + which are full expect, may be, on the bottom level where it is filled + from the left. + These trees also enjoy the heap property, namely the value of any node + is greater or equal than those of its left and right subtrees. + + There are 4 kinds of complete binary trees, denoted by 4 constructors: + [FFF] for a full binary tree (and thus 2 full subtrees); + [PPF] for a partial tree with a partial left subtree and a full + right subtree; + [PFF] for a partial tree with a full left subtree and a full right subtree + (but of different heights); + and [PFP] for a partial tree with a full left subtree and a partial + right subtree. *) + + type elt = X.t + + type t = + | Empty + | FFF of t * X.t * t (* full (full, full) *) + | PPF of t * X.t * t (* partial (partial, full) *) + | PFF of t * X.t * t (* partial (full, full) *) + | PFP of t * X.t * t (* partial (full, partial) *) + + let empty = Empty + + (* smart constructors for insertion *) + let p_f l x r = match l with + | Empty | FFF _ -> PFF (l, x, r) + | _ -> PPF (l, x, r) + + let pf_ l x = function + | Empty | FFF _ as r -> FFF (l, x, r) + | r -> PFP (l, x, r) + + let rec add x = function + | Empty -> + FFF (Empty, x, Empty) + (* insertion to the left *) + | FFF (l, y, r) | PPF (l, y, r) -> + if X.compare x y > 0 then p_f (add y l) x r else p_f (add x l) y r + (* insertion to the right *) + | PFF (l, y, r) | PFP (l, y, r) -> + if X.compare x y > 0 then pf_ l x (add y r) else pf_ l y (add x r) + + let maximum = function + | Empty -> raise EmptyHeap + | FFF (_, x, _) | PPF (_, x, _) | PFF (_, x, _) | PFP (_, x, _) -> x + + (* smart constructors for removal; note that they are different + from the ones for insertion! *) + let p_f l x r = match l with + | Empty | FFF _ -> FFF (l, x, r) + | _ -> PPF (l, x, r) + + let pf_ l x = function + | Empty | FFF _ as r -> PFF (l, x, r) + | r -> PFP (l, x, r) + + let rec remove = function + | Empty -> + raise EmptyHeap + | FFF (Empty, _, Empty) -> + Empty + | PFF (l, _, Empty) -> + l + (* remove on the left *) + | PPF (l, x, r) | PFF (l, x, r) -> + let xl = maximum l in + let xr = maximum r in + let l' = remove l in + if X.compare xl xr >= 0 then + p_f l' xl r + else + p_f l' xr (add xl (remove r)) + (* remove on the right *) + | FFF (l, x, r) | PFP (l, x, r) -> + let xl = maximum l in + let xr = maximum r in + let r' = remove r in + if X.compare xl xr > 0 then + pf_ (add xr (remove l)) xl r' + else + pf_ l xr r' + + let rec iter f = function + | Empty -> + () + | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> + iter f l; f x; iter f r + + let rec fold f h x0 = match h with + | Empty -> + x0 + | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> + fold f l (fold f r (f x x0)) + +end diff --git a/external/ocamlgraph/lib/heap.mli b/external/ocamlgraph/lib/heap.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/lib/heap.mli @@ -0,0 +1,99 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + + +module type Ordered = sig + type t + val compare : t -> t -> int +end + +exception EmptyHeap + +(*S Imperative implementation. *) + +module Imperative(X: Ordered) : sig + + (* Type of imperative heaps. + (In the following [n] refers to the number of elements in the heap) *) + + type t + + (* [create c] creates a new heap, with initial capacity of [c] *) + val create : int -> t + + (* [is_empty h] checks the emptiness of [h] *) + val is_empty : t -> bool + + (* [add x h] adds a new element [x] in heap [h]; size of [h] is doubled + when maximum capacity is reached; complexity $O(log(n))$ *) + val add : t -> X.t -> unit + + (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] + when [h] is empty; complexity $O(1)$ *) + val maximum : t -> X.t + + (* [remove h] removes the maximum element of [h]; raises [EmptyHeap] + when [h] is empty; complexity $O(log(n))$ *) + val remove : t -> unit + + (* [pop_maximum h] removes the maximum element of [h] and returns it; + raises [EmptyHeap] when [h] is empty; complexity $O(log(n))$ *) + val pop_maximum : t -> X.t + + (* usual iterators and combinators; elements are presented in + arbitrary order *) + val iter : (X.t -> unit) -> t -> unit + + val fold : (X.t -> 'a -> 'a) -> t -> 'a -> 'a + +end + +(*S Functional implementation. *) + +module type FunctionalSig = sig + + (* heap elements *) + type elt + + (* Type of functional heaps *) + type t + + (* The empty heap *) + val empty : t + + (* [add x h] returns a new heap containing the elements of [h], plus [x]; + complexity $O(log(n))$ *) + val add : elt -> t -> t + + (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] + when [h] is empty; complexity $O(1)$ *) + val maximum : t -> elt + + (* [remove h] returns a new heap containing the elements of [h], except + the maximum of [h]; raises [EmptyHeap] when [h] is empty; + complexity $O(log(n))$ *) + val remove : t -> t + + (* usual iterators and combinators; elements are presented in + arbitrary order *) + val iter : (elt -> unit) -> t -> unit + + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + +end + +module Functional(X: Ordered) : FunctionalSig with type elt = X.t diff --git a/external/ocamlgraph/lib/unionfind.ml b/external/ocamlgraph/lib/unionfind.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/lib/unionfind.ml @@ -0,0 +1,117 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id:$ *) + +module type HashedOrderedType = sig + type t + val equal : t -> t -> bool + val hash : t -> int + val compare : t -> t -> int +end + +module type S = sig + type elt + type t + + val init : elt list -> t + val find : elt -> t -> elt + val union : elt -> elt -> t -> unit +end + +module Make(X:HashedOrderedType) = struct + + type elt = X.t + + module H = Hashtbl.Make(X) + + type cell = { + mutable c : int; + data : elt; + mutable father : cell + } + + type t = cell H.t (* a forest *) + + let init l = + let h = H.create 997 in + List.iter + (fun x -> + let rec cell = { c = 0; data = x; father = cell } in + H.add h x cell) + l; + h + + let rec find_aux cell = + if cell.father == cell then + cell + else + let r = find_aux cell.father in + cell.father <- r; + r + + let find x h = (find_aux (H.find h x)).data + + let union x y h = + let rx = find_aux (H.find h x) in + let ry = find_aux (H.find h y) in + if rx != ry then begin + if rx.c > ry.c then + ry.father <- rx + else if rx.c < ry.c then + rx.father <- ry + else begin + rx.c <- rx.c + 1; + ry.father <- rx + end + end +end + +(*** test ***) +(*** + +module M = Make (struct + type t = int let + hash = Hashtbl.hash + let compare = compare + let equal = (=) + end) + +open Printf + +let saisir s = + printf "%s = " s; flush stdout; + let x = read_int () in + x + +let h = M.init [0;1;2;3;4;5;6;7;8;9] +let () = if not !Sys.interactive then + while true do + printf "1) find\n2) union\n"; + match read_int () with + 1 -> begin + let x = saisir "x" in + printf "%d\n" (M.find x h) + end + | 2 -> begin + let x, y = saisir "x", saisir "y" in + M.union x y h + end + | _ -> () + done + +***) diff --git a/external/ocamlgraph/lib/unionfind.mli b/external/ocamlgraph/lib/unionfind.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/lib/unionfind.mli @@ -0,0 +1,49 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + + + +(* Unionfind structure over hash-ordered types. + + This module implements a unionfind data structure, given a total ordering + function and a hash function over the elements. + +*) + + +module type HashedOrderedType = sig + (* The type of the elements*) + type t + val equal : t -> t -> bool + val hash : t -> int + val compare : t -> t -> int +end + +(* Input signature of the functor Unionfind.Make *) + +module type S = sig + type elt + type t + + val init : elt list -> t + val find : elt -> t -> elt + val union : elt -> elt -> t -> unit +end + +module Make (X : HashedOrderedType) : S with type elt = X.t + + diff --git a/external/ocamlgraph/src/blocks.ml b/external/ocamlgraph/src/blocks.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/blocks.ml @@ -0,0 +1,650 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: per_imp.ml,v 1.32 2006-02-03 09:27:29 filliatr Exp $ *) + +(** Common implementation to persistent and imperative graphs. *) + +open Sig +open Util + +let cpt_vertex = ref min_int + (* global counter for abstract vertex *) + +(* ************************************************************************* *) +(** {2 Association table builder} *) +(* ************************************************************************* *) + +(** Common signature to an imperative/persistent association table *) +module type HM = sig + type 'a return + type 'a t + type key + val create : int -> 'a t + val create_from : 'a t -> 'a t + val empty : 'a return + val is_empty : 'a t -> bool + val add : key -> 'a -> 'a t -> 'a t + val remove : key -> 'a t -> 'a t + val mem : key -> 'a t -> bool + val find : key -> 'a t -> 'a + val find_and_raise : key -> 'a t -> string -> 'a + (** [find_and_raise k t s] is equivalent to [find k t] but + raises [Invalid_argument s] when [find k t] raises [Not_found] *) + + val iter : (key -> 'a -> unit) -> 'a t -> unit + val map : (key -> 'a -> key * 'a) -> 'a t -> 'a t + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val copy : 'a t -> 'a t +end + +module type TBL_BUILDER = functor(X: COMPARABLE) -> HM with type key = X.t + +(** [HM] implementation using hashtbl. *) +module Make_Hashtbl(X: COMPARABLE) = struct + + include Hashtbl.Make(X) + + type 'a return = unit + let empty = () + (* never call and not visible for the user thank's to signature + constraints *) + + let create_from h = create (length h) + + let is_empty h = (length h = 0) + + let find_and_raise k h s = try find h k with Not_found -> invalid_arg s + + let map f h = + let h' = create_from h in + iter (fun k v -> let k, v = f k v in add h' k v) h; + h' + + let add k v h = replace h k v; h + let remove k h = remove h k; h + let mem k h = mem h k + let find k h = find h k + +end + +(** [HM] implementation using map *) +module Make_Map(X: COMPARABLE) = struct + include Map.Make(X) + type 'a return = 'a t + let is_empty m = (m = empty) + let create _ = assert false + (* never call and not visible for the user thank's to + signature constraints *) + let create_from _ = empty + let copy m = m + let map f m = fold (fun k v m -> let k, v = f k v in add k v m) m empty + let find_and_raise k h s = try find k h with Not_found -> invalid_arg s +end + +(* ************************************************************************* *) +(** {2 Blocks builder} *) +(* ************************************************************************* *) + +(** Common implementation to all (directed) graph implementations. *) +module Minimal(S: Set.S)(HM: HM) = struct + + type vertex = HM.key + + let is_directed = true + let empty = HM.empty + let create = HM.create + let is_empty = HM.is_empty + + let nb_vertex g = HM.fold (fun _ _ -> succ) g 0 + let nb_edges g = HM.fold (fun _ s n -> n + S.cardinal s) g 0 + let out_degree g v = + S.cardinal (try HM.find v g with Not_found -> invalid_arg "out_degree") + + let mem_vertex g v = HM.mem v g + + let unsafe_add_vertex g v = HM.add v S.empty g + let unsafe_add_edge g v1 v2 = HM.add v1 (S.add v2 (HM.find v1 g)) g + + let add_vertex g v = if HM.mem v g then g else unsafe_add_vertex g v + + let iter_vertex f = HM.iter (fun v _ -> f v) + let fold_vertex f = HM.fold (fun v _ -> f v) + +end + +(** All the predecessor operations from the iterators on the edges *) +module Pred(S: sig + module PV: COMPARABLE + module PE: EDGE with type vertex = PV.t + type t + val mem_vertex : PV.t -> t -> bool + val iter_edges : (PV.t -> PV.t -> unit) -> t -> unit + val fold_edges : (PV.t -> PV.t -> 'a -> 'a) -> t -> 'a -> 'a + val iter_edges_e : (PE.t -> unit) -> t -> unit + val fold_edges_e : (PE.t -> 'a -> 'a) -> t -> 'a -> 'a + end) = +struct + + open S + + let iter_pred f g v = + if not (mem_vertex v g) then invalid_arg "iter_pred"; + iter_edges (fun v1 v2 -> if PV.equal v v2 then f v1) g + + let fold_pred f g v = + if not (mem_vertex v g) then invalid_arg "fold_pred"; + fold_edges (fun v1 v2 a -> if PV.equal v v2 then f v1 a else a) g + + let pred g v = fold_pred (fun v l -> v :: l) g v [] + + let in_degree g v = + if not (mem_vertex v g) then invalid_arg "in_degree"; + fold_pred (fun v n -> n + 1) g v 0 + + let iter_pred_e f g v = + if not (mem_vertex v g) then invalid_arg "iter_pred_e"; + iter_edges_e (fun e -> if PV.equal v (PE.dst e) then f e) g + + let fold_pred_e f g v = + if not (mem_vertex v g) then invalid_arg "fold_pred_e"; + fold_edges_e (fun e a -> if PV.equal v (PE.dst e) then f e a else a) g + + let pred_e g v = fold_pred_e (fun v l -> v :: l) g v [] + +end + +(** Common implementation to all the unlabeled (directed) graphs. *) +module Unlabeled(V: COMPARABLE)(HM: HM with type key = V.t) = struct + + module S = Set.Make(V) + + module E = struct + type vertex = V.t + include OTProduct(V)(V) + let src = fst + let dst = snd + type label = unit + let label _ = () + let create v1 () v2 = v1, v2 + end + + type edge = E.t + + let mem_edge g v1 v2 = + try + S.mem v2 (HM.find v1 g) + with Not_found -> + false + + let mem_edge_e g (v1, v2) = mem_edge g v1 v2 + + let find_edge g v1 v2 = if mem_edge g v1 v2 then v1, v2 else raise Not_found + + let unsafe_remove_edge g v1 v2 = HM.add v1 (S.remove v2 (HM.find v1 g)) g + let unsafe_remove_edge_e g (v1, v2) = unsafe_remove_edge g v1 v2 + + let remove_edge g v1 v2 = + if not (HM.mem v2 g) then invalid_arg "remove_edge"; + HM.add v1 (S.remove v2 (HM.find_and_raise v1 g "remove_edge")) g + + let remove_edge_e g (v1, v2) = remove_edge g v1 v2 + + let iter_succ f g v = S.iter f (HM.find_and_raise v g "iter_succ") + let fold_succ f g v = S.fold f (HM.find_and_raise v g "fold_succ") + + let iter_succ_e f g v = iter_succ (fun v2 -> f (v, v2)) g v + let fold_succ_e f g v = fold_succ (fun v2 -> f (v, v2)) g v + + let succ g v = S.elements (HM.find_and_raise v g "succ") + let succ_e g v = fold_succ_e (fun e l -> e :: l) g v [] + + let map_vertex f = + HM.map (fun v s -> f v, S.fold (fun v s -> S.add (f v) s) s S.empty) + + module I = struct + type t = S.t HM.t + module PV = V + module PE = E + let iter_edges f = HM.iter (fun v -> S.iter (f v)) + let fold_edges f = HM.fold (fun v -> S.fold (f v)) + let iter_edges_e f = iter_edges (fun v1 v2 -> f (v1, v2)) + let fold_edges_e f = fold_edges (fun v1 v2 a -> f (v1, v2) a) + end + include I + + include Pred(struct include I let mem_vertex = HM.mem end) + +end + +(** Common implementation to all the labeled (directed) graphs. *) +module Labeled(V: COMPARABLE)(E: ORDERED_TYPE)(HM: HM with type key = V.t) = +struct + + module VE = OTProduct(V)(E) + + module S = Set.Make(VE) + + module E = struct + type vertex = V.t + type label = E.t + type t = vertex * label * vertex + let src (v, _, _) = v + let dst (_, _, v) = v + let label (_, l, _) = l + let create v1 l v2 = v1, l, v2 + module C = OTProduct(V)(VE) + let compare (x1, x2, x3) (y1, y2, y3) = + C.compare (x1, (x3, x2)) (y1, (y3, y2)) + end + + type edge = E.t + + let mem_edge g v1 v2 = + try + S.exists (fun (v2', _) -> V.equal v2 v2') (HM.find v1 g) + with Not_found -> + false + + let mem_edge_e g (v1, l, v2) = + try + let ve = v2, l in + S.exists (fun ve' -> VE.compare ve ve' == 0) (HM.find v1 g) + with Not_found -> + false + + exception Found of edge + let find_edge g v1 v2 = + try + S.iter + (fun (v2', l) -> if V.equal v2 v2' then raise (Found (v1, l, v2'))) + (HM.find v1 g); + raise Not_found + with Found e -> + e + + let unsafe_remove_edge g v1 v2 = + HM.add v1 (S.filter + (fun (v2', _) -> not (V.equal v2 v2')) (HM.find v1 g)) g + + let unsafe_remove_edge_e g (v1, l, v2) = + HM.add v1 (S.remove (v2, l) (HM.find v1 g)) g + + let remove_edge g v1 v2 = + if not (HM.mem v2 g) then invalid_arg "remove_edge"; + HM.add v1 (S.filter + (fun (v2', _) -> not (V.equal v2 v2')) + (HM.find_and_raise v1 g "remove_edge")) g + + let remove_edge_e g (v1, l, v2) = + if not (HM.mem v2 g) then invalid_arg "remove_edge_e"; + HM.add v1 (S.remove (v2, l) (HM.find_and_raise v1 g "remove_edge_e")) g + + let iter_succ f g v = + S.iter (fun (w, _) -> f w) (HM.find_and_raise v g "iter_succ") + let fold_succ f g v = + S.fold (fun (w, _) -> f w) (HM.find_and_raise v g "fold_succ") + + let iter_succ_e f g v = + S.iter (fun (w, l) -> f (v, l, w)) (HM.find_and_raise v g "iter_succ_e") + let fold_succ_e f g v = + S.fold (fun (w, l) -> f (v, l, w)) (HM.find_and_raise v g "fold_succ_e") + + let succ g v = fold_succ (fun w l -> w :: l) g v [] + let succ_e g v = fold_succ_e (fun e l -> e :: l) g v [] + + let map_vertex f = + HM.map (fun v s -> + f v, S.fold (fun (v, l) s -> S.add (f v, l) s) s S.empty) + + module I = struct + type t = S.t HM.t + module PV = V + module PE = E + + let iter_edges f = HM.iter (fun v -> S.iter (fun (w, _) -> f v w)) + let fold_edges f = HM.fold (fun v -> S.fold (fun (w, _) -> f v w)) + let iter_edges_e f = + HM.iter (fun v -> S.iter (fun (w, l) -> f (v, l, w))) + let fold_edges_e f = + HM.fold (fun v -> S.fold (fun (w, l) -> f (v, l, w))) + end + include I + + include Pred(struct include I let mem_vertex = HM.mem end) + +end + +(** The vertex module and the vertex table for the concrete graphs. *) +module ConcreteVertex(F : TBL_BUILDER)(V: COMPARABLE) = struct + + module V = struct + include V + type label = t + let label v = v + let create v = v + end + + module HM = F(V) + +end + +(* Support for explicitly maintaining edge set of + predecessors. Crucial for algorithms that do a lot of backwards + traversal. *) + +module BidirectionalMinimal(S:Set.S)(HM:HM with type key = S.elt) = +struct + + type vertex = HM.key + + let is_directed = true + let empty = HM.empty + let create = HM.create + let is_empty = HM.is_empty + + let nb_vertex g = HM.fold (fun _ _ -> succ) g 0 + let nb_edges g = HM.fold (fun _ (_,s) n -> n + S.cardinal s) g 0 + let out_degree g v = + S.cardinal (snd (try HM.find v g with Not_found -> invalid_arg "out_degree")) + + let mem_vertex g v = HM.mem v g + + let unsafe_add_vertex g v = HM.add v (S.empty,S.empty) g + let unsafe_add_edge g v1 v2 = + let (in_set,out_set) = HM.find v1 g + in + ignore ( HM.add v1 (in_set,S.add v2 out_set) g ) ; + let (in_set,out_set) = HM.find v2 g + in + HM.add v2 (S.add v1 in_set,out_set) g + + let iter_vertex f = HM.iter (fun v _ -> f v) + let fold_vertex f = HM.fold (fun v _ -> f v) +end + +module BidirectionalUnlabeled(V:COMPARABLE)(HM:HM with type key = V.t) = +struct + + module S = Set.Make(V) + + (* Edge definition *) + + module E = struct + type vertex = V.t + include OTProduct(V)(V) + let src = fst + let dst = snd + type label = unit + let label _ = () + let create v1 () v2 = v1, v2 + end + + type edge = E.t + + let mem_edge g v1 v2 = + try S.mem v2 (snd (HM.find v1 g)) + with Not_found -> false + + let mem_edge_e g (v1,v2) = mem_edge g v1 v2 + + let find_edge g v1 v2 = if mem_edge g v1 v2 then v1, v2 else raise Not_found + + let unsafe_remove_edge g v1 v2 = + let (in_set,out_set) = HM.find v1 g in + ignore ( HM.add v1 (in_set,( S.remove v2 out_set )) g ) ; + let (in_set,out_set) = HM.find v2 g in + HM.add v2 (S.remove v1 in_set,out_set) g + + let unsafe_remove_edge_e g (v1,v2) = unsafe_remove_edge g v1 v2 + + let remove_edge g v1 v2 = + if not (HM.mem v2 g) then invalid_arg "remove_edge"; + unsafe_remove_edge g v1 v2 + (* HM.add v1 (S.remove v2 (HM.find_and_raise v1 g "remove_edge")) g *) + + let remove_edge_e g (v1, v2) = remove_edge g v1 v2 + + let iter_succ f g v = S.iter f (snd (HM.find_and_raise v g "iter_succ")) + let fold_succ f g v = S.fold f (snd (HM.find_and_raise v g "fold_succ")) + + let iter_succ_e f g v = iter_succ (fun v2 -> f (v, v2)) g v + let fold_succ_e f g v = fold_succ (fun v2 -> f (v, v2)) g v + + let succ g v = S.elements (snd (HM.find_and_raise v g "succ")) + let succ_e g v = fold_succ_e (fun e l -> e :: l) g v [] + + let map_vertex f = + HM.map (fun v (s1,s2) -> + f v, + ( S.fold (fun v s -> S.add (f v) s) s1 S.empty, + S.fold (fun v s -> S.add (f v) s) s2 S.empty ) + ) + + module I = struct + (* we keep sets for both incoming and outgoing edges *) + type t = (S.t * S.t) HM.t + module PV = V + module PE = E + let iter_edges f = HM.iter (fun v (_,outset) -> S.iter (f v) outset ) + let fold_edges f = HM.fold (fun v (_,outset) -> S.fold (f v) outset ) + let iter_edges_e f = iter_edges (fun v1 v2 -> f (v1, v2)) + let fold_edges_e f = fold_edges (fun v1 v2 a -> f (v1, v2) a) + end + include I + + let iter_pred f g v = S.iter f (fst (HM.find_and_raise v g "iter_pred")) + let fold_pred f g v = S.fold f (fst (HM.find_and_raise v g "fold_pred")) + + let pred g v = S.elements (fst (HM.find_and_raise v g "pred")) + + let in_degree g v = + S.cardinal + (fst (try HM.find v g with Not_found -> invalid_arg "in_degree")) + + let iter_pred_e f g v = iter_pred (fun v2 -> f (v2,v)) g v + let fold_pred_e f g v = fold_pred (fun v2 -> f (v2,v)) g v + + let pred_e g v = fold_pred_e (fun e l -> e :: l) g v [] +end + +module Make_Abstract + (G: sig + module HM: HM + module S: Set.S + include G with type t = S.t HM.t and type V.t = HM.key + val remove_edge: t -> vertex -> vertex -> t + val remove_edge_e: t -> edge -> t + val unsafe_add_vertex: t -> vertex -> t + val unsafe_add_edge: t -> vertex -> S.elt -> t + val unsafe_remove_edge: t -> vertex -> vertex -> t + val unsafe_remove_edge_e: t -> edge -> t + val empty: S.t HM.return + val create: int -> t + end) = +struct + + module I = struct + type t = { edges : G.t; mutable size : int } + (* BE CAREFUL: [size] is only mutable in the imperative version. + As there is no extensible records in current ocaml version, + and for genericity purpose, [size] is mutable in both the + imperative and persistent implementation. + Do not modify size in the persistent implementation! *) + + type vertex = G.vertex + type edge = G.edge + + module PV = G.V + module PE = G.E + + let iter_edges f g = G.iter_edges f g.edges + let fold_edges f g = G.fold_edges f g.edges + let iter_edges_e f g = G.iter_edges_e f g.edges + let fold_edges_e f g = G.fold_edges_e f g.edges + let mem_vertex v g = G.mem_vertex g.edges v + end + include I + + include Pred(I) + + (* optimisations *) + + let is_empty g = g.size = 0 + let nb_vertex g = g.size + + (* redefinitions *) + module V = G.V + module E = G.E + module HM = G.HM + module S = G.S + + let unsafe_add_edge = G.unsafe_add_edge + let unsafe_remove_edge = G.unsafe_remove_edge + let unsafe_remove_edge_e = G.unsafe_remove_edge_e + let is_directed = G.is_directed + + let remove_edge g = G.remove_edge g.edges + let remove_edge_e g = G.remove_edge_e g.edges + + let out_degree g = G.out_degree g.edges + let in_degree g = G.in_degree g.edges + + let nb_edges g = G.nb_edges g.edges + let succ g = G.succ g.edges + let mem_vertex g = G.mem_vertex g.edges + let mem_edge g = G.mem_edge g.edges + let mem_edge_e g = G.mem_edge_e g.edges + let find_edge g = G.find_edge g.edges + + let iter_vertex f g = G.iter_vertex f g.edges + let fold_vertex f g = G.fold_vertex f g.edges + let iter_succ f g = G.iter_succ f g.edges + let fold_succ f g = G.fold_succ f g.edges + let succ_e g = G.succ_e g.edges + let iter_succ_e f g = G.iter_succ_e f g.edges + let fold_succ_e f g = G.fold_succ_e f g.edges + let map_vertex f g = { g with edges = G.map_vertex f g.edges } + +end + +(** Build persistent (resp. imperative) graphs from a persistent (resp. + imperative) association table *) +module Make(F : TBL_BUILDER) = struct + + module Digraph = struct + + module Concrete(V: COMPARABLE) = struct + include ConcreteVertex(F)(V) + include Unlabeled(V)(HM) + include Minimal(S)(HM) + + let add_edge g v1 v2 = + let g = add_vertex g v1 in + let g = add_vertex g v2 in + unsafe_add_edge g v1 v2 + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_vertex g v = + if HM.mem v g then + let g = HM.remove v g in + HM.fold + (fun k s g -> HM.add k (S.remove v s) g) + g + (HM.create_from g) + else + g + + end + + module ConcreteBidirectional(V: COMPARABLE) = struct + include ConcreteVertex(F)(V) + include BidirectionalUnlabeled(V)(HM) + include BidirectionalMinimal(S)(HM) + end + + module ConcreteLabeled(V: COMPARABLE)(E: ORDERED_TYPE_DFT) = struct + include ConcreteVertex(F)(V) + include Labeled(V)(E)(HM) + include Minimal(S)(HM) + end + + module Abstract(V: VERTEX) = struct + module G = struct + module V = V + module HM = F(V) + include Unlabeled(V)(HM) + include Minimal(S)(HM) + end + include Make_Abstract(G) + end + + module AbstractLabeled(V: VERTEX)(E: ORDERED_TYPE_DFT) = struct + module G = struct + module V = V + module HM = F(V) + include Labeled(V)(E)(HM) + include Minimal(S)(HM) + end + include Make_Abstract(G) + end + + end + +end + +(** Implementation of undirected graphs from implementation of directed + graphs. *) +module Graph(G: Sig.G) = struct + + include G + + let is_directed = false + + (* Redefine iterators and [nb_edges]. *) + + let iter_edges f = + iter_edges (fun v1 v2 -> if V.compare v1 v2 >= 0 then f v1 v2) + + let fold_edges f = + fold_edges + (fun v1 v2 acc -> if V.compare v1 v2 >= 0 then f v1 v2 acc else acc) + + let iter_edges_e f = + iter_edges_e + (fun e -> if V.compare (E.src e) (E.dst e) >= 0 then f e) + + let fold_edges_e f = + fold_edges_e + (fun e acc -> + if V.compare (E.src e) (E.dst e) >= 0 then f e acc else acc) + + let nb_edges g = fold_edges_e (fun _ -> (+) 1) g 0 + + (* Redefine operations on predecessors: + predecessors are successors in an undirected graph. *) + + let pred = succ + let in_degree = out_degree + let iter_pred = iter_succ + let fold_pred = fold_succ + let pred_e = succ_e + let iter_pred_e = iter_succ_e + let fold_pred_e = fold_succ_e + +end diff --git a/external/ocamlgraph/src/builder.ml b/external/ocamlgraph/src/builder.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/builder.ml @@ -0,0 +1,49 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: builder.ml,v 1.12 2004-02-20 14:37:40 signoles Exp $ *) + +open Sig + +module type S = sig + module G : Sig.G + val empty : unit -> G.t + val copy : G.t -> G.t + val add_vertex : G.t -> G.V.t -> G.t + val add_edge : G.t -> G.V.t -> G.V.t -> G.t + val add_edge_e : G.t -> G.E.t -> G.t +end + +module type INT = S with type G.V.label = int + +module P(G : Sig.P) = struct + module G = G + let empty () = G.empty + let copy g = g + let add_vertex = G.add_vertex + let add_edge = G.add_edge + let add_edge_e = G.add_edge_e +end + +module I(G : Sig.I) = struct + module G = G + let empty () = G.create ~size:997 () + let copy = G.copy + let add_vertex g v = G.add_vertex g v; g + let add_edge g v1 v2 = G.add_edge g v1 v2; g + let add_edge_e g e = G.add_edge_e g e; g +end diff --git a/external/ocamlgraph/src/builder.mli b/external/ocamlgraph/src/builder.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/builder.mli @@ -0,0 +1,47 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: builder.mli,v 1.13 2004-02-20 14:37:40 signoles Exp $ *) + +(** Graph builders *) + +open Sig + +(** {1 Common interface for graph builders}. + + Note: the following functions always return graphs but this is meaningless + for imperative implementations (the graph is modified in-place). + This is just to provide a common interface. *) + +module type S = sig + module G : Sig.G + val empty : unit -> G.t + val copy : G.t -> G.t + val add_vertex : G.t -> G.V.t -> G.t + val add_edge : G.t -> G.V.t -> G.V.t -> G.t + val add_edge_e : G.t -> G.E.t -> G.t +end + +module type INT = S with type G.V.label = int + +(** {1 Builders for the various graph implementations} *) + +module P(G : Sig.P) : S with module G = G + (** Persistent Graphs Builders *) + +module I(G : Sig.I) : S with module G = G + (** Imperative Graphs Builders *) diff --git a/external/ocamlgraph/src/classic.ml b/external/ocamlgraph/src/classic.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/classic.ml @@ -0,0 +1,85 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: classic.ml,v 1.9 2004-02-02 08:11:14 filliatr Exp $ *) + +module type S = sig + type graph + val divisors : int -> graph + val de_bruijn : int -> graph + val vertex_only : int -> graph + val full : ?self:bool -> int -> graph +end + +module Generic(B : Builder.INT) = struct + + type graph = B.G.t + + let divisors n = + if n < 2 then invalid_arg "divisors"; + let v = Array.init (n + 1) (fun i -> B.G.V.create i) in + let rec loop g i = + let sqrt_i = truncate (sqrt (float i)) in + let rec loop_i g d = + if d > sqrt_i then + g + else if i mod d == 0 then + loop_i (B.add_edge (B.add_edge g v.(i / d) v.(i)) v.(d) v.(i)) (d+1) + else + loop_i g (succ d) + in + if i > n then g else loop (loop_i (B.add_vertex g v.(i)) 2) (i+1) + in + loop (B.empty ()) 2 + + let fold_for i0 i1 f = + let rec loop i v = if i > i1 then v else loop (i + 1) (f v i) in + loop i0 + + let de_bruijn n = + if n < 1 || n > Sys.word_size - 1 then invalid_arg "de_bruijn"; + let v = Array.init (1 lsl n) (fun i -> B.G.V.create i) in + let all_1 = 1 lsl n - 1 in (* 11...1 *) + let g = fold_for 0 all_1 (fun g i -> B.add_vertex g v.(i)) (B.empty ()) in + let rec loop g i = + if i > all_1 then + g + else + let si = (i lsl 1) land all_1 in + let g = B.add_edge g v.(i) v.(si) in + let g = B.add_edge g v.(i) v.(si lor 1) in + loop g (i + 1) + in + loop g 0 + + let vertex_only n = + fold_for 1 n (fun g i -> B.add_vertex g (B.G.V.create i)) (B.empty ()) + + let full ?(self=true) n = + let v = Array.init (n + 1) (fun i -> B.G.V.create i) in + fold_for 1 n + (fun g i -> + fold_for 1 n + (fun g j -> if self || i <> j then B.add_edge g v.(i) v.(j) else g) + g) + (fold_for 1 n (fun g i -> B.add_vertex g v.(i)) (B.empty ())) + +end + +module P (G : Sig.P with type V.label = int) = Generic(Builder.P(G)) + +module I (G : Sig.I with type V.label = int) = Generic(Builder.I(G)) diff --git a/external/ocamlgraph/src/classic.mli b/external/ocamlgraph/src/classic.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/classic.mli @@ -0,0 +1,54 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: classic.mli,v 1.12 2005-02-25 13:54:33 signoles Exp $ *) + +(** Some classic graphs *) + +module type S = sig + + type graph + + val divisors : int -> graph + (** [divisors n] builds the graph of divisors. + Vertices are integers from [2] to [n]. [i] is connected to [j] if + and only if [i] divides [j]. + @raise Invalid_argument is [n < 2]. *) + + val de_bruijn : int -> graph + (** [de_bruijn n] builds the de Bruijn graph of order [n]. + Vertices are bit sequences of length [n] (encoded as their + interpretation as binary integers). The sequence [xw] is connected + to the sequence [wy] for any bits [x] and [y] and any bit sequence + [w] of length [n-1]. + @raise Invalid_argument is [n < 1] or [n > Sys.word_size-1]. *) + + val vertex_only : int -> graph + (** [vertex_only n] builds a graph with [n] vertices and no edge. *) + + val full : ?self:bool -> int -> graph + (** [full n] builds a graph with [n] vertices and all possible edges. + The optional argument [self] indicates if loop edges should be added + (default value is [true]). *) + +end + +module P (G : Sig.P with type V.label = int) : S with type graph = G.t + (** Classic Persistent Graphs *) + +module I (G : Sig.I with type V.label = int) : S with type graph = G.t + (** Classic Imperative Graphs *) diff --git a/external/ocamlgraph/src/cliquetree.ml b/external/ocamlgraph/src/cliquetree.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/cliquetree.ml @@ -0,0 +1,343 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(** + Clique tree of a graph. + + @author Matthieu Sozeau +*) + +(*i $Id: cliquetree.ml,v 1.6 2005-11-02 13:43:35 filliatr Exp $ i*) + +module CliqueTree(Gr : Sig.G) = struct + + (* Original vertex set (of Gr) *) + module OVSet = Set.Make(Gr.V) + + (* Vertex signature *) + module rec CliqueV : + sig + type t + val compare : t -> t -> int + val hash : t -> int + val equal : t -> t -> bool + val label : t -> t + val create : Gr.V.t -> t + val vertex : t -> Gr.V.t + val number : t -> int + val set_number : t -> int -> unit + val clique : t -> int + val set_clique : t -> int -> unit + val mark : t -> int + val incr_mark : t -> unit + val m : t -> CVS.t + val set_m : t -> CVS.t -> unit + val last : t -> t + val set_last : t -> t -> unit + end = + struct + type t = { + mutable mark: int; + orig: Gr.V.t; + mutable m: CVS.t; + mutable last: t option; + mutable number: int; + mutable clique: int; + } + + let compare x y = Gr.V.compare x.orig y.orig + let hash x = Gr.V.hash x.orig + let equal x y = Gr.V.equal x.orig y.orig + + type label = t + let label x = x + + let create o = { + mark = 0; + orig = o; + m = CVS.empty; + last = None; + number = 0; + clique = -1; + } + + let vertex x = x.orig + + let clique x = x.clique + let set_clique x v = x.clique <- v + + let number x = x.number + let set_number x v = x.number <- v + + let mark x = x.mark + let incr_mark x = + (*Printf.printf "Increasing mark of %s to %i\n%!" + (Gr.v_to_string x.orig) (succ x.mark);*) + x.mark <- succ x.mark + + let m x = x.m + let set_m x v = x.m <- v + + let last x = + match x.last with + Some v -> v + | None -> failwith "last not set" + + let set_last x v = x.last <- Some v + + end + (* Clique tree vertex set *) + and CVS : Set.S with type elt = CliqueV.t = Set.Make(CliqueV) + + (* The final clique tree vertex type: + - set of original vertexes ordered by mark. + - clique number. + *) + module CliqueTreeV = + Util.DataV + (struct type t = CliqueV.t list * CVS.t end) + (struct + type t = int + type label = int + let compare x y = Pervasives.compare x y + let hash = Hashtbl.hash + let equal x y = x = y + let label x = x + let create lbl = lbl + end) + + module CliqueTreeE = struct + type t = int * CVS.t + + let compare (x, _) (y, _) = Pervasives.compare x y + + let default = (0, CVS.empty) + + let create n s = (n, s) + + let vertices = snd + + let width g tri (_, x) = + let vertices = List.map CliqueV.vertex (CVS.elements x) in + let w = + List.fold_left + (fun w v -> + List.fold_left + (fun w v' -> + if v <> v' then + if not (Gr.mem_edge g v v') && Gr.mem_edge tri v v' + then succ w + else w + else w) + w vertices) + 0 vertices + in + assert(w mod 2 = 0); + w / 2 + end + + (* The returned tree *) + module CliqueTree = + Persistent.Digraph.ConcreteLabeled(CliqueTreeV)(CliqueTreeE) + + (* Intermediate graph *) + module G = Persistent.Graph.Concrete(CliqueV) + + (* Convenient types *) + module EdgeSet = Set.Make(G.E) + module H = Hashtbl.Make(CliqueV) + + (* Used to choose some vertex in the intermediate graph *) + module Choose = Oper.Choose(G) + + (* Creates the intermediate graph from the original *) + module Copy = Gmap.Vertex(Gr)(struct include G include Builder.P(G) end) + + open CliqueV + + let vertices_list x = + let l = CVS.elements x in + List.sort + (fun x y -> + (*let markx = mark x and marky = mark y in*) + - Pervasives.compare (number x) (number y)) + l + + let mcs_clique g = + (* initializations *) + let n = Gr.nb_vertex g in + let g' = Copy.map CliqueV.create g in + let unnumbered = ref (G.fold_vertex CVS.add g' CVS.empty) in + let pmark = ref (-1) in + let order = ref [] in + let cliques = Array.make n ([], CVS.empty) in + let ties = ref [] in + let j = ref 0 in + (* loop, taking each unnumbered vertex in turn *) + for i = n downto 1 do + (* Find greatest unnumbered vertex + if CVS.is_empty !unnumbered then + Printf.printf "No more unnumbered vertices\n%!" + else + Printf.printf "%i unnumbered vertices remaining\n%!" + (CVS.cardinal !unnumbered); + *) + let x, mark = + let choosed = CVS.choose !unnumbered in + CVS.fold + (fun x ((maxx, maxv) as max) -> + let v = mark x in + if v > maxv then (x, v) else max) + !unnumbered (choosed, mark choosed) + in + (* peo construction *) + order := x :: !order; + (* now numbered *) + unnumbered := CVS.remove x !unnumbered; + if mark <= !pmark then begin + (* Create a new clique (lemma 8) *) + incr j; + (* m x is the neighborhoud of x in the previous clique *) + cliques.(!j) <- ([x], CVS.add x (m x)); + (* Use reverse map of cliques to find what clique + we're connected to. m x is the width of the ties *) + let clast = clique (last x) in + ties := (clast, m x, !j) :: !ties; + end else begin + let l, c = cliques.(!j) in + cliques.(!j) <- (x::l, CVS.add x c); + end; + G.iter_succ + (fun y -> + if number y == 0 then begin + incr_mark y; + set_m y (CVS.add x (m y)); + end; + set_last y x) + g' x; + pmark := mark; + set_number x i; + set_clique x !j; + done; + let cliques = + Array.mapi + (fun i (l, c) -> CliqueTreeV.create (List.rev l, c) i) + (Array.sub cliques 0 (succ !j)) + in + let tree = + Array.fold_left CliqueTree.add_vertex CliqueTree.empty cliques + in + let tree, _ = + List.fold_left + (fun (g, n) (i, verts, j) -> + let label = CliqueTreeE.create n verts in + let edge = CliqueTree.E.create cliques.(i) label cliques.(j) in + (CliqueTree.add_edge_e g edge, succ n)) + (tree, 1) !ties + in + List.map CliqueV.vertex !order, tree, cliques.(0) + + let sons g x = CliqueTree.fold_succ (fun x y -> x :: y) g x [] + + exception NotClique + + let rec drop_while p l = + match l with + | x :: tl -> + if p x then drop_while p tl + else l + | [] -> [] + + let test_simpliciality_first l sons = + let takeOne l = match !l with + | x :: xs -> l := xs; Some x + | [] -> None + in + let vertices = ref l in + let sons = ref sons in + try + while !vertices <> [] && not (List.for_all (fun c -> !c = []) !sons) do + (match takeOne vertices with + Some v -> + let mark = CliqueV.mark v in + List.iter + (fun s -> + match !s with + | y :: tl -> + let ymark = CliqueV.mark y in + if ymark > mark then + () + else if ymark = mark then + s := drop_while + (fun y -> CliqueV.mark y = mark) tl + else raise NotClique + | [] -> ()) + !sons + | None -> assert false); + done; + !vertices <> [] + with NotClique -> false + + let test_simpliciality_first' l sons = + List.for_all + (fun son -> + match !son with + | [] -> false + | xi :: tl -> + let other = m xi in + CVS.subset other l) + sons + + let test_simpliciality_next vertices sons = + match vertices with + | x :: tl -> + begin + try + ignore( + List.fold_left + (fun vm v' -> + let vm' = CliqueV.m v' in + if CVS.equal vm' vm then + CVS.add v' vm' + else raise NotClique) + (CVS.add x (m x)) tl); + true + with NotClique -> false + end + | _ -> true + + let is_chordal g = + let order, tree, root = mcs_clique g in + let rec aux c = + let csons = sons tree c in + let s = List.map CliqueTreeV.data csons in + let l = CliqueTreeV.data c in + let sons () = List.map (fun (x,y) -> ref x) s in + let first = test_simpliciality_first' (snd l) (sons ()) in + let next = test_simpliciality_next (fst l) (sons ()) in + first && next && (List.for_all aux csons) + in + aux root + + let maxwidth g tri tree = + CliqueTree.fold_edges_e + (fun e res -> + let w = CliqueTreeE.width g tri (CliqueTree.E.label e) in + max res w) + tree 0 + +end diff --git a/external/ocamlgraph/src/cliquetree.mli b/external/ocamlgraph/src/cliquetree.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/cliquetree.mli @@ -0,0 +1,90 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(** + Construction of the clique tree of a graph and recognition + of chordal graphs. + + Based on the article: + Chordal graphs and their clique graph + by P. Galinier, M. Habib and C. Paul. + + @author Matthieu Sozeau +*) + +(*i $Id: cliquetree.mli,v 1.4 2004-10-19 15:22:47 signoles Exp $ i*) + +module CliqueTree(G : Sig.G) : sig + + (** Original graph vertex *) + module CliqueV : + sig + type t + val compare : t -> t -> int + val hash : t -> int + val equal : t -> t -> bool + val label : t -> t + val create : G.V.t -> t + val vertex : t -> G.V.t + end + + (** Set of original vertices *) + module CVS : Set.S with type elt = CliqueV.t + + (** Clique tree vertex type *) + module CliqueTreeV : sig + (** Trace of the algorithm as a list of markers Clique vertices *) + type data = CliqueV.t list * CVS.t + type label + type t + + val compare : t -> t -> int + val hash : t -> int + val equal : t -> t -> bool + + val create : data -> label -> t + val label : t -> label + val data : t -> data + end + + module CliqueTreeE : sig + type t = int * CVS.t + val compare : t -> t -> int + val default : t + val create : int -> CVS.t -> t + + (** Vertices in the clique tree edge + (intersection of the two clique extremities). *) + val vertices : t -> CVS.t + end + + (** The clique tree graph type *) + module CliqueTree : Sig.G with type V.t = CliqueTreeV.t + and type E.label = CliqueTreeE.t + + (** [mcs_clique g] return an perfect elimination order of [g] + (if it is chordal), the clique tree of [g] and its root. *) + val mcs_clique : G.t -> G.V.t list * CliqueTree.t * CliqueTree.V.t + + (** [is_chordal g] uses the clique tree construction to test if a graph is + chordal or not. *) + val is_chordal : G.t -> bool + + (** [maxwidth g tri tree] returns the maxwidth characteristic of the + triangulation [tri] of graph [g] given the clique tree [tree] of [tri]. *) + val maxwidth : G.t -> G.t -> CliqueTree.t -> int +end diff --git a/external/ocamlgraph/src/components.ml b/external/ocamlgraph/src/components.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/components.ml @@ -0,0 +1,90 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: components.ml,v 1.9 2004-10-22 14:42:06 signoles Exp $ *) + +open Util + +module type G = sig + type t + module V : Sig.COMPARABLE + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_succ : (V.t -> unit) -> t -> V.t -> unit +end + +module Make(G: G) = struct + + module H = Hashtbl.Make(G.V) + module S = Set.Make(G.V) + + let scc g = + let root = H.create 997 in + let hashcomp = H.create 997 in + let stack = ref [] in + let numdfs = ref 0 in + let numcomp = ref 0 in + let rec pop x c = function + | (y, w) :: l when y > x -> + H.add hashcomp w !numcomp; + pop x (S.add w c) l + | l -> c,l + in + let rec visit v = + if not (H.mem root v) then + begin + let n = incr numdfs; !numdfs in + H.add root v n; + G.iter_succ + (fun w -> + visit w; + if not (H.mem hashcomp w) then + H.replace root v (min (H.find root v) (H.find root w))) + g v; + if H.find root v = n then + (H.add hashcomp v !numcomp; + let comp,s = pop n (S.add v S.empty) !stack in + stack:= s; + incr numcomp) + else stack := (n,v)::!stack; + end + in + G.iter_vertex visit g; + (!numcomp,(fun v -> H.find hashcomp v)) + + let scc_array g = + let n,f = scc g in + let t = Array.make n [] in + G.iter_vertex + (fun v -> let i = f v in t.(i) <- v::t.(i)) g; + t + + let scc_list g = + let _,scc = scc g in + let tbl = Hashtbl.create 97 in + G.iter_vertex + (fun v -> + let n = scc v in + try + let l = Hashtbl.find tbl n in + l := v :: !l + with Not_found -> + Hashtbl.add tbl n (ref [ v ])) + g; + Hashtbl.fold (fun _ v l -> !v :: l) tbl [] + + +end diff --git a/external/ocamlgraph/src/components.mli b/external/ocamlgraph/src/components.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/components.mli @@ -0,0 +1,53 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: components.mli,v 1.12 2004-10-22 14:42:06 signoles Exp $ *) + +(** Strongly connected components *) + +open Util + +(** Minimal graph signature for [scc] *) +module type G = sig + type t + module V : Sig.COMPARABLE + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_succ : (V.t -> unit) -> t -> V.t -> unit +end + +module Make (G: G) : sig + + val scc : G.t -> int*(G.V.t -> int) + (** [scc g] computes the strongly connected components of [g]. + The result is a pair [(n,f)] where [n] is the number of + components. Components are numbered from [0] to [n-1], and + [f] is a function mapping each vertex to its component + number. In particular, [f u = f v] if and only if [u] and + [v] are in the same component. Another property of the + numbering is that components are numbered in a topological + order: if there is an arc from [u] to [v], then [f u >= f u] *) + + val scc_array : G.t -> G.V.t list array + (** [scc_array] computes the strongly connected components of [g]. + Components are stored in the resulting array, indexed with a + numbering with the same properties as for [scc] above. *) + + val scc_list : G.t -> G.V.t list list + (** [scc_list] computes the strongly connected components of [g]. + The result is a partition of the set of the vertices of [g]. *) + +end diff --git a/external/ocamlgraph/src/delaunay.ml b/external/ocamlgraph/src/delaunay.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/delaunay.ml @@ -0,0 +1,344 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: delaunay.ml,v 1.12 2005-11-02 13:43:35 filliatr Exp $ *) + +(** Code follows Don Knuth's algorithm + from ``Axioms and hulls'' (LNCS 606, Springer-Verlag, 1992), pp. 73-77 *) + +open Printf + +module type CCC = sig + type point + val ccw : point -> point -> point -> bool + val in_circle : point -> point -> point -> point -> bool +end + +module type Triangulation = sig + module S : CCC + type triangulation + val triangulate : S.point array -> triangulation + val iter : (S.point -> S.point -> unit) -> triangulation -> unit + val fold : (S.point -> S.point -> 'a -> 'a) -> triangulation -> 'a -> 'a +end + +module Make (S : CCC) = struct + + module S = S + + type point = Point of int | Infinity + + type arc = { mutable vert : point; + mutable next : arc; + mutable inst : node ref; + mate : int } + and node = + | Branch of int * int * node ref * node ref + | Terminal of arc + + type triangulation = { + points : S.point array; + arcs : arc array; + last_used_arc : int + } + + let rec dummy_arc = + { vert = Infinity; next = dummy_arc; + inst = ref (Terminal dummy_arc); mate = -1 } + + let make_arc n i = + { vert = Infinity; next = dummy_arc; + inst = ref (Terminal dummy_arc); mate = 6 * n - 7 - i } + + let finite = function Point p -> p | Infinity -> assert false + + (* [flip] will be used in both steps T4 and T5 *) + let flip c d e t'' p n n' = + let e' = e.next in + let c' = c.next in + let c'' = c'.next in + e.next <- c; + c.next <- c''; + c''.next <- e; + c''.inst <- n; c.inst <- n; e.inst <- n; + c.vert <- Point p; + d.next <- e'; + e'.next <- c'; + c'.next <- d; + c'.inst <- n'; e'.inst <- n'; d.inst <- n'; + d.vert <- Point t'' + + let triangulate points = + let ccw p q r = S.ccw points.(p) points.(q) points.(r) in + let in_circle p q r s = + S.in_circle points.(p) points.(q) points.(r) points.(s) + in + let n = Array.length points in + if n < 2 then invalid_arg "triangulate"; + let arcs = Array.init (6 * n - 6) (make_arc n) in + let mate i = 6 * n - 7 - i in + + (*i DEBUG + let rec dump d l = + eprintf "%s" (String.make (2*d) ' '); + match !l with + | Terminal a -> + eprintf "T %d\n" (mate a.mate) + | Branch (u, v, l, r) -> + eprintf "N %d %d\n" u v; + dump (d+1) l; + dump (d+1) r + in + i*) + + (* initialization: + create a trivial triangulation for the first 2 vertices *) + let u = 0 in + let v = 1 in + let a1 = arcs.(0) in + let a2 = arcs.(1) in + let a3 = arcs.(2) in + let b1 = arcs.(mate 0) in + let b2 = arcs.(mate 1) in + let b3 = arcs.(mate 2) in + let l1 = ref (Terminal a2) in + let l2 = ref (Terminal b3) in + a1.vert <- Point v; a1.next <- a2; a1.inst <- l1; + a2.vert <- Infinity; a2.next <- a3; a2.inst <- l1; + a3.vert <- Point u; a3.next <- a1; a3.inst <- l1; + b1.vert <- Point u; b1.next <- b3; b1.inst <- l2; + b2.vert <- Point v; b2.next <- b1; b2.inst <- l2; + b3.vert <- Infinity; b3.next <- b2; b3.inst <- l2; + let l0 = ref (Branch (u, v, l1, l2)) in + let j = ref 2 in (* last used arc *) + + (* then for each new vertex [p] *) + for p = 2 to n - 1 do + (* Step T1 *) + let rec step_T1 l p = match !l with + | Terminal al -> + l, al + | Branch (pl, ql, al, bl) -> + step_T1 (if ccw pl ql p then al else bl) p + in + let l, al = step_T1 l0 p in + + (* Step T2 *) + let a = al in + let b = a.next in + let c = b.next in + let q = a.vert in + let r = b.vert in + let s = c.vert in + j := !j + 3; + let aj = arcs.(!j) in + let aj_1 = arcs.(!j - 1) in + let aj_2 = arcs.(!j - 2) in + let bj = arcs.(aj.mate) in + let bj_1 = arcs.(aj_1.mate) in + let bj_2 = arcs.(aj_2.mate) in + let l' = ref (Terminal a) in + let l'' = ref (Terminal aj) in + let l''' = ref (Terminal c) in + aj.vert <- q; aj.next <- b; aj.inst <- l''; + aj_1.vert <- r; aj_1.next <- c; aj_1.inst <- l'''; + aj_2.vert <- s; aj_2.next <- a; aj_2.inst <- l'; + bj.vert <- Point p; bj.next <- aj_2; bj.inst <- l'; + bj_1.vert <- Point p; bj_1.next <- aj; bj_1.inst <- l''; + bj_2.vert <- Point p; bj_2.next <- aj_1; bj_2.inst <- l'''; + a.next <- bj; a.inst <- l'; + b.next <- bj_1; b.inst <- l''; + c.next <- bj_2; c.inst <- l'''; + let r = finite r in + let s = finite s in + + (* steps T3 or T4 depending on [q] *) + let r = match q with + | Point q -> (* Step T3 *) + let n = ref (Branch (q, p, l', l'')) in + let n' = ref (Branch (s, p, l''', l')) in + l := Branch (r, p, n, n'); + r + | Infinity -> (* Step T4 *) + let n = ref (Branch (s, p, l''', l')) in + l := Branch (r, p, l'', n); + let rec loop m a d s t = + if t <> r && ccw p s t then begin + let n = ref (Terminal d) in + match !m with + | Branch (mu, mv, ml, is_l') -> + assert (is_l' == l'); + m := Branch (mu, mv, ml, d.inst); + d.inst := Branch (t, p, n, l'); + let m = d.inst in + flip a arcs.(a.mate) d t p n l'; + let a = arcs.(a.mate).next in + let d = arcs.(a.mate).next in + let s = t in + let t = finite d.vert in + l' := Terminal a; + loop m a d s t + | Terminal _ -> + assert false + end else begin + (* at exit of while loop *) + let n = ref (Terminal d.next) in + d.inst := Branch (s, p, n, l'); + d.inst <- n; d.next.inst <- n; d.next.next.inst <- n; + s + end + in + let d = arcs.(a.mate).next in + loop n a d s (finite d.vert) + in + + (* Step T5 *) + let rec loop c = + let d = arcs.(c.mate) in + let e = d.next in + let t = finite d.vert in + let t' = finite c.vert in + let t'' = e.vert in + if t'' <> Infinity && in_circle (finite t'') t' t p then begin + let t'' = finite t'' in + let n = ref (Terminal e) in + let n' = ref (Terminal d) in + c.inst := Branch (t'', p, n, n'); + d.inst := Branch (t'', p, n, n'); + flip c d e t'' p n n'; + loop e + end else if t' <> r then + loop arcs.(c.next.mate).next + else + () (* break *) + in + loop c + + done; + { points = points; arcs = arcs; last_used_arc = !j } + + let iter f t = + let points = t.points in + let n = Array.length t.arcs in + for i = 0 to t.last_used_arc do + match t.arcs.(i).vert, t.arcs.(n - 1 - i).vert with + | Point u, Point v -> f points.(u) points.(v) + | _ -> () + done + + let fold f t a = + let points = t.points in + let n = Array.length t.arcs in + let rec loop i a = + if i <= t.last_used_arc then + match t.arcs.(i).vert, t.arcs.(n - 1 - i).vert with + | Point u, Point v -> loop (succ i) (f points.(u) points.(v) a) + | _ -> loop (succ i) a + else + a + in + loop 0 a + +end + +(** Points with floating point coordinates *) + +module FloatPoints = struct + + type point = float * float + + let ( + ) = ( +. ) + let ( - ) = ( -. ) + let ( * ) = ( *. ) + + let det = function + | [| [| a00; a01 |]; + [| a10; a11 |] |] -> + a00 * a11 - a01 * a10 + | [| [| a00; a01; a02 |]; + [| a10; a11; a12 |]; + [| a20; a21; a22 |] |] -> + a00*a11*a22 - a00*a12*a21 - a10*a01*a22 + + a10*a02*a21 + a20*a01*a12 - a20*a02*a11 + | [| [| a00; a01; a02; a03 |]; + [| a10; a11; a12; a13 |]; + [| a20; a21; a22; a23 |]; + [| a30; a31; a32; a33 |] |] -> + a00*a11*a22*a33 - a00*a11*a23*a32 - a00*a21*a12*a33 + + a00*a21*a13*a32 + a00*a31*a12*a23 - a00*a31*a13*a22 - + a10*a01*a22*a33 + a10*a01*a23*a32 + a10*a21*a02*a33 - + a10*a21*a03*a32 - a10*a31*a02*a23 + a10*a31*a03*a22 + + a20*a01*a12*a33 - a20*a01*a13*a32 - a20*a11*a02*a33 + + a20*a11*a03*a32 + a20*a31*a02*a13 - a20*a31*a03*a12 - + a30*a01*a12*a23 + a30*a01*a13*a22 + a30*a11*a02*a23 - + a30*a11*a03*a22 - a30*a21*a02*a13 + a30*a21*a03*a12 + | _ -> assert false + + let ccw (xu,yu) (xv,yv) (xw,yw) = + det [| [| xu; yu; 1.0 |]; + [| xv; yv; 1.0 |]; + [| xw; yw; 1.0 |] |] > 0.0 + + (*i DEBUG + let ccw (xu,yu) (xv,yv) (xw,yw) = + eprintf "ccw((%.0f,%.0f),(%.0f,%.0f),(%.0f,%.0f)) -> " + xu yu xv yv xw yw; + let r = ccw (xu,yu) (xv,yv) (xw,yw) in + eprintf "%b\n" r; flush stderr; + r + i*) + + let in_circle (xt,yt) (xu,yu) (xv,yv) (xw,yw) = + det [| [| xt; yt; (xt * xt + yt * yt); 1.0 |]; + [| xu; yu; (xu * xu + yu * yu); 1.0 |]; + [| xv; yv; (xv * xv + yv * yv); 1.0 |]; + [| xw; yw; (xw * xw + yw * yw); 1.0 |]; |] > 0.0 + + (*i DEBUG + let in_circle (xt,yt) (xu,yu) (xv,yv) (xw,yw) = + eprintf "in_circle((%.0f,%.0f),(%.0f,%.0f),(%.0f,%.0f),(%.0f,%.0f)) -> " + xt yt xu yu xv yv xw yw; + let r = in_circle (xt,yt) (xu,yu) (xv,yv) (xw,yw) in + eprintf "%b\n" r; flush stderr; + r + i*) + +end + +module Float = Make(FloatPoints) + +(** Points with integer coordinates. + We approximate using module [FloatPoints] but this could be made exact + following Knuth's code in Axioms and Hulls *) + +module IntPoints = struct + + type point = int * int + + let ccw (xu,yu) (xv,yv) (xw,yw) = + FloatPoints.ccw + (float xu, float yu) (float xv, float yv) (float xw, float yw) + + let in_circle (xt,yt) (xu,yu) (xv,yv) (xw,yw) = + FloatPoints.in_circle + (float xt, float yt) + (float xu, float yu) (float xv, float yv) (float xw, float yw) + +end + +module Int = Make(IntPoints) + diff --git a/external/ocamlgraph/src/delaunay.mli b/external/ocamlgraph/src/delaunay.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/delaunay.mli @@ -0,0 +1,76 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: delaunay.mli,v 1.8 2004-02-20 14:37:40 signoles Exp $ *) + +(** Delaunay triangulation *) + +(** Delaunay triangulation is available for any CCC system in the sense + of Knuth's ``Axioms and Hulls'' *) +module type CCC = sig + + type point + + val ccw : point -> point -> point -> bool + (** The counterclockwise relation [ccw p q r] states that the + circle through points [(p,q,r)] is traversed counterclockwise + when we encounter the points in cyclic order [p,q,r,p,...] **) + + val in_circle : point -> point -> point -> point -> bool + (** The relation [in_circle p q r s] states that [s] lies + inside the circle [(p,q,r)] if [ccw p q r] is true, or outside that + circle if [ccw p q r] is false. *) + +end + +(** The result of triangulation is an abstract value of type [triangulation]. + Then one can iterate over all edges of the triangulation. *) +module type Triangulation = sig + + module S : CCC + + type triangulation + + val triangulate : S.point array -> triangulation + (** [triangulate a] computes the Delaunay triangulation of a set of + points, given as an array [a]. If [N] is the number of points + (that is [Array.length a]), then the running time is $O(N \log N)$ + on the average and $O(N^2)$ on the worst-case. The space used is + always $O(N)$. *) + + val iter : (S.point -> S.point -> unit) -> triangulation -> unit + (** [iter f t] iterates over all edges of the triangulation [t]. + [f u v] is called once for each undirected edge [(u,v)]. *) + + val fold : (S.point -> S.point -> 'a -> 'a) -> triangulation -> 'a -> 'a + +end + +(** Generic Delaunay triangulation *) +module Make(S : CCC) : Triangulation with module S = S + +(** Points with integer coordinates *) +module IntPoints : CCC with type point = int * int + +(** Delaunay triangulation with integer coordinates *) +module Int : Triangulation with module S = IntPoints + +(** Points with floating point coordinates *) +module FloatPoints : CCC with type point = float * float + +(** Delaunay triangulation with floating point coordinates *) +module Float : Triangulation with module S = FloatPoints diff --git a/external/ocamlgraph/src/dot.ml b/external/ocamlgraph/src/dot.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/dot.ml @@ -0,0 +1,78 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id:$ *) + +(** Parser for DOT file format *) + +open Dot_ast + +module Parse + (B : Builder.S) + (L : sig + val node : node_id -> attr list -> B.G.V.label + (** how to build the node label out of the set of attributes *) + val edge : attr list -> B.G.E.label + (** how to build the edge label out of the set of attributes *) + end) = +struct + + let create_graph dot = + let nodes = Hashtbl.create 97 in + let node g id l = + try + g, Hashtbl.find nodes id + with Not_found -> + let n = B.G.V.create (L.node id l) in + Hashtbl.add nodes id n; + B.add_vertex g n, n + in + List.fold_left + (fun g s -> match s with + | Node_stmt (id, al) -> + let g,_ = node g id al in g + | Edge_stmt (NodeId id, nl, al) -> + let el = L.edge al in + let g,vn = node g id [] in + List.fold_left + (fun g m -> match m with + | NodeId idm -> + let g,vm = node g idm [] in + let e = B.G.E.create vn el vm in + B.add_edge_e g e + | NodeSub _ -> + g) + g nl + | _ -> + g) + (B.empty ()) + dot.stmts + + let parse f = + let c = open_in f in + let lb = Lexing.from_channel c in + let dot = + try + Dot_parser.file Dot_lexer.token lb + with Parsing.Parse_error -> + let n = Lexing.lexeme_start lb in + failwith (Printf.sprintf "Dot.parse: parse error character %d" n) + in + close_in c; + create_graph dot + +end diff --git a/external/ocamlgraph/src/dot.mli b/external/ocamlgraph/src/dot.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/dot.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(** Parser for DOT file format *) + +open Dot_ast + +module Parse + (B : Builder.S) + (L : sig + val node : node_id -> attr list -> B.G.V.label + (** how to build the node label out of the set of attributes *) + val edge : attr list -> B.G.E.label + (** how to build the edge label out of the set of attributes *) + end) : +sig + + val parse : string -> B.G.t + +end diff --git a/external/ocamlgraph/src/dot_ast.mli b/external/ocamlgraph/src/dot_ast.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/dot_ast.mli @@ -0,0 +1,57 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id:$ *) + +type id = + | Ident of string + | Number of string + | String of string + | Html of string + +type attr = (id * id option) list + +type compass_pt = N | Ne | E | Se | S | Sw | W | Nw + +type port = + | PortId of id * compass_pt option + | PortC of compass_pt + +type node_id = id * port option + +type subgraph = + | SubgraphId of id + | SubgraphDef of id option * stmt list + +and node = + | NodeId of node_id + | NodeSub of subgraph + +and stmt = + | Node_stmt of node_id * attr list + | Edge_stmt of node * node list * attr list + | Attr_graph of attr list + | Attr_node of attr list + | Attr_edge of attr list + | Equal of id * id + | Subgraph of subgraph + +type file = + { strict : bool; + digraph : bool; + id : id option; + stmts : stmt list } diff --git a/external/ocamlgraph/src/dot_lexer.ml b/external/ocamlgraph/src/dot_lexer.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/dot_lexer.ml @@ -0,0 +1,386 @@ +# 20 "src/dot_lexer.mll" + + open Lexing + open Dot_ast + open Dot_parser + + let string_buf = Buffer.create 1024 + + let keyword = + let h = Hashtbl.create 17 in + List.iter + (fun (s,k) -> Hashtbl.add h s k) + [ + "strict", STRICT; + "graph", GRAPH; + "digraph", DIGRAPH; + "subgraph", SUBGRAPH; + "node", NODE; + "edge", EDGE; + ]; + fun s -> let s = String.lowercase s in Hashtbl.find h s + + +# 25 "src/dot_lexer.ml" +let __ocaml_lex_tables = { + Lexing.lex_base = + "\000\000\238\255\239\255\240\255\241\255\078\000\088\000\098\000\ + \176\000\245\255\246\255\247\255\248\255\249\255\250\255\251\255\ + \252\255\114\000\001\000\005\000\254\255\002\000\253\255\191\000\ + \244\255\211\000\221\000\157\000\252\255\253\255\002\000\255\255\ + \254\255\032\000\252\255\253\255\254\255\255\255\054\000\253\255\ + \254\255\015\000\255\255"; + Lexing.lex_backtrk = + "\255\255\255\255\255\255\255\255\255\255\013\000\017\000\012\000\ + \017\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\017\000\017\000\000\000\255\255\255\255\255\255\255\255\ + \255\255\013\000\013\000\255\255\255\255\255\255\002\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\001\000\255\255"; + Lexing.lex_default = + "\001\000\000\000\000\000\000\000\000\000\255\255\255\255\255\255\ + \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\255\255\021\000\255\255\000\000\021\000\000\000\255\255\ + \000\000\255\255\255\255\029\000\000\000\000\000\255\255\000\000\ + \000\000\035\000\000\000\000\000\000\000\000\000\040\000\000\000\ + \000\000\255\255\000\000"; + Lexing.lex_trans = + "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\019\000\019\000\020\000\020\000\019\000\019\000\019\000\ + \000\000\000\000\019\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \019\000\000\000\004\000\018\000\032\000\019\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\015\000\008\000\006\000\017\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\016\000\014\000\003\000\013\000\042\000\000\000\ + \000\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\010\000\036\000\009\000\037\000\007\000\ + \041\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\012\000\026\000\011\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ + \025\000\025\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\022\000\000\000\000\000\000\000\ + \000\000\021\000\000\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\000\000\000\000\031\000\ + \000\000\007\000\000\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\024\000\023\000\000\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\000\000\000\000\000\000\000\000\024\000\025\000\ + \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ + \025\000\030\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \002\000\255\255\255\255\025\000\025\000\025\000\025\000\025\000\ + \025\000\025\000\025\000\025\000\025\000\026\000\026\000\026\000\ + \026\000\026\000\026\000\026\000\026\000\026\000\026\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \034\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\039\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\028\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000"; + Lexing.lex_check = + "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\000\000\000\000\018\000\021\000\000\000\019\000\019\000\ + \255\255\255\255\019\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \000\000\255\255\000\000\000\000\030\000\019\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\041\000\255\255\ + \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\033\000\000\000\033\000\000\000\ + \038\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\005\000\000\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\017\000\255\255\255\255\255\255\ + \255\255\017\000\255\255\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\255\255\255\255\027\000\ + \255\255\007\000\255\255\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\008\000\008\000\255\255\ + \008\000\008\000\008\000\008\000\008\000\008\000\008\000\008\000\ + \008\000\008\000\255\255\255\255\255\255\255\255\008\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\027\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \000\000\018\000\021\000\025\000\025\000\025\000\025\000\025\000\ + \025\000\025\000\025\000\025\000\025\000\026\000\026\000\026\000\ + \026\000\026\000\026\000\026\000\026\000\026\000\026\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \033\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\038\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\027\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255"; + Lexing.lex_base_code = + ""; + Lexing.lex_backtrk_code = + ""; + Lexing.lex_default_code = + ""; + Lexing.lex_trans_code = + ""; + Lexing.lex_check_code = + ""; + Lexing.lex_code = + ""; +} + +let rec token lexbuf = + __ocaml_lex_token_rec lexbuf 0 +and __ocaml_lex_token_rec lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with + | 0 -> +# 52 "src/dot_lexer.mll" + ( token lexbuf ) +# 191 "src/dot_lexer.ml" + + | 1 -> +# 54 "src/dot_lexer.mll" + ( token lexbuf ) +# 196 "src/dot_lexer.ml" + + | 2 -> +# 56 "src/dot_lexer.mll" + ( comment lexbuf; token lexbuf ) +# 201 "src/dot_lexer.ml" + + | 3 -> +# 58 "src/dot_lexer.mll" + ( COLON ) +# 206 "src/dot_lexer.ml" + + | 4 -> +# 60 "src/dot_lexer.mll" + ( COMMA ) +# 211 "src/dot_lexer.ml" + + | 5 -> +# 62 "src/dot_lexer.mll" + ( SEMICOLON ) +# 216 "src/dot_lexer.ml" + + | 6 -> +# 64 "src/dot_lexer.mll" + ( EQUAL ) +# 221 "src/dot_lexer.ml" + + | 7 -> +# 66 "src/dot_lexer.mll" + ( LBRA ) +# 226 "src/dot_lexer.ml" + + | 8 -> +# 68 "src/dot_lexer.mll" + ( RBRA ) +# 231 "src/dot_lexer.ml" + + | 9 -> +# 70 "src/dot_lexer.mll" + ( LSQ ) +# 236 "src/dot_lexer.ml" + + | 10 -> +# 72 "src/dot_lexer.mll" + ( RSQ ) +# 241 "src/dot_lexer.ml" + + | 11 -> +# 74 "src/dot_lexer.mll" + ( EDGEOP ) +# 246 "src/dot_lexer.ml" + + | 12 -> +let +# 75 "src/dot_lexer.mll" + s +# 252 "src/dot_lexer.ml" += Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in +# 76 "src/dot_lexer.mll" + ( try keyword s with Not_found -> ID (Ident s) ) +# 256 "src/dot_lexer.ml" + + | 13 -> +let +# 77 "src/dot_lexer.mll" + s +# 262 "src/dot_lexer.ml" += Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in +# 78 "src/dot_lexer.mll" + ( ID (Number s) ) +# 266 "src/dot_lexer.ml" + + | 14 -> +# 80 "src/dot_lexer.mll" + ( Buffer.clear string_buf; + let s = string lexbuf in + ID (String s) ) +# 273 "src/dot_lexer.ml" + + | 15 -> +# 84 "src/dot_lexer.mll" + ( Buffer.clear string_buf; + html lexbuf; + ID (Html (Buffer.contents string_buf)) ) +# 280 "src/dot_lexer.ml" + + | 16 -> +# 88 "src/dot_lexer.mll" + ( EOF ) +# 285 "src/dot_lexer.ml" + + | 17 -> +let +# 89 "src/dot_lexer.mll" + c +# 291 "src/dot_lexer.ml" += Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in +# 90 "src/dot_lexer.mll" + ( failwith ("Dot_lexer: invalid character " ^ String.make 1 c) ) +# 295 "src/dot_lexer.ml" + + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_token_rec lexbuf __ocaml_lex_state + +and string lexbuf = + __ocaml_lex_string_rec lexbuf 27 +and __ocaml_lex_string_rec lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with + | 0 -> +# 94 "src/dot_lexer.mll" + ( Buffer.contents string_buf ) +# 306 "src/dot_lexer.ml" + + | 1 -> +# 96 "src/dot_lexer.mll" + ( Buffer.add_char string_buf '"'; + string lexbuf ) +# 312 "src/dot_lexer.ml" + + | 2 -> +let +# 98 "src/dot_lexer.mll" + c +# 318 "src/dot_lexer.ml" += Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in +# 99 "src/dot_lexer.mll" + ( Buffer.add_char string_buf c; + string lexbuf ) +# 323 "src/dot_lexer.ml" + + | 3 -> +# 102 "src/dot_lexer.mll" + ( failwith ("Dot_lexer: unterminated string literal") ) +# 328 "src/dot_lexer.ml" + + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_string_rec lexbuf __ocaml_lex_state + +and html lexbuf = + __ocaml_lex_html_rec lexbuf 33 +and __ocaml_lex_html_rec lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with + | 0 -> +# 106 "src/dot_lexer.mll" + ( () ) +# 339 "src/dot_lexer.ml" + + | 1 -> +# 108 "src/dot_lexer.mll" + ( Buffer.add_char string_buf '<'; html lexbuf; + Buffer.add_char string_buf '>'; html lexbuf ) +# 345 "src/dot_lexer.ml" + + | 2 -> +let +# 110 "src/dot_lexer.mll" + c +# 351 "src/dot_lexer.ml" += Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in +# 111 "src/dot_lexer.mll" + ( Buffer.add_char string_buf c; + html lexbuf ) +# 356 "src/dot_lexer.ml" + + | 3 -> +# 114 "src/dot_lexer.mll" + ( failwith ("Dot_lexer: unterminated html literal") ) +# 361 "src/dot_lexer.ml" + + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_html_rec lexbuf __ocaml_lex_state + +and comment lexbuf = + __ocaml_lex_comment_rec lexbuf 38 +and __ocaml_lex_comment_rec lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with + | 0 -> +# 118 "src/dot_lexer.mll" + ( () ) +# 372 "src/dot_lexer.ml" + + | 1 -> +# 120 "src/dot_lexer.mll" + ( comment lexbuf ) +# 377 "src/dot_lexer.ml" + + | 2 -> +# 122 "src/dot_lexer.mll" + ( failwith "Dot_lexer: unterminated comment" ) +# 382 "src/dot_lexer.ml" + + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_comment_rec lexbuf __ocaml_lex_state + +;; + diff --git a/external/ocamlgraph/src/dot_lexer.mll b/external/ocamlgraph/src/dot_lexer.mll new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/dot_lexer.mll @@ -0,0 +1,122 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id:$ *) + +{ + open Lexing + open Dot_ast + open Dot_parser + + let string_buf = Buffer.create 1024 + + let keyword = + let h = Hashtbl.create 17 in + List.iter + (fun (s,k) -> Hashtbl.add h s k) + [ + "strict", STRICT; + "graph", GRAPH; + "digraph", DIGRAPH; + "subgraph", SUBGRAPH; + "node", NODE; + "edge", EDGE; + ]; + fun s -> let s = String.lowercase s in Hashtbl.find h s + +} + +let alpha = ['a'-'z' 'A'-'Z' '_'] +let digit = ['0'-'9'] +let ident = alpha (alpha | digit)* +let number = '-'? ('.'['0'-'9']+ | ['0'-'9']+('.'['0'-'9']*)? ) + +let space = [' ' '\t' '\r' '\n']+ + +rule token = parse + | space + { token lexbuf } + | ('#' | "//") [^ '\n']* '\n' + { token lexbuf } + | "/*" + { comment lexbuf; token lexbuf } + | ":" + { COLON } + | "," + { COMMA } + | ";" + { SEMICOLON } + | "=" + { EQUAL } + | "{" + { LBRA } + | "}" + { RBRA } + | "[" + { LSQ } + | "]" + { RSQ } + | "--" | "->" + { EDGEOP } + | ident as s + { try keyword s with Not_found -> ID (Ident s) } + | number as s + { ID (Number s) } + | "\"" + { Buffer.clear string_buf; + let s = string lexbuf in + ID (String s) } + | "<" + { Buffer.clear string_buf; + html lexbuf; + ID (Html (Buffer.contents string_buf)) } + | eof + { EOF } + | _ as c + { failwith ("Dot_lexer: invalid character " ^ String.make 1 c) } + +and string = parse + | "\"" + { Buffer.contents string_buf } + | "\\" "\"" + { Buffer.add_char string_buf '"'; + string lexbuf } + | _ as c + { Buffer.add_char string_buf c; + string lexbuf } + | eof + { failwith ("Dot_lexer: unterminated string literal") } + +and html = parse + | ">" + { () } + | "<" + { Buffer.add_char string_buf '<'; html lexbuf; + Buffer.add_char string_buf '>'; html lexbuf } + | _ as c + { Buffer.add_char string_buf c; + html lexbuf } + | eof + { failwith ("Dot_lexer: unterminated html literal") } + +and comment = parse + | "*/" + { () } + | _ + { comment lexbuf } + | eof + { failwith "Dot_lexer: unterminated comment" } diff --git a/external/ocamlgraph/src/dot_parser.ml b/external/ocamlgraph/src/dot_parser.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/dot_parser.ml @@ -0,0 +1,551 @@ +type token = + | ID of (Dot_ast.id) + | COLON + | COMMA + | EQUAL + | SEMICOLON + | EDGEOP + | STRICT + | GRAPH + | DIGRAPH + | LBRA + | RBRA + | LSQ + | RSQ + | NODE + | EDGE + | SUBGRAPH + | EOF + +open Parsing;; +# 23 "src/dot_parser.mly" + open Dot_ast + open Parsing + + let compass_pt = function + | Ident "n" -> N + | Ident "ne" -> Ne + | Ident "e" -> E + | Ident "se" -> Se + | Ident "s" -> S + | Ident "sw" -> Sw + | Ident "w" -> W + | Ident "nw" -> Nw + | _ -> invalid_arg "compass_pt" + +# 37 "src/dot_parser.ml" +let yytransl_const = [| + 258 (* COLON *); + 259 (* COMMA *); + 260 (* EQUAL *); + 261 (* SEMICOLON *); + 262 (* EDGEOP *); + 263 (* STRICT *); + 264 (* GRAPH *); + 265 (* DIGRAPH *); + 266 (* LBRA *); + 267 (* RBRA *); + 268 (* LSQ *); + 269 (* RSQ *); + 270 (* NODE *); + 271 (* EDGE *); + 272 (* SUBGRAPH *); + 0 (* EOF *); + 0|] + +let yytransl_block = [| + 257 (* ID *); + 0|] + +let yylhs = "\255\255\ +\001\000\002\000\002\000\003\000\003\000\005\000\005\000\006\000\ +\006\000\008\000\008\000\007\000\007\000\007\000\007\000\007\000\ +\009\000\010\000\011\000\011\000\011\000\016\000\018\000\018\000\ +\015\000\015\000\013\000\019\000\019\000\020\000\020\000\014\000\ +\014\000\017\000\017\000\004\000\004\000\021\000\021\000\022\000\ +\022\000\023\000\023\000\012\000\012\000\012\000\012\000\000\000" + +let yylen = "\002\000\ +\007\000\000\000\001\000\001\000\001\000\000\000\001\000\002\000\ +\003\000\000\000\001\000\001\000\001\000\001\000\003\000\001\000\ +\002\000\003\000\002\000\002\000\002\000\003\000\000\000\003\000\ +\001\000\001\000\002\000\000\000\001\000\002\000\004\000\000\000\ +\001\000\003\000\004\000\000\000\001\000\002\000\003\000\001\000\ +\003\000\000\000\001\000\002\000\005\000\004\000\003\000\002\000" + +let yydefred = "\000\000\ +\000\000\000\000\003\000\048\000\000\000\004\000\005\000\000\000\ +\037\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\007\000\000\000\012\000\013\000\014\000\000\000\ +\000\000\000\000\000\000\000\000\027\000\029\000\000\000\019\000\ +\000\000\020\000\021\000\000\000\000\000\000\000\011\000\000\000\ +\017\000\033\000\000\000\000\000\000\000\015\000\000\000\000\000\ +\000\000\047\000\000\000\000\000\001\000\009\000\000\000\026\000\ +\025\000\000\000\018\000\000\000\000\000\000\000\043\000\000\000\ +\000\000\046\000\000\000\022\000\031\000\041\000\035\000\039\000\ +\045\000\000\000\024\000" + +let yydgoto = "\002\000\ +\004\000\005\000\008\000\010\000\018\000\019\000\020\000\040\000\ +\021\000\022\000\023\000\024\000\025\000\041\000\026\000\044\000\ +\042\000\068\000\029\000\030\000\048\000\049\000\064\000" + +let yysindex = "\009\000\ +\024\255\000\000\000\000\000\000\000\255\000\000\000\000\031\255\ +\000\000\029\255\131\255\011\255\033\255\131\255\033\255\033\255\ +\051\255\040\255\000\000\048\255\000\000\000\000\000\000\000\000\ +\033\255\050\255\057\255\067\255\000\000\000\000\069\255\000\000\ +\062\255\000\000\000\000\070\255\131\255\091\000\000\000\131\255\ +\000\000\000\000\018\255\033\255\090\255\000\000\099\255\081\255\ +\101\255\000\000\131\255\095\255\000\000\000\000\107\255\000\000\ +\000\000\110\255\000\000\114\255\117\255\033\255\000\000\069\255\ +\111\255\000\000\018\255\000\000\000\000\000\000\000\000\000\000\ +\000\000\110\255\000\000" + +let yyrindex = "\000\000\ +\074\255\000\000\000\000\000\000\000\000\000\000\000\000\116\255\ +\000\000\000\000\118\255\006\255\000\000\118\255\000\000\000\000\ +\000\000\000\000\000\000\120\255\000\000\000\000\000\000\049\255\ +\061\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\073\255\118\255\000\000\000\000\122\255\ +\000\000\000\000\000\000\097\255\032\255\000\000\023\255\000\000\ +\022\255\000\000\118\255\000\000\000\000\000\000\006\255\000\000\ +\000\000\085\255\000\000\000\000\000\000\109\255\000\000\124\255\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\085\255\000\000" + +let yygindex = "\000\000\ +\000\000\000\000\000\000\000\000\246\255\087\000\000\000\000\000\ +\000\000\000\000\000\000\214\255\218\255\094\000\219\255\000\000\ +\243\255\066\000\000\000\000\000\078\000\000\000\000\000" + +let yytablesize = 147 +let yytable = "\032\000\ +\056\000\034\000\035\000\033\000\057\000\058\000\028\000\006\000\ +\007\000\001\000\028\000\028\000\027\000\028\000\028\000\028\000\ +\028\000\028\000\055\000\028\000\028\000\028\000\042\000\040\000\ +\056\000\040\000\052\000\014\000\057\000\074\000\003\000\009\000\ +\030\000\017\000\042\000\040\000\030\000\030\000\011\000\030\000\ +\065\000\030\000\030\000\030\000\031\000\030\000\030\000\030\000\ +\071\000\016\000\038\000\036\000\039\000\016\000\026\000\043\000\ +\016\000\045\000\016\000\016\000\037\000\032\000\016\000\016\000\ +\016\000\032\000\025\000\046\000\032\000\047\000\032\000\032\000\ +\050\000\044\000\032\000\032\000\032\000\044\000\044\000\051\000\ +\044\000\002\000\002\000\044\000\044\000\023\000\044\000\044\000\ +\044\000\023\000\053\000\060\000\023\000\062\000\023\000\023\000\ +\023\000\032\000\023\000\023\000\023\000\032\000\061\000\063\000\ +\032\000\066\000\032\000\032\000\027\000\034\000\032\000\032\000\ +\032\000\034\000\069\000\067\000\034\000\070\000\034\000\034\000\ +\010\000\073\000\034\000\034\000\034\000\036\000\054\000\010\000\ +\006\000\010\000\010\000\012\000\008\000\010\000\010\000\010\000\ +\038\000\059\000\013\000\075\000\014\000\072\000\000\000\000\000\ +\015\000\016\000\017\000" + +let yycheck = "\013\000\ +\043\000\015\000\016\000\014\000\043\000\043\000\001\001\008\001\ +\009\001\001\000\005\001\006\001\002\001\008\001\004\001\010\001\ +\011\001\012\001\001\001\014\001\015\001\016\001\001\001\001\001\ +\067\000\003\001\037\000\010\001\067\000\067\000\007\001\001\001\ +\001\001\016\001\013\001\013\001\005\001\006\001\010\001\008\001\ +\051\000\010\001\011\001\012\001\012\001\014\001\015\001\016\001\ +\062\000\001\001\011\001\001\001\005\001\005\001\006\001\006\001\ +\008\001\001\001\010\001\011\001\010\001\001\001\014\001\015\001\ +\016\001\005\001\006\001\001\001\008\001\001\001\010\001\011\001\ +\011\001\001\001\014\001\015\001\016\001\005\001\006\001\010\001\ +\008\001\008\001\009\001\011\001\012\001\001\001\014\001\015\001\ +\016\001\005\001\000\000\002\001\008\001\013\001\010\001\011\001\ +\012\001\001\001\014\001\015\001\016\001\005\001\004\001\003\001\ +\008\001\011\001\010\001\011\001\002\001\001\001\014\001\015\001\ +\016\001\005\001\001\001\006\001\008\001\001\001\010\001\011\001\ +\001\001\011\001\014\001\015\001\016\001\010\001\040\000\008\001\ +\011\001\010\001\011\001\001\001\011\001\014\001\015\001\016\001\ +\013\001\044\000\008\001\074\000\010\001\064\000\255\255\255\255\ +\014\001\015\001\016\001" + +let yynames_const = "\ + COLON\000\ + COMMA\000\ + EQUAL\000\ + SEMICOLON\000\ + EDGEOP\000\ + STRICT\000\ + GRAPH\000\ + DIGRAPH\000\ + LBRA\000\ + RBRA\000\ + LSQ\000\ + RSQ\000\ + NODE\000\ + EDGE\000\ + SUBGRAPH\000\ + EOF\000\ + " + +let yynames_block = "\ + ID\000\ + " + +let yyact = [| + (fun _ -> failwith "parser") +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 6 : 'strict_opt) in + let _2 = (Parsing.peek_val __caml_parser_env 5 : 'graph_or_digraph) in + let _3 = (Parsing.peek_val __caml_parser_env 4 : 'id_opt) in + let _5 = (Parsing.peek_val __caml_parser_env 2 : 'stmt_list) in + Obj.repr( +# 49 "src/dot_parser.mly" + ( { strict = _1; digraph = _2; id = _3; stmts = _5 } ) +# 199 "src/dot_parser.ml" + : Dot_ast.file)) +; (fun __caml_parser_env -> + Obj.repr( +# 53 "src/dot_parser.mly" + ( false ) +# 205 "src/dot_parser.ml" + : 'strict_opt)) +; (fun __caml_parser_env -> + Obj.repr( +# 54 "src/dot_parser.mly" + ( true ) +# 211 "src/dot_parser.ml" + : 'strict_opt)) +; (fun __caml_parser_env -> + Obj.repr( +# 58 "src/dot_parser.mly" + ( false ) +# 217 "src/dot_parser.ml" + : 'graph_or_digraph)) +; (fun __caml_parser_env -> + Obj.repr( +# 59 "src/dot_parser.mly" + ( true ) +# 223 "src/dot_parser.ml" + : 'graph_or_digraph)) +; (fun __caml_parser_env -> + Obj.repr( +# 63 "src/dot_parser.mly" + ( [] ) +# 229 "src/dot_parser.ml" + : 'stmt_list)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 0 : 'list1_stmt) in + Obj.repr( +# 64 "src/dot_parser.mly" + ( _1 ) +# 236 "src/dot_parser.ml" + : 'stmt_list)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 1 : 'stmt) in + let _2 = (Parsing.peek_val __caml_parser_env 0 : 'semicolon_opt) in + Obj.repr( +# 68 "src/dot_parser.mly" + ( [_1] ) +# 244 "src/dot_parser.ml" + : 'list1_stmt)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 2 : 'stmt) in + let _2 = (Parsing.peek_val __caml_parser_env 1 : 'semicolon_opt) in + let _3 = (Parsing.peek_val __caml_parser_env 0 : 'list1_stmt) in + Obj.repr( +# 69 "src/dot_parser.mly" + ( _1 :: _3 ) +# 253 "src/dot_parser.ml" + : 'list1_stmt)) +; (fun __caml_parser_env -> + Obj.repr( +# 73 "src/dot_parser.mly" + ( () ) +# 259 "src/dot_parser.ml" + : 'semicolon_opt)) +; (fun __caml_parser_env -> + Obj.repr( +# 74 "src/dot_parser.mly" + ( () ) +# 265 "src/dot_parser.ml" + : 'semicolon_opt)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 0 : 'node_stmt) in + Obj.repr( +# 78 "src/dot_parser.mly" + ( _1 ) +# 272 "src/dot_parser.ml" + : 'stmt)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 0 : 'edge_stmt) in + Obj.repr( +# 79 "src/dot_parser.mly" + ( _1 ) +# 279 "src/dot_parser.ml" + : 'stmt)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 0 : 'attr_stmt) in + Obj.repr( +# 80 "src/dot_parser.mly" + ( _1 ) +# 286 "src/dot_parser.ml" + : 'stmt)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 2 : Dot_ast.id) in + let _3 = (Parsing.peek_val __caml_parser_env 0 : Dot_ast.id) in + Obj.repr( +# 81 "src/dot_parser.mly" + ( Equal (_1, _3) ) +# 294 "src/dot_parser.ml" + : 'stmt)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 0 : 'subgraph) in + Obj.repr( +# 82 "src/dot_parser.mly" + ( Subgraph _1 ) +# 301 "src/dot_parser.ml" + : 'stmt)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 1 : 'node_id) in + let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attr_list_opt) in + Obj.repr( +# 86 "src/dot_parser.mly" + ( Node_stmt (_1, _2) ) +# 309 "src/dot_parser.ml" + : 'node_stmt)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 2 : 'node) in + let _2 = (Parsing.peek_val __caml_parser_env 1 : 'edge_rhs) in + let _3 = (Parsing.peek_val __caml_parser_env 0 : 'attr_list_opt) in + Obj.repr( +# 90 "src/dot_parser.mly" + ( Edge_stmt (_1, _2, _3) ) +# 318 "src/dot_parser.ml" + : 'edge_stmt)) +; (fun __caml_parser_env -> + let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attr_list) in + Obj.repr( +# 94 "src/dot_parser.mly" + ( Attr_graph _2 ) +# 325 "src/dot_parser.ml" + : 'attr_stmt)) +; (fun __caml_parser_env -> + let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attr_list) in + Obj.repr( +# 95 "src/dot_parser.mly" + ( Attr_node _2 ) +# 332 "src/dot_parser.ml" + : 'attr_stmt)) +; (fun __caml_parser_env -> + let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attr_list) in + Obj.repr( +# 96 "src/dot_parser.mly" + ( Attr_edge _2 ) +# 339 "src/dot_parser.ml" + : 'attr_stmt)) +; (fun __caml_parser_env -> + let _2 = (Parsing.peek_val __caml_parser_env 1 : 'node) in + let _3 = (Parsing.peek_val __caml_parser_env 0 : 'edge_rhs_opt) in + Obj.repr( +# 100 "src/dot_parser.mly" + ( _2 :: _3 ) +# 347 "src/dot_parser.ml" + : 'edge_rhs)) +; (fun __caml_parser_env -> + Obj.repr( +# 104 "src/dot_parser.mly" + ( [] ) +# 353 "src/dot_parser.ml" + : 'edge_rhs_opt)) +; (fun __caml_parser_env -> + let _2 = (Parsing.peek_val __caml_parser_env 1 : 'node) in + let _3 = (Parsing.peek_val __caml_parser_env 0 : 'edge_rhs_opt) in + Obj.repr( +# 105 "src/dot_parser.mly" + ( _2 :: _3 ) +# 361 "src/dot_parser.ml" + : 'edge_rhs_opt)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 0 : 'node_id) in + Obj.repr( +# 109 "src/dot_parser.mly" + ( NodeId _1 ) +# 368 "src/dot_parser.ml" + : 'node)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 0 : 'subgraph) in + Obj.repr( +# 110 "src/dot_parser.mly" + ( NodeSub _1 ) +# 375 "src/dot_parser.ml" + : 'node)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 1 : Dot_ast.id) in + let _2 = (Parsing.peek_val __caml_parser_env 0 : 'port_opt) in + Obj.repr( +# 114 "src/dot_parser.mly" + ( _1, _2 ) +# 383 "src/dot_parser.ml" + : 'node_id)) +; (fun __caml_parser_env -> + Obj.repr( +# 118 "src/dot_parser.mly" + ( None ) +# 389 "src/dot_parser.ml" + : 'port_opt)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 0 : 'port) in + Obj.repr( +# 119 "src/dot_parser.mly" + ( Some _1 ) +# 396 "src/dot_parser.ml" + : 'port_opt)) +; (fun __caml_parser_env -> + let _2 = (Parsing.peek_val __caml_parser_env 0 : Dot_ast.id) in + Obj.repr( +# 123 "src/dot_parser.mly" + ( try PortC (compass_pt _2) + with Invalid_argument _ -> PortId (_2, None) ) +# 404 "src/dot_parser.ml" + : 'port)) +; (fun __caml_parser_env -> + let _2 = (Parsing.peek_val __caml_parser_env 2 : Dot_ast.id) in + let _4 = (Parsing.peek_val __caml_parser_env 0 : Dot_ast.id) in + Obj.repr( +# 126 "src/dot_parser.mly" + ( let cp = + try compass_pt _4 with Invalid_argument _ -> raise Parse_error + in + PortId (_2, Some cp) ) +# 415 "src/dot_parser.ml" + : 'port)) +; (fun __caml_parser_env -> + Obj.repr( +# 133 "src/dot_parser.mly" + ( [] ) +# 421 "src/dot_parser.ml" + : 'attr_list_opt)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 0 : 'attr_list) in + Obj.repr( +# 134 "src/dot_parser.mly" + ( _1 ) +# 428 "src/dot_parser.ml" + : 'attr_list_opt)) +; (fun __caml_parser_env -> + let _2 = (Parsing.peek_val __caml_parser_env 1 : 'a_list) in + Obj.repr( +# 138 "src/dot_parser.mly" + ( [_2] ) +# 435 "src/dot_parser.ml" + : 'attr_list)) +; (fun __caml_parser_env -> + let _2 = (Parsing.peek_val __caml_parser_env 2 : 'a_list) in + let _4 = (Parsing.peek_val __caml_parser_env 0 : 'attr_list) in + Obj.repr( +# 139 "src/dot_parser.mly" + ( _2 :: _4 ) +# 443 "src/dot_parser.ml" + : 'attr_list)) +; (fun __caml_parser_env -> + Obj.repr( +# 143 "src/dot_parser.mly" + ( None ) +# 449 "src/dot_parser.ml" + : 'id_opt)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 0 : Dot_ast.id) in + Obj.repr( +# 144 "src/dot_parser.mly" + ( Some _1 ) +# 456 "src/dot_parser.ml" + : 'id_opt)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 1 : 'equality) in + let _2 = (Parsing.peek_val __caml_parser_env 0 : 'comma_opt) in + Obj.repr( +# 148 "src/dot_parser.mly" + ( [_1] ) +# 464 "src/dot_parser.ml" + : 'a_list)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 2 : 'equality) in + let _2 = (Parsing.peek_val __caml_parser_env 1 : 'comma_opt) in + let _3 = (Parsing.peek_val __caml_parser_env 0 : 'a_list) in + Obj.repr( +# 149 "src/dot_parser.mly" + ( _1 :: _3 ) +# 473 "src/dot_parser.ml" + : 'a_list)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 0 : Dot_ast.id) in + Obj.repr( +# 153 "src/dot_parser.mly" + ( _1, None ) +# 480 "src/dot_parser.ml" + : 'equality)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 2 : Dot_ast.id) in + let _3 = (Parsing.peek_val __caml_parser_env 0 : Dot_ast.id) in + Obj.repr( +# 154 "src/dot_parser.mly" + ( _1, Some _3 ) +# 488 "src/dot_parser.ml" + : 'equality)) +; (fun __caml_parser_env -> + Obj.repr( +# 158 "src/dot_parser.mly" + ( () ) +# 494 "src/dot_parser.ml" + : 'comma_opt)) +; (fun __caml_parser_env -> + Obj.repr( +# 159 "src/dot_parser.mly" + ( () ) +# 500 "src/dot_parser.ml" + : 'comma_opt)) +; (fun __caml_parser_env -> + let _2 = (Parsing.peek_val __caml_parser_env 0 : Dot_ast.id) in + Obj.repr( +# 164 "src/dot_parser.mly" + ( SubgraphId _2 ) +# 507 "src/dot_parser.ml" + : 'subgraph)) +; (fun __caml_parser_env -> + let _2 = (Parsing.peek_val __caml_parser_env 3 : Dot_ast.id) in + let _4 = (Parsing.peek_val __caml_parser_env 1 : 'stmt_list) in + Obj.repr( +# 165 "src/dot_parser.mly" + ( SubgraphDef (Some _2, _4) ) +# 515 "src/dot_parser.ml" + : 'subgraph)) +; (fun __caml_parser_env -> + let _3 = (Parsing.peek_val __caml_parser_env 1 : 'stmt_list) in + Obj.repr( +# 166 "src/dot_parser.mly" + ( SubgraphDef (None, _3) ) +# 522 "src/dot_parser.ml" + : 'subgraph)) +; (fun __caml_parser_env -> + let _2 = (Parsing.peek_val __caml_parser_env 1 : 'stmt_list) in + Obj.repr( +# 167 "src/dot_parser.mly" + ( SubgraphDef (None, _2) ) +# 529 "src/dot_parser.ml" + : 'subgraph)) +(* Entry file *) +; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0))) +|] +let yytables = + { Parsing.actions=yyact; + Parsing.transl_const=yytransl_const; + Parsing.transl_block=yytransl_block; + Parsing.lhs=yylhs; + Parsing.len=yylen; + Parsing.defred=yydefred; + Parsing.dgoto=yydgoto; + Parsing.sindex=yysindex; + Parsing.rindex=yyrindex; + Parsing.gindex=yygindex; + Parsing.tablesize=yytablesize; + Parsing.table=yytable; + Parsing.check=yycheck; + Parsing.error_function=parse_error; + Parsing.names_const=yynames_const; + Parsing.names_block=yynames_block } +let file (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = + (Parsing.yyparse yytables 1 lexfun lexbuf : Dot_ast.file) diff --git a/external/ocamlgraph/src/dot_parser.mli b/external/ocamlgraph/src/dot_parser.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/dot_parser.mli @@ -0,0 +1,21 @@ +type token = + | ID of (Dot_ast.id) + | COLON + | COMMA + | EQUAL + | SEMICOLON + | EDGEOP + | STRICT + | GRAPH + | DIGRAPH + | LBRA + | RBRA + | LSQ + | RSQ + | NODE + | EDGE + | SUBGRAPH + | EOF + +val file : + (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Dot_ast.file diff --git a/external/ocamlgraph/src/dot_parser.mly b/external/ocamlgraph/src/dot_parser.mly new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/dot_parser.mly @@ -0,0 +1,168 @@ +/**************************************************************************/ +/* */ +/* Ocamlgraph: a generic graph library for OCaml */ +/* Copyright (C) 2004-2007 */ +/* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles */ +/* */ +/* This software is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU Library General Public */ +/* License version 2, with the special exception on linking */ +/* described in file LICENSE. */ +/* */ +/* This software is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. */ +/* */ +/**************************************************************************/ + +/* $Id:$ */ + +/* DOT parser, following http://www.graphviz.org/doc/info/lang.html */ + +%{ + open Dot_ast + open Parsing + + let compass_pt = function + | Ident "n" -> N + | Ident "ne" -> Ne + | Ident "e" -> E + | Ident "se" -> Se + | Ident "s" -> S + | Ident "sw" -> Sw + | Ident "w" -> W + | Ident "nw" -> Nw + | _ -> invalid_arg "compass_pt" + +%} + +%token ID +%token COLON COMMA EQUAL SEMICOLON EDGEOP +%token STRICT GRAPH DIGRAPH LBRA RBRA LSQ RSQ NODE EDGE SUBGRAPH EOF + +%type file +%start file +%% + +file: +| strict_opt graph_or_digraph id_opt LBRA stmt_list RBRA EOF + { { strict = $1; digraph = $2; id = $3; stmts = $5 } } +; + +strict_opt: +| /* epsilon */ { false } +| STRICT { true } +; + +graph_or_digraph: +| GRAPH { false } +| DIGRAPH { true } +; + +stmt_list: +| /* epsilon */ { [] } +| list1_stmt { $1 } +; + +list1_stmt: +| stmt semicolon_opt { [$1] } +| stmt semicolon_opt list1_stmt { $1 :: $3 } +; + +semicolon_opt: +| /* epsilon */ { () } +| SEMICOLON { () } +; + +stmt: +| node_stmt { $1 } +| edge_stmt { $1 } +| attr_stmt { $1 } +| ID EQUAL ID { Equal ($1, $3) } +| subgraph { Subgraph $1 } +; + +node_stmt: +| node_id attr_list_opt { Node_stmt ($1, $2) } +; + +edge_stmt: +| node edge_rhs attr_list_opt { Edge_stmt ($1, $2, $3) } +; + +attr_stmt: +| GRAPH attr_list { Attr_graph $2 } +| NODE attr_list { Attr_node $2 } +| EDGE attr_list { Attr_edge $2 } +; + +edge_rhs: +| EDGEOP node edge_rhs_opt { $2 :: $3 } +; + +edge_rhs_opt: +| /* epsilon */ { [] } +| EDGEOP node edge_rhs_opt { $2 :: $3 } +; + +node: +| node_id { NodeId $1 } +| subgraph { NodeSub $1 } +; + +node_id: +| ID port_opt { $1, $2 } +; + +port_opt: +| /* epsilon */ { None } +| port { Some $1 } +; + +port: +| COLON ID { try PortC (compass_pt $2) + with Invalid_argument _ -> PortId ($2, None) } +| COLON ID COLON ID + { let cp = + try compass_pt $4 with Invalid_argument _ -> raise Parse_error + in + PortId ($2, Some cp) } +; + +attr_list_opt: +| /* epsilon */ { [] } +| attr_list { $1 } +; + +attr_list: +| LSQ a_list RSQ { [$2] } +| LSQ a_list RSQ attr_list { $2 :: $4 } +; + +id_opt: +| /* epsilon */ { None } +| ID { Some $1 } +; + +a_list: +| equality comma_opt { [$1] } +| equality comma_opt a_list { $1 :: $3 } +; + +equality: +| ID { $1, None } +| ID EQUAL ID { $1, Some $3 } +; + +comma_opt: +| /* epsilon */ { () } +| COMMA { () } +; + +/* one shift/reduce conflict here, which is ok */ +subgraph: +| SUBGRAPH ID { SubgraphId $2 } +| SUBGRAPH ID LBRA stmt_list RBRA { SubgraphDef (Some $2, $4) } +| SUBGRAPH LBRA stmt_list RBRA { SubgraphDef (None, $3) } +| LBRA stmt_list RBRA { SubgraphDef (None, $2) } +; diff --git a/external/ocamlgraph/src/flow.ml b/external/ocamlgraph/src/flow.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/flow.ml @@ -0,0 +1,329 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +module type FLOW = sig + type label + type t + val max_capacity : label -> t + val min_capacity : label -> t + val flow : label -> t + val add : t -> t -> t + val sub : t -> t -> t + val zero : t + val compare : t -> t -> int +end + +module type G_GOLDBERG = sig + type t + module V : Sig.COMPARABLE + module E : Sig.EDGE with type vertex = V.t + val nb_vertex : t -> int + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_edges_e : (E.t -> unit) -> t -> unit + val fold_succ_e : (E.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a + val fold_pred_e : (E.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a +end + +module Goldberg(G: G_GOLDBERG)(F: FLOW with type label = G.E.label) = +struct + + module V = Hashtbl.Make(G.V) + module E = Hashtbl.Make(Util.HTProduct(G.V)(G.V)) + module Se = Set.Make(G.E) + module Sv = Set.Make(G.V) + + let excedents = V.create 997 + let hauteur = V.create 997 + let flot = E.create 997 + + let fold_booleen f = List.fold_left (fun r x->(f x) or r) false + + let capacite_restante g e = + F.sub (F.max_capacity (G.E.label e)) (E.find flot (G.E.src e, G.E.dst e)) + + let reste_excedent x = F.compare (V.find excedents x) F.zero > 0 + + let flux_et_reflux g x = + let s = + G.fold_succ_e + (fun e s-> + if F.compare + (capacite_restante g e) (F.min_capacity (G.E.label e)) + > 0 + then e::s else s) + g x [] + in + G.fold_pred_e + (fun e s -> + if F.compare + (E.find flot (G.E.src e, G.E.dst e)) (F.min_capacity (G.E.label e)) + > 0 + then (G.E.create (G.E.dst e) (G.E.label e) (G.E.src e))::s else s) + g x s + + let pousser g e l = + let x, y = G.E.src e, G.E.dst e in + let ex = V.find excedents x in + let cxy = capacite_restante g e in + if F.compare ex F.zero > 0 && + F.compare cxy (F.min_capacity (G.E.label e)) > 0 && + V.find hauteur x = (V.find hauteur y + 1) + then + let d = if F.compare ex cxy < 0 then ex else cxy in + let fxy = E.find flot (x,y) in + let ex = V.find excedents x in + let ey = V.find excedents y in + E.replace flot (x,y) (F.add fxy d); + E.replace flot (y,x) (F.sub F.zero (F.add fxy d)); + V.replace excedents x (F.sub ex d); + V.replace excedents y (F.add ey d); + if reste_excedent x then l:=Sv.add x !l; + if reste_excedent y then l:=Sv.add y !l; + true + else + (if F.compare ex F.zero > 0 then l:=Sv.add x !l; + false) + + let elever g p x = + let u = flux_et_reflux g x in + reste_excedent x + && not (G.V.equal x p) + && + List.for_all + (fun e -> (V.find hauteur (G.E.src e)) <= (V.find hauteur (G.E.dst e))) u + && + (let min = + List.fold_left (fun m e -> min (V.find hauteur (G.E.dst e)) m) max_int u + in + V.replace hauteur x (1+min); + true) + + let init_preflot g s p = + G.iter_vertex (fun x -> V.add excedents x F.zero; V.add hauteur x 0) g; + G.iter_edges_e + (fun e -> + let x,y = G.E.src e, G.E.dst e in + E.add flot (x,y) (F.flow (G.E.label e)); + E.add flot (y,x) (F.sub F.zero (F.flow (G.E.label e)))) + g; + V.add hauteur s (G.nb_vertex g); + G.fold_succ_e + (fun e l -> + let y = G.E.dst e in + let c = F.max_capacity (G.E.label e) in + E.add flot (s,y) c; + E.add flot (y,s) (F.sub F.zero c); + V.add excedents y c; + y::l) + g s [] + + let maxflow g s p = + let push_and_pull l x = + G.fold_succ_e (fun e r->pousser g e l or r) g x false + or G.fold_pred_e (fun e r->pousser g e l or r) g x false + in + let todo = ref (init_preflot g s p) in + while + (fold_booleen (elever g p) !todo) or + (let l = ref Sv.empty in + let r = fold_booleen (push_and_pull l) !todo in + todo:=Sv.elements !l; r) + do () done; + let flot_max = + G.fold_pred_e (fun e f -> F.add (E.find flot (G.E.src e,p)) f) g p F.zero + in + let flot_init = + G.fold_pred_e (fun e f -> F.add (F.flow (G.E.label e)) f) g p F.zero + in + let f e = + let x,y = G.E.src e, G.E.dst e in + try E.find flot (x,y) + with Not_found -> F.flow (G.E.label e) + in + f, F.sub flot_max flot_init +end + +(*****************************************************************************) + +module type G_FORD_FULKERSON = sig + type t + module V : Sig.HASHABLE + module E : sig + type t + type label + val src : t -> V.t + val dst : t -> V.t + val label : t -> label + end + val iter_succ_e : (E.t -> unit) -> t -> V.t -> unit + val iter_pred_e : (E.t -> unit) -> t -> V.t -> unit +end + +module Ford_Fulkerson + (G: G_FORD_FULKERSON) + (F: FLOW with type label = G.E.label) = +struct + + (* redefinition of F *) + module F = struct + include F + + type u = + | Flow of F.t + | Infinity + + let min x y = match x, y with + | Flow _, Infinity -> x + | Flow fx, Flow fy when F.compare fx fy < 0 -> x + | (Infinity, _) | (Flow _, Flow _) -> y + end + + module Mark = struct + module H = Hashtbl.Make(G.V) + type mark = Plus | Minus + + let marked = H.create 997 + let unvisited = Queue.create () + + let clear () = H.clear marked + + let mem = H.mem marked + + let set s e tag = + assert (not (mem s)); + H.add marked s (e, tag); + Queue.add s unvisited + + let get s : G.E.t * mark = + let e, tag = H.find marked s in + (match e with None -> assert false | Some e -> e), tag + + exception Empty = Queue.Empty + let next () = Queue.pop unvisited + end + + module Result = struct + module H = + Hashtbl.Make + (struct + open G + type t = E.t + module U = Util.HTProduct(V)(V) + let equal e1 e2 = U.equal (E.src e1, E.dst e1) (E.src e2, E.dst e2) + let hash e = U.hash (E.src e, E.dst e) + end) + + let create () = H.create 997 + + let find = H.find + + let flow r e = + try + find r e + with Not_found -> + let f = F.flow (G.E.label e) in + H.add r e f; + f + + let change op r e f = + try + H.replace r e (op (find r e) f); + with Not_found -> + assert false + + let grow = change F.add + let reduce = change F.sub + end + + let is_full r e = + F.compare (F.max_capacity (G.E.label e)) (Result.flow r e) = 0 + + let is_empty r e = + F.compare (F.min_capacity (G.E.label e)) (Result.flow r e) = 0 + + let set_flow r s t a = + let rec loop t = + if not (G.V.equal s t) then + let e, tag = Mark.get t in + match tag with + | Mark.Plus -> Result.grow r e a; loop (G.E.src e) + | Mark.Minus -> Result.reduce r e a; loop (G.E.dst e) + in + loop t + + let grow_flow r s t a = + let rec loop u b = + if G.V.equal s u then begin + match b with + | F.Infinity -> (* source = destination *) + assert (G.V.equal s t); + a + | F.Flow f -> + set_flow r s t f; + F.add a f + end else + let e, tag = Mark.get u in + let l = G.E.label e in + match tag with + | Mark.Plus -> + loop + (G.E.src e) + (F.min b (F.Flow (F.sub (F.max_capacity l) (Result.flow r e)))) + | Mark.Minus -> + loop + (G.E.dst e) + (F.min b (F.Flow (F.sub (Result.flow r e) (F.min_capacity l)))) + in + loop t F.Infinity + + let maxflow g s t = + let r = Result.create () in + let succ s = + G.iter_succ_e + (fun e -> + assert (G.V.equal s (G.E.src e)); + let t = G.E.dst e in + if not (Mark.mem t || is_full r e) then + Mark.set t (Some e) Mark.Plus) + g s + in + let pred s = + G.iter_pred_e + (fun e -> + assert (G.V.equal s (G.E.dst e)); + let t = G.E.src e in + if not (Mark.mem t || is_empty r e) then + Mark.set t (Some e) Mark.Minus) + g s + in + let internal_loop a = + try + while true do let s = Mark.next () in succ s; pred s done; + assert false + with Mark.Empty -> + if Mark.mem t then grow_flow r s t a else a + in + let rec external_loop a = + Mark.clear (); + Mark.set s None Mark.Plus; + let a' = internal_loop a in + if a = a' then a else external_loop a' + in + let a = external_loop F.zero in + (fun e -> try Result.find r e with Not_found -> F.flow (G.E.label e)), a + +end diff --git a/external/ocamlgraph/src/flow.mli b/external/ocamlgraph/src/flow.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/flow.mli @@ -0,0 +1,107 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(** Algorithms on flows + + The following flow algorithms only apply to networks, that are + directed graphs together with a source (a 0 in-degree vertex) and a + terminal (a 0 out-degree vertex). *) + +(** {1 Maximum flow algorithms} *) + +(** Signature for edges' flow *) +module type FLOW = sig + type label + type t + + (** maximum and minimum capacities for a label on an edge *) + + val max_capacity : label -> t + val min_capacity : label -> t + + (** current flow for a label on an edge *) + + val flow : label -> t + + (** [+] and [-] on flows. *) + + val add : t -> t -> t + val sub : t -> t -> t + + (** neutral element for [add] and [sub]. *) + + val zero : t + + (** a total ordering over flows *) + + val compare : t -> t -> int + +end + +(** {2 Goldberg maximal flow algorithm} *) + +(** Minimal digraph signature for Goldberg *) +module type G_GOLDBERG = sig + type t + module V : Sig.COMPARABLE + module E : Sig.EDGE with type vertex = V.t + val nb_vertex : t -> int + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_edges_e : (E.t -> unit) -> t -> unit + val fold_succ_e : (E.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a + val fold_pred_e : (E.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a +end + +module Goldberg(G: G_GOLDBERG)(F: FLOW with type label = G.E.label) : +sig + + val maxflow : G.t -> G.V.t -> G.V.t -> (G.E.t -> F.t) * F.t + (** [maxflow g v1 v2] searchs the maximal flow from source [v1] to + terminal [v2] using the Goldberg algorithm. It returns the new + flows on each edges and the growth of the flow. *) + +end + +(** {2 Ford-Fulkerson maximal flow algorithm} *) + +(** Minimal digraph signature for Ford-Fulkerson *) +module type G_FORD_FULKERSON = sig + type t + module V : Sig.HASHABLE + module E : sig + type t + type label + val src : t -> V.t + val dst : t -> V.t + val label : t -> label + end + val iter_succ_e : (E.t -> unit) -> t -> V.t -> unit + val iter_pred_e : (E.t -> unit) -> t -> V.t -> unit +end + +module Ford_Fulkerson + (G: G_FORD_FULKERSON) + (F: FLOW with type label = G.E.label) : +sig + + val maxflow : G.t -> G.V.t -> G.V.t -> (G.E.t -> F.t) * F.t + (** [maxflow g v1 v2] searchs the maximal flow from source [v1] + to terminal [v2] using the Ford-Fulkerson algorithm. It + returns the new flows on each edges and the growth of the + flow. *) + +end diff --git a/external/ocamlgraph/src/gcoloring.ml b/external/ocamlgraph/src/gcoloring.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/gcoloring.ml @@ -0,0 +1,123 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +exception NoColoring + +module type GM = sig + type t + val nb_vertex : t -> int + module V : Sig.COMPARABLE + val out_degree : t -> V.t -> int + val iter_vertex : (V.t -> unit) -> t -> unit + val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a + module Mark : sig + val get : V.t -> int + val set : V.t -> int -> unit + end +end + +(** Graph coloring with marking. + Only applies to imperative graphs with marks. *) +module Mark(G : GM) = struct + + module Bfs = Traverse.Bfs(G) + + let coloring g k = + (* first step: we eliminate vertices with less than [k] successors *) + let stack = Stack.create () in + let nb_to_color = ref (G.nb_vertex g) in + let count = ref 1 in + while !count > 0 do + count := 0; + let erase v = incr count; G.Mark.set v (k+1); Stack.push v stack in + G.iter_vertex + (fun v -> if G.Mark.get v = 0 && G.out_degree g v < k then erase v) + g; + (*Format.printf "eliminating %d nodes@." !count;*) + nb_to_color := !nb_to_color - !count + done; + (* second step: we k-color the remaining of the graph *) + (* [try_color v i] tries to assign color [i] to vertex [v] *) + let try_color v i = + G.Mark.set v i; + G.iter_succ (fun w -> if G.Mark.get w = i then raise NoColoring) g v + in + let uncolor v = G.Mark.set v 0 in + if !nb_to_color > 0 then begin + let rec iterate iter = + let v = Bfs.get iter in + let m = G.Mark.get v in + if m > 0 then + iterate (Bfs.step iter) + else begin + for i = 1 to k do + try try_color v i; iterate (Bfs.step iter) + with NoColoring -> () + done; + uncolor v; + raise NoColoring + end + in + try iterate (Bfs.start g) with Exit -> () + end; + (* third step: we color the eliminated vertices, in reverse order *) + Stack.iter + (fun v -> + try + for i = 1 to k do + try try_color v i; raise Exit with NoColoring -> () + done; + raise NoColoring (* it may still fail on a self edge v->v *) + with Exit -> ()) + stack + +end + +(** Graph coloring for graphs without marks: we use an external hashtbl *) + +module type G = sig + type t + val nb_vertex : t -> int + module V : Sig.COMPARABLE + val out_degree : t -> V.t -> int + val iter_vertex : (V.t -> unit) -> t -> unit + val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a +end + +module Make(G: G) = struct + + module H = Hashtbl.Make(G.V) + + let coloring g k = + let h = H.create 97 in + let module M = + Mark(struct + include G + module Mark = struct + let get v = try H.find h v with Not_found -> 0 + let set v n = H.replace h v n + end + end ) + in + M.coloring g k; + h + +end diff --git a/external/ocamlgraph/src/gcoloring.mli b/external/ocamlgraph/src/gcoloring.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/gcoloring.mli @@ -0,0 +1,79 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(** k-coloring of undirected graphs. + + A k-coloring of a graph g is a mapping c from nodes to \{1,...,k\} such + that c(u)<>c(v) for any edge u-v in g. *) + +exception NoColoring + +(** Graph coloring for graph with integer marks. *) + +module type GM = sig + type t + val nb_vertex : t -> int + module V : Sig.COMPARABLE + val out_degree : t -> V.t -> int + val iter_vertex : (V.t -> unit) -> t -> unit + val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a + module Mark : sig + val get : V.t -> int + val set : V.t -> int -> unit + end +end + +module Mark(G : GM) : sig + + val coloring : G.t -> int -> unit + (** [coloring g k] colors the nodes of graph [g] using k colors, + assigning the marks integer values between 1 and k. + raises [NoColoring] when there is no possible coloring. + + The graph marks may be partially set before starting; the meaning of + initial values is as follows: + - 0: a node to be colored + - any value between 1 and k: a color already assigned + - any value greater than k: a node to be ignored *) + +end + +(** Graph coloring for graphs without marks *) + +module type G = sig + type t + val nb_vertex : t -> int + module V : Sig.COMPARABLE + val out_degree : t -> V.t -> int + val iter_vertex : (V.t -> unit) -> t -> unit + val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a +end + +module Make(G: G) : sig + + module H : Hashtbl.S with type key = G.V.t + (** hash tables used to store the coloring *) + + val coloring : G.t -> int -> int H.t + (** [coloring g k] colors the graph [g] with [k] colors and returns the + coloring as a hash table mapping nodes to their colors. *) + +end diff --git a/external/ocamlgraph/src/gmap.ml b/external/ocamlgraph/src/gmap.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/gmap.ml @@ -0,0 +1,68 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: gmap.ml,v 1.1 2004-10-20 09:59:56 signoles Exp $ *) + +module Vertex + (G_Init : sig + type t + module V : Sig.HASHABLE + val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a + end) + (G_Dest : sig + type t + type vertex + val empty : unit -> t + val add_vertex : t -> vertex -> t + end) = +struct + + module H = Hashtbl.Make(G_Init.V) + + let vertices = H.create 97 + + let convert_vertex f x = + try + H.find vertices x + with Not_found -> + let x' = f x in + H.add vertices x x'; + x' + + let map f g = + H.clear vertices; + G_Init.fold_vertex + (fun x g -> G_Dest.add_vertex g (convert_vertex f x)) + g (G_Dest.empty ()) + +end + +module Edge + (G_Init : sig + type t + module E : Sig.HASHABLE + val fold_edges_e : (E.t -> 'a -> 'a) -> t -> 'a -> 'a + end) + (G_Dest : sig + type t + type edge + val empty : unit -> t + val add_edge_e : t -> edge -> t + end) = + Vertex + (struct include G_Init module V = E let fold_vertex = fold_edges_e end) + (struct include G_Dest type vertex = edge let add_vertex = add_edge_e end) diff --git a/external/ocamlgraph/src/gmap.mli b/external/ocamlgraph/src/gmap.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/gmap.mli @@ -0,0 +1,60 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: gmap.mli,v 1.1 2004-10-20 09:59:56 signoles Exp $ *) + +(** Graph mapping *) + +module Vertex + (G_Init : sig + type t + module V : Sig.HASHABLE + val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a + end) + (G_Dest : sig + type t + type vertex + val empty : unit -> t + val add_vertex : t -> vertex -> t + end) : +sig + + val map : (G_Init.V.t -> G_Dest.vertex) -> G_Init.t -> G_Dest.t + (** [map f g] applies [f] to each vertex of [g] and so builds a new graph + based on [g] *) + +end + +module Edge + (G_Init : sig + type t + module E : Sig.HASHABLE + val fold_edges_e : (E.t -> 'a -> 'a) -> t -> 'a -> 'a + end) + (G_Dest : sig + type t + type edge + val empty : unit -> t + val add_edge_e : t -> edge -> t + end) : +sig + + val map : (G_Init.E.t -> G_Dest.edge) -> G_Init.t -> G_Dest.t + (** [map f g] applies [f] to each edge of [g] and so builds a new graph + based on [g] *) + +end diff --git a/external/ocamlgraph/src/gml.ml b/external/ocamlgraph/src/gml.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/gml.ml @@ -0,0 +1,670 @@ +# 20 "src/gml.mll" + + + open Lexing + + type value = + | Int of int + | Float of float + | String of string + | List of value_list + + and value_list = (string * value) list + + +# 16 "src/gml.ml" +let __ocaml_lex_tables = { + Lexing.lex_base = + "\000\000\252\255\253\255\114\000\002\000\007\000\228\000\086\001\ + \252\255\253\255\200\001\009\000\014\000\058\002\002\000\251\255\ + \252\255\001\000\080\000\102\000\194\000\216\000\052\001\071\001\ + \253\255\006\000"; + Lexing.lex_backtrk = + "\255\255\255\255\255\255\003\000\000\000\001\000\255\255\255\255\ + \255\255\255\255\003\000\000\000\001\000\255\255\255\255\255\255\ + \255\255\004\000\001\000\000\000\004\000\255\255\001\000\255\255\ + \255\255\255\255"; + Lexing.lex_default = + "\001\000\000\000\000\000\255\255\255\255\255\255\255\255\008\000\ + \000\000\000\000\255\255\255\255\255\255\255\255\015\000\000\000\ + \000\000\025\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \000\000\025\000"; + Lexing.lex_trans = + "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\004\000\004\000\004\000\004\000\004\000\000\000\004\000\ + \005\000\005\000\011\000\011\000\005\000\000\000\011\000\012\000\ + \012\000\000\000\000\000\012\000\000\000\000\000\000\000\000\000\ + \004\000\000\000\004\000\024\000\017\000\000\000\000\000\005\000\ + \024\000\011\000\000\000\000\000\000\000\020\000\012\000\020\000\ + \018\000\000\000\019\000\019\000\019\000\019\000\019\000\019\000\ + \019\000\019\000\019\000\019\000\000\000\000\000\000\000\000\000\ + \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\000\000\000\000\016\000\000\000\000\000\ + \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\005\000\005\000\000\000\000\000\005\000\ + \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ + \018\000\018\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\005\000\000\000\018\000\021\000\019\000\019\000\ + \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ + \000\000\000\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\005\000\005\000\000\000\ + \018\000\005\000\019\000\019\000\019\000\019\000\019\000\019\000\ + \019\000\019\000\019\000\019\000\000\000\000\000\000\000\000\000\ + \002\000\255\255\255\255\023\000\005\000\023\000\255\255\000\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\000\000\000\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\011\000\ + \011\000\000\000\000\000\011\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\011\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\000\000\000\000\009\000\000\000\000\000\000\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\012\000\012\000\000\000\000\000\012\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \012\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\012\000\012\000\000\000\000\000\012\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\255\255\000\000\ + \000\000\000\000\012\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000"; + Lexing.lex_check = + "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\000\000\000\000\004\000\004\000\000\000\255\255\004\000\ + \005\000\005\000\011\000\011\000\005\000\255\255\011\000\012\000\ + \012\000\255\255\255\255\012\000\255\255\255\255\255\255\255\255\ + \000\000\255\255\004\000\017\000\014\000\255\255\255\255\005\000\ + \025\000\011\000\255\255\255\255\255\255\014\000\012\000\014\000\ + \014\000\255\255\014\000\014\000\014\000\014\000\014\000\014\000\ + \014\000\014\000\014\000\014\000\255\255\255\255\255\255\255\255\ + \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\255\255\255\255\014\000\255\255\255\255\ + \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\003\000\003\000\255\255\255\255\003\000\ + \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ + \018\000\018\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\003\000\255\255\019\000\018\000\019\000\019\000\ + \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ + \255\255\255\255\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\006\000\006\000\255\255\ + \020\000\006\000\020\000\020\000\020\000\020\000\020\000\020\000\ + \020\000\020\000\020\000\020\000\255\255\255\255\255\255\255\255\ + \000\000\017\000\014\000\021\000\006\000\021\000\025\000\255\255\ + \021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ + \021\000\021\000\255\255\255\255\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\007\000\ + \007\000\255\255\255\255\007\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\007\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\255\255\255\255\007\000\255\255\255\255\255\255\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\010\000\010\000\255\255\255\255\010\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \010\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\013\000\013\000\255\255\255\255\013\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\007\000\255\255\ + \255\255\255\255\013\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255"; + Lexing.lex_base_code = + "\000\000\000\000\000\000\075\000\000\000\000\000\150\000\208\000\ + \000\000\000\000\027\001\000\000\000\000\102\001\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000"; + Lexing.lex_backtrk_code = + "\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000"; + Lexing.lex_default_code = + "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000"; + Lexing.lex_trans_code = + "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ + \001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000"; + Lexing.lex_check_code = + "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\255\255\255\255\255\255\255\255\255\255\255\255\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ + \007\000\007\000\007\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\255\255\255\255\255\255\255\255\255\255\255\255\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ + \013\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255"; + Lexing.lex_code = + "\255\001\255\255\000\001\255"; +} + +let rec file lexbuf = + lexbuf.Lexing.lex_mem <- Array.create 2 (-1) ; __ocaml_lex_file_rec lexbuf 0 +and __ocaml_lex_file_rec lexbuf __ocaml_lex_state = + match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf with + | 0 -> +# 45 "src/gml.mll" + ( file lexbuf ) +# 425 "src/gml.ml" + + | 1 -> +let +# 46 "src/gml.mll" + key +# 431 "src/gml.ml" += Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_mem.(0) in +# 47 "src/gml.mll" + ( let v = value lexbuf in + (key, v) :: file lexbuf ) +# 436 "src/gml.ml" + + | 2 -> +# 50 "src/gml.mll" + ( [] ) +# 441 "src/gml.ml" + + | 3 -> +let +# 51 "src/gml.mll" + c +# 447 "src/gml.ml" += Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in +# 52 "src/gml.mll" + ( failwith ("Gml: invalid character " ^ String.make 1 c) ) +# 451 "src/gml.ml" + + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_file_rec lexbuf __ocaml_lex_state + +and value_list lexbuf = + lexbuf.Lexing.lex_mem <- Array.create 2 (-1) ; __ocaml_lex_value_list_rec lexbuf 7 +and __ocaml_lex_value_list_rec lexbuf __ocaml_lex_state = + match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf with + | 0 -> +# 56 "src/gml.mll" + ( value_list lexbuf ) +# 462 "src/gml.ml" + + | 1 -> +let +# 57 "src/gml.mll" + key +# 468 "src/gml.ml" += Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_mem.(0) in +# 58 "src/gml.mll" + ( let v = value lexbuf in + (key, v) :: value_list lexbuf ) +# 473 "src/gml.ml" + + | 2 -> +# 61 "src/gml.mll" + ( [] ) +# 478 "src/gml.ml" + + | 3 -> +let +# 62 "src/gml.mll" + c +# 484 "src/gml.ml" += Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in +# 63 "src/gml.mll" + ( failwith ("Gml: invalid character " ^ String.make 1 c) ) +# 488 "src/gml.ml" + + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_value_list_rec lexbuf __ocaml_lex_state + +and value lexbuf = + __ocaml_lex_value_rec lexbuf 14 +and __ocaml_lex_value_rec lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with + | 0 -> +let +# 66 "src/gml.mll" + i +# 500 "src/gml.ml" += Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in +# 67 "src/gml.mll" + ( Int (int_of_string i) ) +# 504 "src/gml.ml" + + | 1 -> +let +# 68 "src/gml.mll" + r +# 510 "src/gml.ml" += Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in +# 69 "src/gml.mll" + ( Float (float_of_string r) ) +# 514 "src/gml.ml" + + | 2 -> +let +# 70 "src/gml.mll" + s +# 520 "src/gml.ml" += Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 1) (lexbuf.Lexing.lex_curr_pos + -1) in +# 71 "src/gml.mll" + ( String s ) +# 524 "src/gml.ml" + + | 3 -> +# 73 "src/gml.mll" + ( let l = value_list lexbuf in List l ) +# 529 "src/gml.ml" + + | 4 -> +let +# 74 "src/gml.mll" + c +# 535 "src/gml.ml" += Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in +# 75 "src/gml.mll" + ( failwith ("Gml: invalid character " ^ String.make 1 c) ) +# 539 "src/gml.ml" + + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_value_rec lexbuf __ocaml_lex_state + +;; + +# 77 "src/gml.mll" + + + let parse f = + let c = open_in f in + let lb = from_channel c in + let v = file lb in + close_in c; + v + + module Parse + (B : Builder.S) + (L : sig val node : value_list -> B.G.V.label + val edge : value_list -> B.G.E.label end) = + struct + + let create_graph l = + let nodes = Hashtbl.create 97 in + let g = B.empty () in + (* 1st pass: create the nodes *) + let g = + List.fold_left + (fun g v -> match v with + | "node", List l -> + let n = B.G.V.create (L.node l) in + begin + try + let id = List.assoc "id" l in Hashtbl.add nodes id n + with Not_found -> + () + end; + B.add_vertex g n + | _ -> + g) + g l + in + (* 2nd pass: add the edges *) + List.fold_left + (fun g v -> match v with + | "edge", List l -> + begin try + let source = List.assoc "source" l in + let target = List.assoc "target" l in + let nsource = Hashtbl.find nodes source in + let ntarget = Hashtbl.find nodes target in + let e = B.G.E.create nsource (L.edge l) ntarget in + B.add_edge_e g e + with Not_found -> + g + end + | _ -> + g) + g l + + let parse f = + match parse f with + | ["graph", List l] -> create_graph l + | _ -> invalid_arg "Gml.Parse.parse: not a graph file" + + end + + module Print + (G : sig + module V : sig + type t + val hash : t -> int + val equal : t -> t -> bool + type label + val label : t -> label + end + module E : sig + type t + type label + val src : t -> V.t + val dst : t -> V.t + val label : t -> label + end + type t + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_edges_e : (E.t -> unit) -> t -> unit + end) + (L : sig + val node : G.V.label -> value_list + val edge : G.E.label -> value_list + end) = + struct + + open Format + + module H = Hashtbl.Make(G.V) + + let print fmt g = + let nodes = H.create 97 in + let cpt = ref 0 in + let id n = + try H.find nodes n + with Not_found -> incr cpt; let id = !cpt in H.add nodes n id; id + in + fprintf fmt "@[graph [@\n"; + let rec value fmt = function + | Int n -> fprintf fmt "%d" n + | Float f -> fprintf fmt "%f" f + | String s -> fprintf fmt "\"%s\"" s + | List l -> fprintf fmt "[@\n @[%a@]@\n]" value_list l + and value_list fmt = function + | [] -> () + | [s,v] -> fprintf fmt "%s %a" s value v + | (s,v) :: l -> fprintf fmt "%s %a@\n" s value v; value_list fmt l + in + G.iter_vertex + (fun v -> + fprintf fmt " @[node [@\n id %d@\n @[%a@]@\n]@]@\n" + (id v) value_list (L.node (G.V.label v))) + g; + G.iter_edges_e + (fun e -> + fprintf fmt + " @[edge [@\n source %d@\n target %d@\n @[%a@]@\n]@]@\n" + (id (G.E.src e)) (id (G.E.dst e)) + value_list (L.edge (G.E.label e))) + g; + fprintf fmt "]@\n" + + end + + +# 671 "src/gml.ml" diff --git a/external/ocamlgraph/src/gml.mli b/external/ocamlgraph/src/gml.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/gml.mli @@ -0,0 +1,76 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: gml.mli,v 1.3 2005-07-06 13:20:31 conchon Exp $ *) + +(** Parser for GML file format *) + +type value = + | Int of int + | Float of float + | String of string + | List of value_list + +and value_list = (string * value) list + +module Parse + (B : Builder.S) + (L : sig + val node : value_list -> B.G.V.label + (** how to build the node label out of the set of GML attributes; +for example {v node [ id 12 label "foo" ] v} +will call this function with [["id", Int 12; "label", String "foo"]] *) + val edge : value_list -> B.G.E.label + (** how to build the edge label out of the set of GML attributes *) + end) : +sig + + val parse : string -> B.G.t + +end + +module Print + (G : sig + module V : sig + type t + val hash : t -> int + val equal : t -> t -> bool + type label + val label : t -> label + end + module E : sig + type t + type label + val src : t -> V.t + val dst : t -> V.t + val label : t -> label + end + type t + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_edges_e : (E.t -> unit) -> t -> unit + end) + (L : sig + val node : G.V.label -> value_list + val edge : G.E.label -> value_list + end) : +sig + + val print : Format.formatter -> G.t -> unit + +end + + diff --git a/external/ocamlgraph/src/gml.mll b/external/ocamlgraph/src/gml.mll new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/gml.mll @@ -0,0 +1,202 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: gml.mll,v 1.3 2005-07-06 13:20:31 conchon Exp $ *) + +{ + + open Lexing + + type value = + | Int of int + | Float of float + | String of string + | List of value_list + + and value_list = (string * value) list + +} + +let space = [' ' '\t' '\r' '\n']+ +let ident = ['a'-'z' 'A'-'Z'] ['a'-'z' 'A'-'Z' '0'-'9']* +let digit = ['0'-'9'] +let sign = '-' | '+' +let integer = sign? digit+ +let mantissa = 'E' sign? digit+ +let real = sign? digit* '.' digit* mantissa? +let in_string = [^ '"']* + +rule file = parse + | space + { file lexbuf } + | (ident as key) space + { let v = value lexbuf in + (key, v) :: file lexbuf } + | eof + { [] } + | _ as c + { failwith ("Gml: invalid character " ^ String.make 1 c) } + +and value_list = parse + | space + { value_list lexbuf } + | (ident as key) space + { let v = value lexbuf in + (key, v) :: value_list lexbuf } + | ']' + { [] } + | _ as c + { failwith ("Gml: invalid character " ^ String.make 1 c) } + +and value = parse + | integer as i + { Int (int_of_string i) } + | real as r + { Float (float_of_string r) } + | '"' (in_string as s) '"' + { String s } + | '[' + { let l = value_list lexbuf in List l } + | _ as c + { failwith ("Gml: invalid character " ^ String.make 1 c) } + +{ + + let parse f = + let c = open_in f in + let lb = from_channel c in + let v = file lb in + close_in c; + v + + module Parse + (B : Builder.S) + (L : sig val node : value_list -> B.G.V.label + val edge : value_list -> B.G.E.label end) = + struct + + let create_graph l = + let nodes = Hashtbl.create 97 in + let g = B.empty () in + (* 1st pass: create the nodes *) + let g = + List.fold_left + (fun g v -> match v with + | "node", List l -> + let n = B.G.V.create (L.node l) in + begin + try + let id = List.assoc "id" l in Hashtbl.add nodes id n + with Not_found -> + () + end; + B.add_vertex g n + | _ -> + g) + g l + in + (* 2nd pass: add the edges *) + List.fold_left + (fun g v -> match v with + | "edge", List l -> + begin try + let source = List.assoc "source" l in + let target = List.assoc "target" l in + let nsource = Hashtbl.find nodes source in + let ntarget = Hashtbl.find nodes target in + let e = B.G.E.create nsource (L.edge l) ntarget in + B.add_edge_e g e + with Not_found -> + g + end + | _ -> + g) + g l + + let parse f = + match parse f with + | ["graph", List l] -> create_graph l + | _ -> invalid_arg "Gml.Parse.parse: not a graph file" + + end + + module Print + (G : sig + module V : sig + type t + val hash : t -> int + val equal : t -> t -> bool + type label + val label : t -> label + end + module E : sig + type t + type label + val src : t -> V.t + val dst : t -> V.t + val label : t -> label + end + type t + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_edges_e : (E.t -> unit) -> t -> unit + end) + (L : sig + val node : G.V.label -> value_list + val edge : G.E.label -> value_list + end) = + struct + + open Format + + module H = Hashtbl.Make(G.V) + + let print fmt g = + let nodes = H.create 97 in + let cpt = ref 0 in + let id n = + try H.find nodes n + with Not_found -> incr cpt; let id = !cpt in H.add nodes n id; id + in + fprintf fmt "@[graph [@\n"; + let rec value fmt = function + | Int n -> fprintf fmt "%d" n + | Float f -> fprintf fmt "%f" f + | String s -> fprintf fmt "\"%s\"" s + | List l -> fprintf fmt "[@\n @[%a@]@\n]" value_list l + and value_list fmt = function + | [] -> () + | [s,v] -> fprintf fmt "%s %a" s value v + | (s,v) :: l -> fprintf fmt "%s %a@\n" s value v; value_list fmt l + in + G.iter_vertex + (fun v -> + fprintf fmt " @[node [@\n id %d@\n @[%a@]@\n]@]@\n" + (id v) value_list (L.node (G.V.label v))) + g; + G.iter_edges_e + (fun e -> + fprintf fmt + " @[edge [@\n source %d@\n target %d@\n @[%a@]@\n]@]@\n" + (id (G.E.src e)) (id (G.E.dst e)) + value_list (L.edge (G.E.label e))) + g; + fprintf fmt "]@\n" + + end + +} + diff --git a/external/ocamlgraph/src/gpath.ml b/external/ocamlgraph/src/gpath.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/gpath.ml @@ -0,0 +1,132 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: path.ml,v 1.6 2005-07-18 07:10:35 filliatr Exp $ *) + +module type WEIGHT = sig + type label + type t + val weight : label -> t + val zero : t + val add : t -> t -> t + val compare : t -> t -> int +end + +module type G = sig + type t + module V : Sig.COMPARABLE + module E : sig + type t + type label + val label : t -> label + val dst : t -> V.t + end + val iter_succ_e : (E.t -> unit) -> t -> V.t -> unit +end + +module Dijkstra + (G: G) + (W: WEIGHT with type label = G.E.label) = +struct + + open G.E + + module H = Hashtbl.Make(G.V) + + module Elt = struct + type t = W.t * G.V.t * G.E.t list + + (* weights are compared first, and minimal weights come first in the + queue *) + let compare (w1,v1,_) (w2,v2,_) = + let cw = W.compare w2 w1 in + if cw != 0 then cw else G.V.compare v1 v2 + end + + module PQ = Heap.Imperative(Elt) + + let shortest_path g v1 v2 = + let visited = H.create 97 in + let q = PQ.create 17 in + let rec loop () = + if PQ.is_empty q then raise Not_found; + let (w,v,p) = PQ.pop_maximum q in + if G.V.compare v v2 = 0 then + List.rev p, w + else begin + if not (H.mem visited v) then begin + H.add visited v (); + G.iter_succ_e + (fun e -> PQ.add q (W.add w (W.weight (label e)), dst e, e :: p)) + g v + end; + loop () + end + in + PQ.add q (W.zero, v1, []); + loop () + +end + + + +module Check + (G : + sig + type t + module V : Sig.COMPARABLE + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + end) = +struct + + module HV = Hashtbl.Make(G.V) + module HVV = Hashtbl.Make(Util.HTProduct(G.V)(G.V)) + + (* the cache contains the path tests already computed *) + type path_checker = { cache : bool HVV.t; graph : G.t } + + let create g = { cache = HVV.create 97; graph = g } + + let check_path pc v1 v2 = + try + HVV.find pc.cache (v1, v2) + with Not_found -> + (* the path is not in cache; we check it with Dijkstra *) + let visited = HV.create 97 in + let q = Queue.create () in + let rec loop () = + if Queue.is_empty q then begin + HVV.add pc.cache (v1, v2) false; + false + end else begin + let v = Queue.pop q in + HVV.add pc.cache (v1, v) true; + if G.V.compare v v2 = 0 then + true + else begin + if not (HV.mem visited v) then begin + HV.add visited v (); + G.iter_succ (fun v' -> Queue.add v' q) pc.graph v + end; + loop () + end + end + in + Queue.add v1 q; + loop () + +end diff --git a/external/ocamlgraph/src/gpath.mli b/external/ocamlgraph/src/gpath.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/gpath.mli @@ -0,0 +1,96 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: path.mli,v 1.9 2005-07-18 07:10:35 filliatr Exp $ *) + +(** Paths *) + +(** Minimal graph signature for Dijkstra's algorithm *) +module type G = sig + type t + module V : Sig.COMPARABLE + module E : sig + type t + type label + val label : t -> label + val dst : t -> V.t + end + val iter_succ_e : (E.t -> unit) -> t -> V.t -> unit +end + +(** Signature for edges' weights *) +module type WEIGHT = sig + type label + type t + val weight : label -> t + val zero : t + val add : t -> t -> t + val compare : t -> t -> int +end + +module Dijkstra + (G: G) + (W: WEIGHT with type label = G.E.label) : +sig + + val shortest_path : G.t -> G.V.t -> G.V.t -> G.E.t list * W.t + (** [shortest_path g v1 v2] computes the shortest path from vertex [v1] + to vertex [v2] in graph [g]. The path is returned as the list of + followed edges, together with the total length of the path. + raise [Not_found] if the path from [v1] to [v2] does not exist. + + Complexity: at most O((V+E)log(V)) *) + +end + + +(** Check for a path *) + +module Check + (G : + sig + type t + module V : Sig.COMPARABLE + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + end) : +sig + + type path_checker + (** the abstract data type of a path checker; this is a mutable data + structure *) + + val create : G.t -> path_checker + (** [create g] builds a new path checker for the graph [g]; + if the graph is mutable, it must not be mutated while this path + checker is in use (through the function [check_path] below). *) + + val check_path : path_checker -> G.V.t -> G.V.t -> bool + (** [check_path pc v1 v2] checks whether there is a path from [v1] to + [v2] in the graph associated to the path checker [pc]. + + Complexity: The path checker contains a cache of all results computed + so far. This cache is implemented with a hash table so access in this + cache is usually O(1). When the result is not in the cache, Dijkstra's + algorithm is run to check for the path, and all intermediate results + are cached. + + Note: if checks are to be done for almost all pairs of vertices, it + may be more efficient to compute the transitive closure of the graph + (see module [Oper]). + *) + +end diff --git a/external/ocamlgraph/src/graphviz.ml b/external/ocamlgraph/src/graphviz.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/graphviz.ml @@ -0,0 +1,779 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: graphviz.ml,v 1.4 2006-05-09 10:19:37 conchon Exp $ *) + +(** Interface with {i GraphViz} + + This module provides a basic interface with dot and neato, + two programs of the GraphViz toolbox. + These tools are available at the following URLs: + http://www.graphviz.org/ + http://www.research.att.com/sw/tools/graphviz/ + + *) + +open Format + +(***************************************************************************) +(** {2 Common stuff} *) + +(** Because the neato and dot engines present a lot of common points - + in particular in the graph description language, large parts of + the code is shared. First, the [!CommonAttributes] module defines + attributes of graphs, nodes and edges that are understood by the + two engines. Second, given a module (of type [!ENGINE]) + describing an engine the [!MakeEngine] functor provides suitable + interface function for it. *) + +(*-------------------------------------------------------------------------*) +(** {3 Common attributes} *) + +type color = int + +let fprint_color ppf color = + fprintf ppf "\"#%06X\"" color + +let fprint_string ppf s = fprintf ppf "\"%s\"" s +(* let s' = String.escaped s in + if s' = s && s <> "" + then fprintf ppf "%s" s + else fprintf ppf "\"%s\"" s'*) + +let fprint_string_user ppf s = +(* let s = String.escaped s in*) + fprintf ppf "\"%s\"" s + +type arrow_style = + [ `None | `Normal | `Inv | `Dot | `Odot | `Invdot | `Invodot ] + +let fprint_arrow_style ppf = function + `None -> fprintf ppf "none" + | `Normal -> fprintf ppf "normal" + | `Inv -> fprintf ppf "inv" + | `Dot -> fprintf ppf "dot" + | `Odot -> fprintf ppf "odot" + | `Invdot -> fprintf ppf "invdot" + | `Invodot -> fprintf ppf "invodot" + +let fprint_dir ppf = function + `TopToBottom -> fprintf ppf "TB" + | `LeftToRight -> fprintf ppf "LR" + +(** The [ATTRIBUTES] module type defines the interface for the engines. *) +module type ATTRIBUTES = sig + + type graph (** Attributes of graphs. *) + + type vertex (** Attributes of vertices. *) + + type edge (** Attributes of edges. *) + + (** Attributes of (optional) boxes around vertices. *) + type subgraph = { + sg_name : string; (** Box name. *) + sg_attributes : vertex list; (** Box attributes. *) + } + +end + +(** The [CommonAttributes] module defines attributes for graphs, nodes and + edges that are available in the two engines, dot and neato. *) +module CommonAttributes = struct + + (** Attributes of graphs. *) + type graph = + [ `Center of bool + (** Centers the drawing on the page. Default value is [false]. *) + | `Fontcolor of color + (** Sets the font color. Default value is [black]. *) + | `Fontname of string + (** Sets the font family name. Default value is ["Times-Roman"]. *) + | `Fontsize of int + (** Sets the type size (in points). Default value is [14]. *) + | `Label of string + (** Caption for graph drawing. *) + | `Orientation of [ `Portrait | `Landscape ] + (** Sets the page orientation. Default value is [`Portrait]. *) + | `Page of float * float + (** Sets the PostScript pagination unit, e.g [8.5, 11.0]. *) + | `Pagedir of [ `TopToBottom | `LeftToRight ] + (** Traversal order of pages. Default value is [`TopToBottom]. *) + | `Size of float * float + (** Sets the bounding box of drawing (in inches). *) + | `OrderingOut + (** Constrains order of out-edges in a subgraph according to + their file sequence *) + ] + + (** Attributes of nodes. *) + type vertex = + [ `Color of color + (** Sets the color of the border of the node. Default value is [black] + *) + | `Fontcolor of color + (** Sets the label font color. Default value is [black]. *) + | `Fontname of string + (** Sets the label font family name. Default value is + ["Times-Roman"]. *) + | `Fontsize of int + (** Sets the label type size (in points). Default value is [14]. *) + | `Height of float + (** Sets the minimum height. Default value is [0.5]. *) + | `Label of string + (** Sets the label printed in the node. The string may include escaped + newlines [\n], [\l], or [\r] for center, left, and right justified + lines. + Record labels may contain recursive box lists delimited by { | }. + *) + | `Orientation of float + (** Node rotation angle, in degrees. Default value is [0.0]. *) + | `Peripheries of int + (** Sets the number of periphery lines drawn around the polygon. *) + | `Regular of bool + (** If [true], then the polygon is made regular, i.e. symmetric about + the x and y axis, otherwise the polygon takes on the aspect + ratio of the label. Default value is [false]. *) + | `Shape of + [`Ellipse | `Box | `Circle | `Doublecircle | `Diamond + | `Plaintext | `Record | `Polygon of int * float] + (** Sets the shape of the node. Default value is [`Ellipse]. + [`Polygon (i, f)] draws a polygon with [n] sides and a skewing + of [f]. *) + | `Style of [ `Filled | `Solid | `Dashed | `Dotted | `Bold | `Invis ] + (** Sets the layout style of the node. Several styles may be combined + simultaneously. *) + | `Width of float + (** Sets the minimum width. Default value is [0.75]. *) + ] + + (** Attributes of edges. *) + type edge = + [ `Color of color + (** Sets the edge stroke color. Default value is [black]. *) + | `Decorate of bool + (** If [true], draws a line connecting labels with their edges. *) + | `Dir of [ `Forward | `Back | `Both | `None ] + (** Sets arrow direction. Default value is [`Forward]. *) + | `Fontcolor of color + (** Sets the label font color. Default value is [black]. *) + | `Fontname of string + (** Sets the label font family name. Default value is + ["Times-Roman"]. *) + | `Fontsize of int + (** Sets the label type size (in points). Default value is [14]. *) + | `Label of string + (** Sets the label to be attached to the edge. The string may include + escaped newlines [\n], [\l], or [\r] for centered, left, or right + justified lines. *) + | `Labelfontcolor of color + (** Sets the font color for head and tail labels. Default value is + [black]. *) + | `Labelfontname of string + (** Sets the font family name for head and tail labels. Default + value is ["Times-Roman"]. *) + | `Labelfontsize of int + (** Sets the font size for head and tail labels (in points). + Default value is [14]. *) + | `Style of [ `Solid | `Dashed | `Dotted | `Bold | `Invis ] + (** Sets the layout style of the edge. Several styles may be combined + simultaneously. *) + ] + + (** Pretty-print. *) + + let fprint_orientation ppf = function + `Portrait -> fprintf ppf "portrait" + | `Landscape -> fprintf ppf "landscape" + + let fprint_graph ppf = function + `Center b -> fprintf ppf "center=%i" (if b then 1 else 0) + | `Fontcolor a -> fprintf ppf "fontcolor=%a" fprint_color a + | `Fontname s -> fprintf ppf "fontname=%a" fprint_string s + | `Fontsize i -> fprintf ppf "fontsize=%i" i + | `Label s -> fprintf ppf "label=%a" fprint_string_user s + | `Orientation a -> fprintf ppf "orientation=%a" fprint_orientation a + | `Page (x, y) -> fprintf ppf "page=\"%f,%f\"" x y + | `Pagedir a -> fprintf ppf "pagedir=%a" fprint_dir a + | `Size (x, y) -> fprintf ppf "size=\"%f,%f\"" x y + | `OrderingOut -> fprintf ppf "ordering=out" + + let fprint_shape ppf = function + | `Ellipse -> fprintf ppf "ellipse" + | `Box -> fprintf ppf "box" + | `Circle -> fprintf ppf "circle" + | `Doublecircle -> fprintf ppf "doublecircle" + | `Diamond -> fprintf ppf "diamond" + | `Plaintext -> fprintf ppf "plaintext" + | `Record -> fprintf ppf "record" + | `Polygon (i, f) -> fprintf ppf "polygon, sides=%i, skew=%f" i f + + let fprint_node_style ppf = function + `Filled -> fprintf ppf "filled" + | `Solid -> fprintf ppf "solid" + | `Dashed -> fprintf ppf "dashed" + | `Dotted -> fprintf ppf "dotted" + | `Bold -> fprintf ppf "bold" + | `Invis -> fprintf ppf "invis" + + let fprint_vertex ppf = function + `Color a -> fprintf ppf "color=%a" fprint_color a + | `Fontcolor a -> fprintf ppf "fontcolor=%a" fprint_color a + | `Fontname s -> fprintf ppf "fontname=%a" fprint_string s + | `Fontsize i -> fprintf ppf "fontsize=%i" i + | `Height f -> fprintf ppf "height=%f" f + | `Label s -> fprintf ppf "label=%a" fprint_string_user s + | `Orientation f -> fprintf ppf "orientation=%f" f + | `Peripheries i -> fprintf ppf "peripheries=%i" i + | `Regular b -> fprintf ppf "regular=%b" b + | `Shape a -> fprintf ppf "shape=%a" fprint_shape a + | `Style a -> fprintf ppf "style=%a" fprint_node_style a + | `Width f -> fprintf ppf "width=%f" f + + let fprint_edge_style = + fprint_node_style + + let fprint_arrow_direction ppf = function + `Forward -> fprintf ppf "forward" + | `Back -> fprintf ppf "back" + | `Both -> fprintf ppf "both" + | `None -> fprintf ppf "none" + + let fprint_edge ppf = function + `Color a -> fprintf ppf "color=%a" fprint_color a + | `Decorate b -> fprintf ppf "decorate=%b" b + | `Dir a -> fprintf ppf "dir=%a" fprint_arrow_direction a + | `Fontcolor a -> fprintf ppf "fontcolor=%a" fprint_color a + | `Fontname s -> fprintf ppf "fontname=%a" fprint_string s + | `Fontsize i -> fprintf ppf "fontsize=%i" i + | `Label s -> fprintf ppf "label=%a" fprint_string_user s + | `Labelfontcolor a -> fprintf ppf "labelfontcolor=%a" fprint_color a + | `Labelfontname s -> fprintf ppf "labelfontname=\"%s\"" s + (* (String.escaped s) *) + | `Labelfontsize i -> fprintf ppf "labelfontsize=%i" i + | `Style a -> fprintf ppf "style=%a" fprint_edge_style a + +end + + +(*-------------------------------------------------------------------------*) +(** {3 The [MakeEngine] functor} *) + +(** An engine is described by a module of the following signature. *) +module type ENGINE = sig + + module Attributes : sig + include ATTRIBUTES + val fprint_graph:formatter -> graph -> unit + val fprint_vertex: formatter -> vertex -> unit + val fprint_edge: formatter -> edge -> unit + end + + (** The litteral name of the engine. *) + val name: string + + (** The keyword for graphs ("digraph" for dot, "graph" for neato) *) + val opening: string + + (** The litteral for edge arrows ("->" for dot, "--" for neato) *) + val edge_arrow: string + +end + +module type GRAPH = sig + +end + +module MakeEngine + (EN: ENGINE) + (X : sig + type t + module V : sig type t end + module E : sig type t val src : t -> V.t val dst : t -> V.t end + + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_edges_e : (E.t -> unit) -> t -> unit + + val graph_attributes: t -> EN.Attributes.graph list + + val default_vertex_attributes: t -> EN.Attributes.vertex list + val vertex_name : V.t -> string + val vertex_attributes: V.t -> EN.Attributes.vertex list + + val default_edge_attributes: t -> EN.Attributes.edge list + val edge_attributes: E.t -> EN.Attributes.edge list + val get_subgraph : V.t -> EN.Attributes.subgraph option + end) = +struct + + let command = ref EN.name + let set_command cmd = + command := cmd + + exception Error of string + + let handle_error f arg = + try + f arg + with + Error msg -> + Printf.eprintf "%s: %s failure\n %s\n" + Sys.argv.(0) EN.name msg; + flush stderr; + exit 2 + + (** [fprint_graph_attributes ppf list] pretty prints a list of + graph attributes on the formatter [ppf]. Attributes are separated + by a ";". *) + let fprint_graph_attributes ppf list = + List.iter (function att -> + fprintf ppf "%a;@ " EN.Attributes.fprint_graph att + ) list + + (** [fprint_graph_attribute printer ppf list] pretty prints a list of + attributes on the formatter [ppf], using the printer [printer] for + each attribute. The list appears between brackets and attributes + are speparated by ",". If the list is empty, nothing is printed. *) + let fprint_attributes fprint_attribute ppf = function + [] -> () + | hd :: tl -> + let rec fprint_attributes_rec ppf = function + [] -> () + | hd' :: tl' -> + fprintf ppf ",@ %a%a" + fprint_attribute hd' + fprint_attributes_rec tl' + in + fprintf ppf " [@[%a%a@]]" + fprint_attribute hd + fprint_attributes_rec tl + + (** [fprint_graph_attributes ppf list] pretty prints a list of + node attributes using the format of [fprint_attributes]. *) + let fprint_node_attributes ppf list = + fprint_attributes EN.Attributes.fprint_vertex ppf list + + (** [fprint_graph_attributes ppf list] pretty prints a list of + edge attributes using the format of [fprint_attributes]. *) + let fprint_edge_attributes ppf list = + fprint_attributes EN.Attributes.fprint_edge ppf list + + (** [fprint_graph ppf graph] pretty prints the graph [graph] in + the CGL language on the formatter [ppf]. *) + let fprint_graph ppf graph = + let subgraphs = Hashtbl.create 7 in + + (* Printing nodes. *) + + let print_nodes ppf = + + let default_node_attributes = X.default_vertex_attributes graph in + if default_node_attributes <> [] then + fprintf ppf "node%a;@ " + fprint_node_attributes default_node_attributes; + + X.iter_vertex + (function node -> + begin match X.get_subgraph node with + | None -> () + | Some sg -> + try + let (sg,nodes) = + Hashtbl.find subgraphs sg.EN.Attributes.sg_name + in + Hashtbl.replace subgraphs + sg.EN.Attributes.sg_name (sg,node::nodes) + with Not_found -> + Hashtbl.add subgraphs sg.EN.Attributes.sg_name (sg,[node]) + end; + fprintf ppf "%s%a;@ " + (X.vertex_name node) + fprint_node_attributes (X.vertex_attributes node)) + graph + + in + + (* Printing subgraphs *) + + let print_subgraphs ppf = + + Hashtbl.iter + (fun name (sg,nodes) -> + fprintf ppf "@[subgraph cluster_%s { %t%t };@]@\n" + name + + (fun ppf -> + (List.iter + (fun n -> + fprintf ppf "%a;@\n" EN.Attributes.fprint_vertex n) + sg.EN.Attributes.sg_attributes)) + + (fun ppf -> + (List.iter + (fun n -> fprintf ppf "%s;" (X.vertex_name n)) + nodes)) + ) + subgraphs + + in + + (* Printing edges *) + + let print_edges ppf = + + let default_edge_attributes = X.default_edge_attributes graph in + if default_edge_attributes <> [] then + fprintf ppf "edge%a;@ " + fprint_edge_attributes default_edge_attributes; + + X.iter_edges_e (function edge -> + fprintf ppf "%s %s %s%a;@ " + (X.vertex_name (X.E.src edge)) + EN.edge_arrow + (X.vertex_name (X.E.dst edge)) + fprint_edge_attributes (X.edge_attributes edge) + ) graph + + in + + fprintf ppf "@[%s G {@ @[ %a" + EN.opening + fprint_graph_attributes (X.graph_attributes graph); + fprintf ppf "%t@ " print_nodes; + fprintf ppf "%t@ " print_subgraphs; + fprintf ppf "%t@ " print_edges; + fprintf ppf "@]}@]" + + (** [output_graph oc graph] pretty prints the graph [graph] in the dot + language on the channel [oc]. *) + let output_graph oc graph = + + let ppf = formatter_of_out_channel oc in + fprint_graph ppf graph; + pp_print_flush ppf () + + end + +(***************************************************************************) +(** {2 Interface with the dot engine} *) + +(** The [DotAttributes] module defines attributes for graphs, nodes and edges + that are available in the dot engine. *) +module DotAttributes = struct + + (** Attributes of graphs. They include all common graph attributes and + several specific ones. All attributes described in the "dot User's + Manual, February 4, 2002" are handled, excepted: clusterank, color, + compound, labeljust, labelloc, ordering, rank, remincross, rotate, + searchsize and style. + *) + type graph = + [ CommonAttributes.graph + | `Bgcolor of color + (** Sets the background color and the inital fill color. *) + | `Comment of string + (** Comment string. *) + | `Concentrate of bool + (** If [true], enables edge concentrators. Default value is [false]. *) + | `Fontpath of string + (** List of directories for fonts. *) + | `Layers of string list + (** List of layers. *) + | `Margin of float + (** Sets the page margin (included in the page size). Default value is + [0.5]. *) + | `Mclimit of float + (** Scale factor for mincross iterations. Default value is [1.0]. *) + | `Nodesep of float + (** Sets the minimum separation between nodes, in inches. Default + value is [0.25]. *) + | `Nslimit of int + (** If set of [f], bounds network simplex iterations by [f * + ] when ranking nodes. *) + | `Nslimit1 of int + (** If set of [f], bounds network simplex iterations by [f * + ] when setting x-coordinates. *) + | `Ranksep of float + (** Sets the minimum separation between ranks. *) + | `Quantum of float + (** If not [0.0], node label dimensions will be rounded to integral + multiples of it. Default value is [0.0]. *) + | `Rankdir of [ `TopToBottom | `LeftToRight ] + (** Direction of rank ordering. Default value is [`TopToBottom]. *) + | `Ratio of [ `Float of float | `Fill | `Compress| `Auto ] + (** Sets the aspect ratio. *) + | `Samplepoints of int + (** Number of points used to represent ellipses and circles on output. + Default value is [8]. *) + | `Url of string + (** URL associated with graph (format-dependent). *) + ] + + (** Attributes of nodes. They include all common node attributes and + several specific ones. All attributes described in the "dot User's + Manual, February 4, 2002" are handled, excepted: bottomlabel, group, + shapefile and toplabel. + *) + type vertex = + [ CommonAttributes.vertex + | `Comment of string + (** Comment string. *) + | `Distortion of float + (* TEMPORARY *) + | `Fillcolor of color + (** Sets the fill color (used when `Style filled). Default value + is [lightgrey]. *) + | `Fixedsize of bool + (** If [true], forces the given dimensions to be the actual ones. + Default value is [false]. *) + | `Layer of string + (** Overlay. *) + | `Url of string + (** The default url for image map files; in PostScript files, + the base URL for all relative URLs, as recognized by Acrobat + Distiller 3.0 and up. *) + | `Z of float + (** z coordinate for VRML output. *) + ] + + (** Attributes of edges. They include all common edge attributes and + several specific ones. All attributes described in the "dot User's + Manual, February 4, 2002" are handled, excepted: lhead and ltail. + *) + type edge = + [ CommonAttributes.edge + | `Arrowhead of arrow_style + (** Sets the style of the head arrow. Default value is [`Normal]. *) + | `Arrowsize of float + (** Sets the scaling factor of arrowheads. Default value is [1.0]. *) + | `Arrowtail of arrow_style + (** Sets the style of the tail arrow. Default value is [`Normal]. *) + | `Comment of string + (** Comment string. *) + | `Constraints of bool + (** If [false], causes an edge to be ignored for rank assignment. + Default value is [true]. *) + | `Headlabel of string + (** Sets the label attached to the head arrow. *) + | `Headport of [ `N | `NE | `E | `SE | `S | `SW | `W | `NW ] + (* TEMPORARY *) + | `Headurl of string + (** Url attached to head label if output format is ismap. *) + | `Labelangle of float + (** Angle in degrees which head or tail label is rotated off edge. + Default value is [-25.0]. *) + | `Labeldistance of float + (** Scaling factor for distance of head or tail label from node. + Default value is [1.0]. *) + | `Labelfloat of bool + (** If [true], lessen constraints on edge label placement. + Default value is [false]. *) + | `Layer of string + (** Overlay. *) + | `Minlen of int + (** Minimum rank distance between head an tail. Default value is [1]. *) + | `Samehead of string + (** Tag for head node; edge heads with the same tag are merged onto the + same port. *) + | `Sametail of string + (** Tag for tail node; edge tails with the same tag are merged onto the + same port. *) + | `Taillabel of string + (** Sets the label attached to the tail arrow. *) + | `Tailport of [ `N | `NE | `E | `SE | `S | `SW | `W | `NW ] + (* TEMPORARY *) + | `Tailurl of string + (** Url attached to tail label if output format is ismap. *) + | `Weight of int + (** Sets the integer cost of stretching the edge. Default value is + [1]. *) + ] + + type subgraph = { + sg_name : string; + sg_attributes : vertex list; + } + + (** {4 Pretty-print of attributes} *) + + let rec fprint_string_list ppf = function + [] -> () + | [hd] -> fprintf ppf "%s" hd + | hd :: tl -> fprintf ppf "%s,%a" hd fprint_string_list tl + + let fprint_ratio ppf = function + `Float f -> fprintf ppf "%f" f + | `Fill -> fprintf ppf "fill" + | `Compress -> fprintf ppf "compress" + | `Auto -> fprintf ppf "auto" + + let fprint_graph ppf = function + #CommonAttributes.graph as att -> CommonAttributes.fprint_graph ppf att + | `Bgcolor a -> fprintf ppf "bgcolor=%a" fprint_color a + | `Comment s -> fprintf ppf "comment=%a" fprint_string s + | `Concentrate b -> fprintf ppf "concentrate=%b" b + | `Fontpath s -> fprintf ppf "fontpath=%a" fprint_string s + | `Layers s -> fprintf ppf "layers=%a" fprint_string_list s + | `Margin f -> fprintf ppf "margin=%f" f + | `Mclimit f -> fprintf ppf "mclimit=%f" f + | `Nodesep f -> fprintf ppf "nodesep=%f" f + | `Nslimit i -> fprintf ppf "nslimit=%i" i + | `Nslimit1 i -> fprintf ppf "nslimit1=%i" i + | `Ranksep f -> fprintf ppf "ranksep=%f" f + | `Quantum f -> fprintf ppf "quantum=%f" f + | `Rankdir a -> fprintf ppf "rankdir=%a" fprint_dir a + | `Ratio a -> fprintf ppf "ratio=%a" fprint_ratio a + | `Samplepoints i -> fprintf ppf "samplepoints=%i" i + | `Url s -> fprintf ppf "URL=\"%s\"" s (*(String.escaped s)*) + + let fprint_vertex ppf = function + #CommonAttributes.vertex as att -> + CommonAttributes.fprint_vertex ppf att + | `Comment s -> fprintf ppf "comment=%a" fprint_string s + | `Distortion f -> fprintf ppf "distortion=%f" f + | `Fillcolor a -> fprintf ppf "fillcolor=%a" fprint_color a + | `Fixedsize b -> fprintf ppf "fixedsize=%b" b + | `Layer s -> fprintf ppf "layer=%a" fprint_string s + | `Url s -> fprintf ppf "URL=\"%s\"" s (*(String.escaped s)*) + | `Z f -> fprintf ppf "z=%f" f + + let fprint_port ppf = function + `N -> fprintf ppf "n" + | `NE -> fprintf ppf "ne" + | `E -> fprintf ppf "e" + | `SE -> fprintf ppf "se" + | `S -> fprintf ppf "s" + | `SW -> fprintf ppf "sw" + | `W -> fprintf ppf "w" + | `NW -> fprintf ppf "nw" + + let fprint_edge ppf = function + #CommonAttributes.edge as att -> CommonAttributes.fprint_edge ppf att + | `Arrowhead a -> fprintf ppf "arrowhead=%a" fprint_arrow_style a + | `Arrowsize f -> fprintf ppf "arrowsize=%f" f + | `Arrowtail a -> fprintf ppf "arrowtail=%a" fprint_arrow_style a + | `Comment s -> fprintf ppf "comment=%a" fprint_string s + | `Constraints b -> fprintf ppf "constraints=%b" b + | `Headlabel s -> fprintf ppf "headlabel=%a" fprint_string s + | `Headport a -> fprintf ppf "headport=%a" fprint_port a + | `Headurl s -> fprintf ppf "headURL=%a" fprint_string s + | `Labelangle f -> fprintf ppf "labelangle=%f" f + | `Labeldistance f -> fprintf ppf "labeldistance=%f" f + | `Labelfloat b -> fprintf ppf "labelfloat=%b" b + | `Layer s -> fprintf ppf "layer=%a" fprint_string s + | `Minlen i -> fprintf ppf "minlen=%i" i + | `Samehead s -> fprintf ppf "samehead=%a" fprint_string s + | `Sametail s -> fprintf ppf "sametail=%a" fprint_string s + | `Taillabel s -> fprintf ppf "taillabel=%a" fprint_string s + | `Tailport a -> fprintf ppf "tailport=%a" fprint_port a + | `Tailurl s -> fprintf ppf "tailURL=%a" fprint_string s + | `Weight i -> fprintf ppf "weight=%i" i + +end + +module Dot = + MakeEngine (struct + module Attributes = DotAttributes + let name = "dot" + let opening = "digraph" + let edge_arrow = "->" + end) + +(***************************************************************************) +(** {2 Interface with the neato engine} *) + +(** The [NeatoAttributes] module defines attributes for graphs, nodes and edges + that are available in the neato engine. *) +module NeatoAttributes = struct + + (** Attributes of graphs. They include all common graph attributes and + several specific ones. All attributes described in the "Neato User's + manual, April 10, 2002" are handled. *) + type graph = + [ CommonAttributes.graph + | `Margin of float * float + (** Sets the page margin (included in the page size). Default value is + [0.5, 0.5]. *) + | `Start of int + (** Seed for random number generator. *) + | `Overlap of bool + (** Default value is [true]. *) + | `Spline of bool + (** [true] makes edge splines if nodes don't overlap. + Default value is [false]. *) + | `Sep of float + (** Edge spline separation factor from nodes. Default value + is [0.0]. *) + ] + + (** Attributes of nodes. They include all common node attributes and + several specific ones. All attributes described in the "Neato User's + manual, April 10, 2002" are handled. *) + type vertex = + [ CommonAttributes.vertex + | `Pos of float * float + (** Initial coordinates of the node. *) + ] + + (** Attributes of edges. They include all common edge attributes and + several specific ones. All attributes described in the "Neato User's + manual, April 10, 2002" are handled. *) + type edge = + [ CommonAttributes.edge + | `Id of string + (** Optional value to distinguish multiple edges. *) + | `Len of float + (** Preferred length of edge. Default value is [1.0]. *) + | `Weight of float + (** Strength of edge spring. Default value is [1.0]. *) + ] + + type subgraph = { + sg_name : string; + sg_attributes : vertex list; + } + + (** {4 Pretty-print of attributes} *) + + let fprint_graph ppf = function + #CommonAttributes.graph as att -> CommonAttributes.fprint_graph ppf att + | `Margin (f1, f2) -> fprintf ppf "margin=\"%f,%f\"" f1 f2 + | `Start i -> fprintf ppf "start=%i" i + | `Overlap b -> fprintf ppf "overlap=%b" b + | `Spline b -> fprintf ppf "spline=%b" b + | `Sep f -> fprintf ppf "sep=%f" f + + let fprint_vertex ppf = function + #CommonAttributes.vertex as att -> + CommonAttributes.fprint_vertex ppf att + | `Pos (f1, f2) -> fprintf ppf "pos=\"%f,%f\"" f1 f2 + + let fprint_edge ppf = function + #CommonAttributes.edge as att -> CommonAttributes.fprint_edge ppf att + | `Id s -> fprintf ppf "id=%a" fprint_string s + | `Len f -> fprintf ppf "len=%f" f + | `Weight f -> fprintf ppf "weight=%f" f + +end + +module Neato = + MakeEngine (struct + module Attributes = NeatoAttributes + let name = "neato" + let opening = "graph" + let edge_arrow = "--" + end) diff --git a/external/ocamlgraph/src/graphviz.mli b/external/ocamlgraph/src/graphviz.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/graphviz.mli @@ -0,0 +1,469 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: graphviz.mli,v 1.4 2005-01-18 09:17:49 filliatr Exp $ *) + +(** Interface with {i GraphViz} + + This module provides a basic interface with dot and neato, + two programs of the GraphViz toolbox. + These tools are available at the following URLs: + + {v http://www.graphviz.org/ v} + + {v http://www.research.att.com/sw/tools/graphviz/ v} + + *) + +open Format + +(***************************************************************************) +(** {2 Common stuff} *) + +(** Because the neato and dot engines present a lot of common points - + in particular in the graph description language, large parts of + the code is shared. The [CommonAttributes] module defines + attributes of graphs, vertices and edges that are understood by the + two engines. Then module [DotAttributes] and [NeatoAttributes] + define attributes specific to dot and neato respectively. *) + +(*-------------------------------------------------------------------------*) +(** {3 Common types and signatures} *) + +type color = int + +type arrow_style = + [ `None | `Normal | `Inv | `Dot | `Odot | `Invdot | `Invodot ] + +(** The [ATTRIBUTES] module type defines the interface for the engines. *) +module type ATTRIBUTES = sig + + type graph (** Attributes of graphs. *) + + type vertex (** Attributes of vertices. *) + + type edge (** Attributes of edges. *) + + (** Attributes of (optional) boxes around vertices. *) + type subgraph = { + sg_name : string; (** Box name. *) + sg_attributes : vertex list; (** Box attributes. *) + } + +end + +(*-------------------------------------------------------------------------*) +(** {3 Common attributes} *) + +(** The [CommonAttributes] module defines attributes for graphs, vertices and + edges that are available in the two engines, dot and neato. *) +module CommonAttributes : sig + + (** Attributes of graphs. *) + type graph = + [ `Center of bool + (** Centers the drawing on the page. Default value is [false]. *) + | `Fontcolor of color + (** Sets the font color. Default value is [black]. *) + | `Fontname of string + (** Sets the font family name. Default value is ["Times-Roman"]. *) + | `Fontsize of int + (** Sets the type size (in points). Default value is [14]. *) + | `Label of string + (** Caption for graph drawing. *) + | `Orientation of [ `Portrait | `Landscape ] + (** Sets the page orientation. Default value is [`Portrait]. *) + | `Page of float * float + (** Sets the PostScript pagination unit, e.g [8.5, 11.0]. *) + | `Pagedir of [ `TopToBottom | `LeftToRight ] + (** Traversal order of pages. Default value is [`TopToBottom]. *) + | `Size of float * float + (** Sets the bounding box of drawing (in inches). *) + | `OrderingOut + (** Constrains order of out-edges in a subgraph according to + their file sequence *) + ] + + (** Attributes of vertices. + *) + type vertex = + [ `Color of color + (** Sets the color of the border of the vertex. + Default value is [black] *) + | `Fontcolor of color + (** Sets the label font color. Default value is [black]. *) + | `Fontname of string + (** Sets the label font family name. Default value is + ["Times-Roman"]. *) + | `Fontsize of int + (** Sets the label type size (in points). Default value is [14]. + *) + | `Height of float + (** Sets the minimum height. Default value is [0.5]. *) + | `Label of string + (** Sets the label printed in the vertex. + The string may include escaped + newlines [\n], [\l], or [\r] for center, left, and right justified + lines. + Record labels may contain recursive box lists delimited by { | }. + *) + | `Orientation of float + (** Vertex rotation angle, in degrees. Default value is [0.0]. *) + | `Peripheries of int + (** Sets the number of periphery lines drawn around the polygon. *) + | `Regular of bool + (** If [true], then the polygon is made regular, i.e. symmetric about + the x and y axis, otherwise the polygon takes on the aspect + ratio of the label. Default value is [false]. *) + | `Shape of + [`Ellipse | `Box | `Circle | `Doublecircle | `Diamond + | `Plaintext | `Record | `Polygon of int * float] + (** Sets the shape of the vertex. Default value is [`Ellipse]. + [`Polygon (i, f)] draws a polygon with [n] sides and a skewing + of [f]. *) + | `Style of [ `Filled | `Solid | `Dashed | `Dotted | `Bold | `Invis ] + (** Sets the layout style of the vertex. + Several styles may be combined simultaneously. *) + | `Width of float + (** Sets the minimum width. Default value is [0.75]. *) + ] + + (** Attributes of edges. + *) + type edge = + [ `Color of color + (** Sets the edge stroke color. Default value is [black]. *) + | `Decorate of bool + (** If [true], draws a line connecting labels with their edges. *) + | `Dir of [ `Forward | `Back | `Both | `None ] + (** Sets arrow direction. Default value is [`Forward]. *) + | `Fontcolor of color + (** Sets the label font color. Default value is [black]. *) + | `Fontname of string + (** Sets the label font family name. Default value is + ["Times-Roman"]. *) + | `Fontsize of int + (** Sets the label type size (in points). Default value is [14]. *) + | `Label of string + (** Sets the label to be attached to the edge. The string may include + escaped newlines [\n], [\l], or [\r] for centered, left, or right + justified lines. *) + | `Labelfontcolor of color + (** Sets the font color for head and tail labels. Default value is + [black]. *) + | `Labelfontname of string + (** Sets the font family name for head and tail labels. Default + value is ["Times-Roman"]. *) + | `Labelfontsize of int + (** Sets the font size for head and tail labels (in points). + Default value is [14]. *) + | `Style of [ `Solid | `Dashed | `Dotted | `Bold | `Invis ] + (** Sets the layout style of the edge. Several styles may be combined + simultaneously. *) + ] + +end + +(***************************************************************************) +(** {2 Interface with the dot engine} *) + +(** [DotAttributes] extends [CommonAttributes] and implements [ATTRIBUTES]. *) +module DotAttributes : sig + + (** Attributes of graphs. They include all common graph attributes and + several specific ones. All attributes described in the "dot User's + Manual, February 4, 2002" are handled, excepted: clusterank, color, + compound, labeljust, labelloc, ordering, rank, remincross, rotate, + searchsize and style. + *) + type graph = + [ CommonAttributes.graph + | `Bgcolor of color + (** Sets the background color and the inital fill color. *) + | `Comment of string + (** Comment string. *) + | `Concentrate of bool + (** If [true], enables edge concentrators. Default value is [false]. *) + | `Fontpath of string + (** List of directories for fonts. *) + | `Layers of string list + (** List of layers. *) + | `Margin of float + (** Sets the page margin (included in the page size). Default value is + [0.5]. *) + | `Mclimit of float + (** Scale factor for mincross iterations. Default value is [1.0]. *) + | `Nodesep of float + (** Sets the minimum separation between nodes, in inches. Default + value is [0.25]. *) + | `Nslimit of int + (** If set of [f], bounds network simplex iterations by [f * + ] when ranking nodes. *) + | `Nslimit1 of int + (** If set of [f], bounds network simplex iterations by [f * + ] when setting x-coordinates. *) + | `Ranksep of float + (** Sets the minimum separation between ranks. *) + | `Quantum of float + (** If not [0.0], node label dimensions will be rounded to integral + multiples of it. Default value is [0.0]. *) + | `Rankdir of [ `TopToBottom | `LeftToRight ] + (** Direction of rank ordering. Default value is [`TopToBottom]. *) + | `Ratio of [ `Float of float | `Fill | `Compress| `Auto ] + (** Sets the aspect ratio. *) + | `Samplepoints of int + (** Number of points used to represent ellipses and circles on output. + Default value is [8]. *) + | `Url of string + (** URL associated with graph (format-dependent). *) + ] + + (** Attributes of nodes. They include all common node attributes and + several specific ones. All attributes described in the "dot User's + Manual, February 4, 2002" are handled, excepted: bottomlabel, group, + shapefile and toplabel. + *) + type vertex = + [ CommonAttributes.vertex + | `Comment of string + (** Comment string. *) + | `Distortion of float + (* TEMPORARY *) + | `Fillcolor of color + (** Sets the fill color (used when `Style filled). Default value + is [lightgrey]. *) + | `Fixedsize of bool + (** If [true], forces the given dimensions to be the actual ones. + Default value is [false]. *) + | `Layer of string + (** Overlay. *) + | `Url of string + (** The default url for image map files; in PostScript files, + the base URL for all relative URLs, as recognized by Acrobat + Distiller 3.0 and up. *) + | `Z of float + (** z coordinate for VRML output. *) + ] + + (** Attributes of edges. They include all common edge attributes and + several specific ones. All attributes described in the "dot User's + Manual, February 4, 2002" are handled, excepted: lhead and ltail. + *) + type edge = + [ CommonAttributes.edge + | `Arrowhead of arrow_style + (** Sets the style of the head arrow. Default value is [`Normal]. *) + | `Arrowsize of float + (** Sets the scaling factor of arrowheads. Default value is [1.0]. *) + | `Arrowtail of arrow_style + (** Sets the style of the tail arrow. Default value is [`Normal]. *) + | `Comment of string + (** Comment string. *) + | `Constraints of bool + (** If [false], causes an edge to be ignored for rank assignment. + Default value is [true]. *) + | `Headlabel of string + (** Sets the label attached to the head arrow. *) + | `Headport of [ `N | `NE | `E | `SE | `S | `SW | `W | `NW ] + (* TEMPORARY *) + | `Headurl of string + (** Url attached to head label if output format is ismap. *) + | `Labelangle of float + (** Angle in degrees which head or tail label is rotated off edge. + Default value is [-25.0]. *) + | `Labeldistance of float + (** Scaling factor for distance of head or tail label from node. + Default value is [1.0]. *) + | `Labelfloat of bool + (** If [true], lessen constraints on edge label placement. + Default value is [false]. *) + | `Layer of string + (** Overlay. *) + | `Minlen of int + (** Minimum rank distance between head an tail. + Default value is [1]. *) + | `Samehead of string + (** Tag for head node; edge heads with the same tag are merged onto the + same port. *) + | `Sametail of string + (** Tag for tail node; edge tails with the same tag are merged onto the + same port. *) + | `Taillabel of string + (** Sets the label attached to the tail arrow. *) + | `Tailport of [ `N | `NE | `E | `SE | `S | `SW | `W | `NW ] + (* TEMPORARY *) + | `Tailurl of string + (** Url attached to tail label if output format is ismap. *) + | `Weight of int + (** Sets the integer cost of stretching the edge. Default value is + [1]. *) + ] + + type subgraph = { + sg_name : string; + sg_attributes : vertex list; + } + +end + +module Dot + (X : sig + + (** Graph implementation. *) + + type t + module V : sig type t end + module E : sig type t val src : t -> V.t val dst : t -> V.t end + + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_edges_e : (E.t -> unit) -> t -> unit + + (** Graph, vertex and edge attributes. *) + + val graph_attributes: t -> DotAttributes.graph list + + val default_vertex_attributes: t -> DotAttributes.vertex list + val vertex_name : V.t -> string + val vertex_attributes: V.t -> DotAttributes.vertex list + + val get_subgraph : V.t -> DotAttributes.subgraph option + (** The box (if exists) which the vertex belongs to. Boxes with same + names are not distinguished and so they should have the same + attributes. *) + + val default_edge_attributes: t -> DotAttributes.edge list + val edge_attributes: E.t -> DotAttributes.edge list + + end) : +sig + + (** [fprint_graph ppf graph] pretty prints the graph [graph] in + the CGL language on the formatter [ppf]. *) + val fprint_graph: formatter -> X.t -> unit + + (** [output_graph oc graph] pretty prints the graph [graph] in the dot + language on the channel [oc]. *) + val output_graph: out_channel -> X.t -> unit + +end + +(***************************************************************************) +(** {2 The neato engine} *) + +module NeatoAttributes : sig + + (** Attributes of graphs. They include all common graph attributes and + several specific ones. All attributes described in the "Neato User's + manual, April 10, 2002" are handled. + *) + type graph = + [ CommonAttributes.graph + | `Margin of float * float + (** Sets the page margin (included in the page size). Default value is + [0.5, 0.5]. *) + | `Start of int + (** Seed for random number generator. *) + | `Overlap of bool + (** Default value is [true]. *) + | `Spline of bool + (** [true] makes edge splines if nodes don't overlap. + Default value is [false]. *) + | `Sep of float + (** Edge spline separation factor from nodes. Default value + is [0.0]. *) + ] + + (** Attributes of nodes. They include all common node attributes and + several specific ones. All attributes described in the "Neato User's + manual, April 10, 2002" are handled. + *) + type vertex = + [ CommonAttributes.vertex + | `Pos of float * float + (** Initial coordinates of the vertex. *) + ] + + (** Attributes of edges. They include all common edge attributes and + several specific ones. All attributes described in the "Neato User's + manual, April 10, 2002" are handled. + *) + type edge = + [ CommonAttributes.edge + | `Id of string + (** Optional value to distinguish multiple edges. *) + | `Len of float + (** Preferred length of edge. Default value is [1.0]. *) + | `Weight of float + (** Strength of edge spring. Default value is [1.0]. *) + ] + + type subgraph = { + sg_name : string; + sg_attributes : vertex list; + } + +end + +module Neato + (X : sig + + (** Graph implementation. *) + + type t + module V : sig type t end + module E : sig type t val src : t -> V.t val dst : t -> V.t end + + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_edges_e : (E.t -> unit) -> t -> unit + + (** Graph, vertex and edge attributes. *) + + val graph_attributes: t -> NeatoAttributes.graph list + + val default_vertex_attributes: t -> NeatoAttributes.vertex list + val vertex_name : V.t -> string + val vertex_attributes: V.t -> NeatoAttributes.vertex list + + val get_subgraph : V.t -> NeatoAttributes.subgraph option + (** The box (if exists) which the vertex belongs to. Boxes with same + names are not distinguished and so they should have the same + attributes. *) + + val default_edge_attributes: t -> NeatoAttributes.edge list + val edge_attributes: E.t -> NeatoAttributes.edge list + + end) : +sig + + (** Several functions provided by this module run the external program + {i neato}. By default, this command is supposed to be in the default + path and is invoked by {i neato}. The function + [set_command] allows to set an alternative path at run time. *) + val set_command: string -> unit + + exception Error of string + val handle_error: ('a -> 'b) -> 'a -> 'b + + (** [fprint_graph ppf graph] pretty prints the graph [graph] in + the CGL language on the formatter [ppf]. *) + val fprint_graph: formatter -> X.t -> unit + + (** [output_graph oc graph] pretty prints the graph [graph] in the dot + language on the channel [oc]. *) + val output_graph: out_channel -> X.t -> unit + +end diff --git a/external/ocamlgraph/src/imperative.ml b/external/ocamlgraph/src/imperative.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/imperative.ml @@ -0,0 +1,618 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: imperative.ml,v 1.27 2006-05-12 14:07:16 filliatr Exp $ *) + +open Sig +open Blocks + +module type S = sig + + (** Imperative Unlabeled Graphs *) + module Concrete (V: COMPARABLE) : + Sig.I with type V.t = V.t and type V.label = V.t and type E.t = V.t * V.t + + (** Abstract Imperative Unlabeled Graphs *) + module Abstract(V: sig type t end) : + Sig.IM with type V.label = V.t and type E.label = unit + + (** Imperative Labeled Graphs *) + module ConcreteLabeled (V: COMPARABLE)(E: ORDERED_TYPE_DFT) : + Sig.I with type V.t = V.t and type V.label = V.t + and type E.t = V.t * E.t * V.t and type E.label = E.t + + (** Abstract Imperative Labeled Graphs *) + module AbstractLabeled (V: sig type t end)(E: ORDERED_TYPE_DFT) : + Sig.IM with type V.label = V.t and type E.label = E.t + +end + +module I = Make(Make_Hashtbl) + +type 'a abstract_vertex = { tag : int; label : 'a; mutable mark : int } + +(* Implement the module [Mark]. *) +module Make_Mark + (X: sig + type graph + type label + val iter_vertex : (label abstract_vertex -> unit) -> graph -> unit + end) = +struct + type vertex = X.label abstract_vertex + type graph = X.graph + let get v = v.mark + let set v m = v.mark <- m + let clear g = X.iter_vertex (fun v -> set v 0) g +end + +(* Vertex for the abstract imperative graphs. *) +module AbstractVertex(V: sig type t end) = struct + + type label = V.t + type t = label abstract_vertex + + let compare x y = compare x.tag y.tag + let hash x = Hashtbl.hash x.tag + let equal x y = x.tag = y.tag + let label x = x.label + + let create l = + assert (!cpt_vertex < max_int); + incr cpt_vertex; + { tag = !cpt_vertex; label = l; mark = 0 } + +end + +module Digraph = struct + + module Concrete (V: COMPARABLE) = struct + + include I.Digraph.Concrete(V) + + let create ?(size=997) () = create size + + let add_vertex g v = ignore (add_vertex g v) + let remove_vertex g v = ignore (remove_vertex g v) + let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) + let remove_edge_e g e = ignore (remove_edge_e g e) + + let add_edge g v1 v2 = + add_vertex g v1; + add_vertex g v2; + ignore (unsafe_add_edge g v1 v2) + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let copy = HM.copy + + end + + module ConcreteBidirectional (V: COMPARABLE) = struct + + include I.Digraph.ConcreteBidirectional(V) + + let create ?(size=997) () = create size + + let add_vertex g v = + if not (HM.mem v g) then ignore (unsafe_add_vertex g v) + + let add_edge g v1 v2 = + add_vertex g v1; + add_vertex g v2; + ignore (unsafe_add_edge g v1 v2) + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_vertex g v = + if HM.mem v g then begin + iter_pred_e (fun e -> ignore (remove_edge_e g e)) g v; + iter_succ_e (fun e -> ignore (remove_edge_e g e)) g v; + ignore (HM.remove v g) + end + + let copy = HM.copy + + let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) + let remove_edge_e g e = ignore (remove_edge_e g e) + + end + + module ConcreteLabeled(V: COMPARABLE)(E: ORDERED_TYPE_DFT) = struct + + let default = E.default + + include I.Digraph.ConcreteLabeled(V)(E) + + let create ?(size=997) () = create size + + let add_vertex g v = ignore (add_vertex g v) + let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) + let remove_edge_e g e = ignore (remove_edge_e g e) + + let add_edge_e g (v1, l, v2) = + add_vertex g v1; + add_vertex g v2; + ignore (unsafe_add_edge g v1 (v2, l)) + + let add_edge g v1 v2 = add_edge_e g (v1, default, v2) + + let remove_vertex g v = + if HM.mem v g then + let remove s = + S.fold + (fun (v2, _ as e) s -> if not (V.equal v v2) then S.add e s else s) + s S.empty + in + ignore (HM.remove v g); + HM.iter (fun k s -> ignore (HM.add k (remove s) g)) g + + let copy = HM.copy + + end + + module Abstract(V: sig type t end) = struct + + include I.Digraph.Abstract(AbstractVertex(V)) + + let create ?(size=997) () = { edges = G.create size; size = 0 } + + let add_vertex g v = + if not (HM.mem v g.edges) then begin + g.size <- Pervasives.succ g.size; + ignore (G.unsafe_add_vertex g.edges v) + end + + let add_edge g v1 v2 = + add_vertex g v1; + add_vertex g v2; + ignore (unsafe_add_edge g.edges v1 v2) + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_vertex g v = + if HM.mem v g.edges then + let e = g.edges in + ignore (HM.remove v e); + HM.iter (fun k s -> ignore (HM.add k (S.remove v s) e)) e; + g.size <- Pervasives.pred g.size + + module Mark = Make_Mark(struct + type graph = t + type label = V.label + let iter_vertex = iter_vertex + end) + + let copy g = + let h = HM.create 997 in + let vertex v = + try + HM.find v h + with Not_found -> + let v' = V.create (V.label v) in + ignore (HM.add v v' h); + v' + in + map_vertex vertex g + + let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) + let remove_edge_e g e = ignore (remove_edge_e g e) + + end + + module AbstractLabeled(V: sig type t end)(Edge: ORDERED_TYPE_DFT) = struct + + include I.Digraph.AbstractLabeled(AbstractVertex(V))(Edge) + + let create ?(size=997) () = { edges = G.create size; size = 0 } + + let add_vertex g v = + if not (HM.mem v g.edges) then begin + g.size <- Pervasives.succ g.size; + ignore (G.unsafe_add_vertex g.edges v) + end + + let add_edge_e g (v1, l, v2) = + add_vertex g v1; + add_vertex g v2; + ignore (unsafe_add_edge g.edges v1 (v2, l)) + + let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) + + let remove_vertex g v = + if HM.mem v g.edges then + let remove s = + S.fold + (fun (v2, _ as e) s -> if not (V.equal v v2) then S.add e s else s) + s S.empty + in + let e = g.edges in + ignore (HM.remove v e); + HM.iter (fun k s -> ignore (HM.add k (remove s) e)) e; + g.size <- Pervasives.pred g.size + + module Mark = Make_Mark(struct + type graph = t + type label = V.label + let iter_vertex = iter_vertex + end) + + let copy g = + let h = HM.create 997 in + let vertex v = + try + HM.find v h + with Not_found -> + let v' = V.create (V.label v) in + ignore (HM.add v v' h); + v' + in + map_vertex vertex g + + let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) + let remove_edge_e g e = ignore (remove_edge_e g e) + + end + +end + +module Graph = struct + + module Concrete(V: COMPARABLE) = struct + + module G = Digraph.Concrete(V) + + include Graph(G) + + (* Export some definitions of [G] *) + + let create = G.create + let copy = G.copy + let add_vertex = G.add_vertex + let remove_vertex = G.remove_vertex + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge g v1 v2 = + G.add_edge g v1 v2; + assert (G.HM.mem v1 g && G.HM.mem v2 g); + ignore (G.unsafe_add_edge g v2 v1) + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_edge g v1 v2 = + G.remove_edge g v1 v2; + assert (G.HM.mem v1 g && G.HM.mem v2 g); + ignore (G.unsafe_remove_edge g v2 v1) + + let remove_edge_e g (v1, v2) = remove_edge g v1 v2 + + end + + module ConcreteLabeled (V: COMPARABLE)(E: ORDERED_TYPE_DFT) = struct + + module G = Digraph.ConcreteLabeled(V)(E) + + include Graph(G) + + (* Export some definitions of [G] *) + + let create = G.create + let copy = G.copy + let add_vertex = G.add_vertex + let remove_vertex = G.remove_vertex + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge_e g (v1, l, v2 as e) = + G.add_edge_e g e; + assert (G.HM.mem v1 g && G.HM.mem v2 g); + ignore (G.unsafe_add_edge g v2 (v1, l)) + + let add_edge g v1 v2 = add_edge_e g (v1, G.default, v2) + + let remove_edge g v1 v2 = + G.remove_edge g v1 v2; + assert (G.HM.mem v1 g && G.HM.mem v2 g); + ignore (G.unsafe_remove_edge g v2 v1) + + let remove_edge_e g (v1, l, v2 as e) = + G.remove_edge_e g e; + assert (G.HM.mem v1 g && G.HM.mem v2 g); + ignore (G.unsafe_remove_edge_e g (v2, l, v1)) + + end + + module Abstract(V: sig type t end) = struct + + module G = Digraph.Abstract(V) + + include Graph(G) + + (* Export some definitions of [G] *) + + module Mark = G.Mark + let create = G.create + let copy = G.copy + let add_vertex = G.add_vertex + let remove_vertex = G.remove_vertex + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge g v1 v2 = + G.add_edge g v1 v2; + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + ignore (G.unsafe_add_edge g.G.edges v2 v1) + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_edge g v1 v2 = + G.remove_edge g v1 v2; + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + ignore (G.unsafe_remove_edge g.G.edges v2 v1) + + let remove_edge_e g (v1, v2) = remove_edge g v1 v2 + + end + + module AbstractLabeled (V: sig type t end)(Edge: ORDERED_TYPE_DFT) = struct + + module G = Digraph.AbstractLabeled(V)(Edge) + + include Graph(G) + + (* Export some definitions of [G] *) + + module Mark = G.Mark + let create = G.create + let copy = G.copy + let add_vertex = G.add_vertex + let remove_vertex = G.remove_vertex + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge_e g (v1, l, v2 as e) = + G.add_edge_e g e; + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + ignore (G.unsafe_add_edge g.G.edges v2 (v1, l)) + + let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) + + let remove_edge g v1 v2 = + G.remove_edge g v1 v2; + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + ignore (G.unsafe_remove_edge g.G.edges v2 v1) + + let remove_edge_e g (v1, l, v2 as e) = + ignore (G.remove_edge_e g e); + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + ignore (G.unsafe_remove_edge_e g.G.edges (v2, l, v1)) + + end + +end + +module Matrix = struct + + module type S = sig + include Sig.I with type V.t = int and type V.label = int + and type E.t = int * int + val make : int -> t + end + + module Digraph = struct + + module V = struct + type t = int + type label = int + let compare = Pervasives.compare + let hash = Hashtbl.hash + let equal = (==) + let create i = i + let label i = i + end + + module E = struct + type t = V.t * V.t + type vertex = V.t + let compare = Pervasives.compare + type label = unit + let create v1 _ v2 = (v1, v2) + let src = fst + let dst = snd + let label _ = () + end + + type t = Bitv.t array + type vertex = V.t + type edge = E.t + + let create ?size () = + failwith "do not use Matrix.create; please use Matrix.make instead" + + let make n = + if n < 0 then invalid_arg "Matrix.make"; + Array.init n (fun _ -> Bitv.create n false) + + let is_directed = true + + let nb_vertex = Array.length + let is_empty g = nb_vertex g = 0 + let nb_edges = + Array.fold_left (Bitv.fold_left (fun n b -> if b then n+1 else n)) 0 + + let mem_vertex g v = 0 <= v && v < nb_vertex g + let mem_edge g i j = Bitv.get g.(i) j + let mem_edge_e g (i,j) = Bitv.get g.(i) j + let find_edge g i j = if mem_edge g i j then i, j else raise Not_found + + (* constructors *) + let add_edge g i j = Bitv.set g.(i) j true + let add_edge_e g (i,j) = Bitv.set g.(i) j true + + let remove_edge g i j = Bitv.set g.(i) j false + let remove_edge_e g (i,j) = Bitv.set g.(i) j false + + let unsafe_add_edge g i j = + Bitv.unsafe_set (Array.unsafe_get g i) j true + let unsafe_remove_edge g i j = + Bitv.unsafe_set (Array.unsafe_get g i) j false + + let remove_vertex g _ = () + let add_vertex g _ = () + + let copy g = Array.init (nb_vertex g) (fun i -> Bitv.copy g.(i)) + + (* iter/fold on all vertices/edges of a graph *) + let iter_vertex f g = + for i = 0 to nb_vertex g - 1 do f i done + + let iter_edges f g = + for i = 0 to nb_vertex g - 1 do + Bitv.iteri (fun j b -> if b then f i j) g.(i) + done + + let fold_vertex f g a = + let n = nb_vertex g in + let rec fold i a = if i = n then a else fold (i+1) (f i a) in fold 0 a + + let fold_edges f g a = + fold_vertex + (fun i a -> + Bitv.foldi_right (fun j b a -> if b then f i j a else a) g.(i) a) + g a + + (* successors and predecessors of a vertex *) + let succ g i = + Bitv.foldi_left (fun l j b -> if b then j::l else l) [] g.(i) + + let pred g i = + fold_vertex + (fun j a -> if Bitv.unsafe_get g.(j) i then j :: a else a) + g [] + + (* iter/fold on all successor/predecessor of a vertex. *) + let iter_succ f g i = + let si = g.(i) in + for j = 0 to nb_vertex g - 1 do if Bitv.unsafe_get si j then f j done + (* optimization w.r.t. + [Bitv.iteri (fun j b -> if b then f j) g.(i)] + *) + + let iter_pred f g i = + for j = 0 to nb_vertex g - 1 do if Bitv.unsafe_get g.(j) i then f j done + + let fold_succ f g i a = + Bitv.foldi_right (fun j b a -> if b then f j a else a) g.(i) a + + let fold_pred f g i a = + fold_vertex + (fun j a -> if Bitv.unsafe_get g.(j) i then f j a else a) + g a + + (* degree *) + let out_degree g i = fold_succ (fun _ n -> n + 1) g i 0 + + let in_degree g i = fold_pred (fun _ n -> n + 1) g i 0 + + (* map iterator on vertex *) + let map_vertex f g = + let n = nb_vertex g in + let g' = make n in + iter_edges + (fun i j -> + let fi = f i in + let fj = f j in + if fi < 0 || fi >= n || fj < 0 || fj >= n then + invalid_arg "map_vertex"; + Bitv.unsafe_set g'.(fi) fj true) + g; + g' + + (* labeled edges going from/to a vertex *) + (* successors and predecessors of a vertex *) + let succ_e g i = + Bitv.foldi_left (fun l j b -> if b then (i,j)::l else l) [] g.(i) + + let pred_e g i = + fold_vertex + (fun j a -> if Bitv.unsafe_get g.(j) i then (j,i) :: a else a) + g [] + + (* iter/fold on all labeled edges of a graph *) + let iter_edges_e f g = + for i = 0 to nb_vertex g - 1 do + Bitv.iteri (fun j b -> if b then f (i,j)) g.(i) + done + + let fold_edges_e f g a = + fold_vertex + (fun i a -> + Bitv.foldi_right (fun j b a -> if b then f (i,j) a else a) g.(i) a) + g a + + (* iter/fold on all edges going from/to a vertex *) + let iter_succ_e f g i = + let si = g.(i) in + for j = 0 to nb_vertex g - 1 do if Bitv.unsafe_get si j then f (i,j) done + + let iter_pred_e f g i = + for j = 0 to nb_vertex g - 1 do + if Bitv.unsafe_get g.(j) i then f (j,i) + done + + let fold_succ_e f g i a = + Bitv.foldi_right (fun j b a -> if b then f (i,j) a else a) g.(i) a + + let fold_pred_e f g i a = + fold_vertex + (fun j a -> if Bitv.unsafe_get g.(j) i then f (j,i) a else a) + g a + + end + + module Graph = struct + + module G = Digraph + + include Blocks.Graph(G) + (* Export some definitions of [G] *) + + let create = G.create + let make = G.make + let copy = G.copy + let add_vertex = G.add_vertex + let remove_vertex = G.remove_vertex + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge g v1 v2 = + G.add_edge g v1 v2; + ignore (G.unsafe_add_edge g v2 v1) + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_edge g v1 v2 = + G.remove_edge g v1 v2; + ignore (G.unsafe_remove_edge g v2 v1) + + let remove_edge_e g (v1, v2) = remove_edge g v1 v2 + + end + +end + diff --git a/external/ocamlgraph/src/imperative.mli b/external/ocamlgraph/src/imperative.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/imperative.mli @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: imperative.mli,v 1.18 2006-05-12 14:07:16 filliatr Exp $ *) + +(** Imperative Implementations *) + +open Sig + +(** Signature of imperative graphs *) +module type S = sig + + (** Imperative Unlabeled Graphs *) + module Concrete (V: COMPARABLE) : + Sig.I with type V.t = V.t and type V.label = V.t and type E.t = V.t * V.t + + (** Abstract Imperative Unlabeled Graphs *) + module Abstract(V: ANY_TYPE) : + Sig.IM with type V.label = V.t and type E.label = unit + + (** Imperative Labeled Graphs *) + module ConcreteLabeled (V: COMPARABLE)(E: ORDERED_TYPE_DFT) : + Sig.I with type V.t = V.t and type V.label = V.t + and type E.t = V.t * E.t * V.t and type E.label = E.t + + (** Abstract Imperative Labeled Graphs *) + module AbstractLabeled (V: ANY_TYPE)(E: ORDERED_TYPE_DFT) : + Sig.IM with type V.label = V.t and type E.label = E.t + +end + +(** Imperative Directed Graphs *) + +module Digraph : sig + include S + + (** Imperative Unlabeled, bidirectional graph (gives predecessors in + constant time) *) + module ConcreteBidirectional (V: COMPARABLE) : + Sig.I with type V.t = V.t and type V.label = V.t and type E.t = V.t * V.t +end + +(** Imperative Undirected Graphs *) +module Graph : S + +(** Imperative graphs implemented as adjacency matrices *) +module Matrix : sig + + module type S = sig + + (** Vertices are integers in [0..n-1]. + A vertex label is the vertex itself. + Edges are unlabeled. *) + + include Sig.I with type V.t = int and type V.label = int + and type E.t = int * int + + (** Creation. graphs are not resizeable: size is given at creation time. + Thus [make] must be used instead of [create] *) + val make : int -> t + + (** Note: [add_vertex] and [remove_vertex] have no effect *) + + end + + module Digraph : S + (** Imperative Directed Graphs implemented with adjacency matrices *) + + module Graph : S + (** Imperative Undirected Graphs implemented with adjacency matrices *) + +end + diff --git a/external/ocamlgraph/src/kruskal.ml b/external/ocamlgraph/src/kruskal.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/kruskal.ml @@ -0,0 +1,74 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: kruskal.ml,v 1.5 2005-06-30 10:48:55 filliatr Exp $ *) + +open Util + +module type UNIONFIND = sig + type elt + type t + + val init : elt list -> t + val find : elt -> t -> elt + val union : elt -> elt -> t -> unit +end + +module type G = sig + type t + module V : Sig.COMPARABLE + module E : sig + type t + type label + val label : t -> label + val dst : t -> V.t + val src : t -> V.t + end + val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a + val iter_edges_e : (E.t -> unit) -> t -> unit +end + +module Generic + (G: G) + (W : Sig.ORDERED_TYPE with type t=G.E.label) + (UF: UNIONFIND with type elt=G.V.t) = +struct + + let spanningtree g = + let vertices = G.fold_vertex (fun v a -> v :: a) g [] in + let uf = UF.init vertices in + let edges = + let l = ref [] in + G.iter_edges_e (fun e -> l:=e::!l) g; + List.sort (fun e e'-> W.compare (G.E.label e) (G.E.label e')) !l + in + let s = ref [] in + let cover e = + let u,v = G.E.src e , G.E.dst e in + if G.V.compare (UF.find u uf) (UF.find v uf) <> 0 then + (UF.union u v uf; s:=e::!s) + in + List.iter cover edges;!s + +end + +module Make + (G: G) + (W : Sig.ORDERED_TYPE with type t=G.E.label) + = + Generic(G)(W)(Unionfind.Make(G.V)) + diff --git a/external/ocamlgraph/src/kruskal.mli b/external/ocamlgraph/src/kruskal.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/kruskal.mli @@ -0,0 +1,65 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: kruskal.mli,v 1.5 2005-06-30 10:48:55 filliatr Exp $ *) + +(** Kruskal's algorithm *) + +(** Minimal graph signature for Kruskal *) +module type G = sig + type t + module V : Sig.COMPARABLE + module E : sig + type t + type label + val label : t -> label + val dst : t -> V.t + val src : t -> V.t + end + val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a + val iter_edges_e : (E.t -> unit) -> t -> unit +end + +module Make + (G: G) + (W: Sig.ORDERED_TYPE with type t = G.E.label) : +sig + + val spanningtree : G.t -> G.E.t list + +end + +(** Generic version where union-find implementation is provided *) + +module type UNIONFIND = sig + type elt + type t + + val init : elt list -> t + val find : elt -> t -> elt + val union : elt -> elt -> t -> unit +end + +module Generic + (G: G) + (W: Sig.ORDERED_TYPE with type t=G.E.label) + (UF: UNIONFIND with type elt=G.V.t) : +sig + + val spanningtree : G.t -> G.E.t list + +end diff --git a/external/ocamlgraph/src/mcs_m.ml b/external/ocamlgraph/src/mcs_m.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/mcs_m.ml @@ -0,0 +1,203 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(** + Maximal Cardinality Search (MCS-M). + + Based on the article: + Maximal Cardinality Search for Computing Minimal Triangulations of Graphs. + by A. Berry, Jean R. S. Blair, Pinar Heggernes & Barry W. Peyton. + + @author Matthieu Sozeau + @author Pierre-Loic Garoche + + $Id: mcs_m.ml,v 1.5 2005-11-02 13:43:35 filliatr Exp $ +*) + +module MaximalCardinalitySearch = struct + + module WeightedV(V : Sig.COMPARABLE) = struct + include Util.DataV(struct type t = int end)(V) + let weight = data + let set_weight = set_data + end + + module P(Gr : Sig.P) = struct + type edgelist = (Gr.V.t * Gr.V.t) list + + module NewV = WeightedV(Gr.V) + module G = Persistent.Graph.Concrete(NewV) + module EdgeSet = Set.Make(G.E) + module VerticesSet = Set.Make(NewV) + module Choose = Oper.Choose(G) + module H = Hashtbl.Make(NewV) + + exception Found + + let check_path g u v = + let h = H.create 97 in + let maxw = NewV.weight u in + let rec aux x : bool = + if H.mem h x then + false + else + if x = v then true + else + if NewV.weight x < maxw || x = u then + begin + H.add h x (); + G.fold_succ + (fun x found -> + if not found then aux x + else found) + g x false + end + else (H.add h x (); false) + in aux u + + module Copy = Gmap.Vertex(Gr)(struct include G include Builder.P(G) end) + + let fold f d = + let rec aux = function + (true, a) -> aux (f a) + | (false, a) -> a + in aux d + + let mcsm g = + let g' = Copy.map (NewV.create 0) g in + let (_, _, ord, triang) = + fold + (fun ((i, g', a, f) as x)-> + if i = 0 then (false, x) + else + let v = + G.fold_vertex + (fun x max -> + if NewV.weight x > NewV.weight max then x else max) + g' (ref 0, snd (Choose.choose_vertex g')) + in + let s = + G.fold_vertex + (fun x s -> + if x = v then s + else + if check_path g' x v then + VerticesSet.add x s + else s) + g' VerticesSet.empty + in + let f' = + VerticesSet.fold + (fun x f -> + NewV.set_weight x (succ (NewV.weight x)); + if not (G.mem_edge g' x v) then + EdgeSet.add (x,v) f + else f) + s f + in + let g' = G.remove_vertex g' v in + let a' = (i, NewV.label v) :: a in + (true, (i - 1, g', a', f'))) + (true, (Gr.nb_vertex g, g', [], EdgeSet.empty)) + in + (List.rev ord, + EdgeSet.fold + (fun (x, y) e -> (NewV.label x, NewV.label y) :: e) + triang []) + + let triangulate g = + let (_, triang) = mcsm g in + List.fold_left (fun g (x, y) -> Gr.add_edge g x y) g triang + end + + module I(Gr : Sig.I) = struct + type edgelist = (Gr.V.t * Gr.V.t) list + + module NewV = WeightedV(Gr.V) + module G = Imperative.Graph.Concrete(NewV) + module EdgeSet = Set.Make(G.E) + module VerticesSet = Set.Make(NewV) + module Choose = Oper.Choose(G) + module H = Hashtbl.Make(NewV) + + exception Found + + let check_path g u v = + let h = H.create 97 in + let maxw = NewV.weight u in + let rec aux x : bool = + if H.mem h x then + false + else + if x = v then true + else + if NewV.weight x < maxw || x = u then begin + H.add h x (); + G.fold_succ + (fun x found -> + if not found then aux x + else found) + g x false + end else (H.add h x (); false) + in aux u + + module Copy = Gmap.Vertex(Gr)(struct include G include Builder.I(G) end) + + let mcsm g = + let f = ref EdgeSet.empty + and a = ref [] + and g' = Copy.map (NewV.create 0) g in + for i = Gr.nb_vertex g downto 1 do + let v = + G.fold_vertex + (fun x max -> + if NewV.weight x > NewV.weight max then x else max) + g' (ref 0, snd (Choose.choose_vertex g')) + in + let s = + G.fold_vertex + (fun x s -> + if x = v then s + else + if check_path g' x v then + VerticesSet.add x s + else s) + g' VerticesSet.empty + in + let f' = + VerticesSet.fold + (fun x f -> + NewV.set_weight x (succ (NewV.weight x)); + if not (G.mem_edge g' x v) then + EdgeSet.add (x,v) f + else f) + s !f + in + f := f'; + G.remove_vertex g' v; + a := (i, NewV.label v) :: !a; + done; + (List.rev !a, + EdgeSet.fold + (fun (x, y) e -> (NewV.label x, NewV.label y) :: e) + !f []) + + let triangulate g = + let (_, triang) = mcsm g in + List.iter (fun (x, y) -> Gr.add_edge g x y) triang + end +end diff --git a/external/ocamlgraph/src/mcs_m.mli b/external/ocamlgraph/src/mcs_m.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/mcs_m.mli @@ -0,0 +1,53 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(** + Maximal Cardinality Search (MCS-M) algorithm + + Based on the article: + Maximal Cardinality Search for Computing Minimal Triangulations of Graphs. + by A. Berry, Jean R. S. Blair, Pinar Heggernes & Barry W. Peyton. + + @author Matthieu Sozeau + @author Pierre-Loic Garoche + + $Id: mcs_m.mli,v 1.2 2004-10-19 15:21:44 signoles Exp $ +*) + +module MaximalCardinalitySearch : sig + module P(G : Sig.P) : sig + type edgelist = (G.V.t * G.V.t) list + + (** [mcsm g] returns a tuple [(o, e)] where [o] is a perfect elimination + order of [g'] where [g'] is the triangulation [e] applied to [g]. *) + val mcsm : G.t -> (int * G.V.t) list * edgelist + + (** [triangulate g] computes a triangulation of [g] + using the MCS-M algorithm *) + val triangulate : G.t -> G.t + end + module I(Gr : Sig.I) : sig + type edgelist = (Gr.V.t * Gr.V.t) list + + (** [mcsm g] return a tuple [(o, e)] where o is a perfect elimination order + of [g'] where [g'] is the triangulation [e] applied to [g]. *) + val mcsm : Gr.t -> (int * Gr.V.t) list * edgelist + + (** [triangulate g] triangulates [g] using the MCS-M algorithm *) + val triangulate : Gr.t -> unit + end +end diff --git a/external/ocamlgraph/src/md.ml b/external/ocamlgraph/src/md.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/md.ml @@ -0,0 +1,163 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: md.ml,v 1.6 2004-10-22 14:42:06 signoles Exp $ *) + +(** Minimum Degree. + + Based on the article: + The Minimum Degree Heuristic and the Minimal Triangulation Process + by A. Berry, Pinar Heggernes & Geneviève Simonet. + + @author Matthieu Sozeau + @author Pierre-Loic Garoche *) + +module P(G : Sig.P) = struct + + module VertexSet = Set.Make(G.V) + module CT = Cliquetree.CliqueTree(G) + + module Choose = Oper.Choose(G) +(* module NG = Neighborhood.Graph(G)*) + + type edgeset = (G.V.t * G.V.t) list + + let md g = + let gref = ref g in + let gtri = ref g in + let n = G.nb_vertex g in + let tri = ref [] in + let ord = ref [] in + let i = ref 0 in + while not (CT.is_chordal !gtri) && !i < n do + let v = + let x = + G.fold_vertex + (fun v' x -> + let deg' = G.out_degree !gref v' in + match x with + Some (v,deg) when deg' > deg -> x + | _ -> Some (v', deg')) + !gref None + in match x with + Some (v,_) -> v + | None -> failwith "Expecting some vertex" + in + let ng = G.succ !gref v in + let g', tri' = + List.fold_left + (fun (g, tri) v -> + let tri' = + List.fold_left + (fun tri v' -> + if v <> v' && not (G.mem_edge g v v') then + (v, v') :: tri + else tri) + tri ng + in + let g' = + List.fold_left + (fun g v' -> + if v <> v' then + G.add_edge g v v' + else g) + g ng + in + (g', tri')) + (!gref, []) ng + in + ord := v :: !ord; + gtri := List.fold_left + (fun g (x,y) -> G.add_edge g x y) + !gtri tri'; + gref := G.remove_vertex g' v; + tri := tri' @ !tri; + incr i; + done; + (!gtri, !tri, !ord) + + let triangulate g = + let gtri, _, _ = md g in + gtri + +end + +module I(G : Sig.I) = struct + + module VertexSet = Set.Make(G.V) + module CT = Cliquetree.CliqueTree(G) + + module Choose = Oper.Choose(G) +(* module NG = Neighborhood.Graph(G)*) + + type edgeset = (G.V.t * G.V.t) list + + module Copy = Gmap.Vertex(G)(struct include G include Builder.I(G) end) + + let md g = + let gtri = Copy.map (fun x -> x) g in + let gcur = Copy.map (fun x -> x) g in + let n = G.nb_vertex g in + let tri = ref [] in + let ord = ref [] in + let i = ref 0 in + while not (CT.is_chordal gtri) && !i < n do + let v = + let x = + G.fold_vertex + (fun v' x -> + let deg' = G.out_degree gcur v' in + match x with + Some (v,deg) when deg' > deg -> x + | _ -> Some (v', deg')) + gcur None + in match x with + Some (v,_) -> v + | None -> failwith "Expecting some vertex" + in + let ng = G.succ gcur v in + let tri' = + List.fold_left + (fun tri v -> + List.fold_left + (fun tri v' -> + let tri' = + if v <> v' && not (G.mem_edge g v v') then + (v, v') :: tri + else + tri + in + List.iter (fun v' -> if v <> v' then G.add_edge gcur v v') ng; + tri') + tri ng) + [] ng + in + ord := v :: !ord; + List.iter + (fun (x,y) -> G.add_edge gtri x y) + tri'; + G.remove_vertex gcur v; + tri := tri' @ !tri; + incr i; + done; + (gtri, !tri, !ord) + + let triangulate g = + let gtri, _, _ = md g in + gtri + +end diff --git a/external/ocamlgraph/src/md.mli b/external/ocamlgraph/src/md.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/md.mli @@ -0,0 +1,57 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: md.mli,v 1.2 2004-06-28 13:48:25 signoles Exp $ *) + +(** Minimum Degree algorithm + + Based on the article: + The Minimum Degree Heuristic and the Minimal Triangulation Process + by A. Berry, Pinar Heggernes & Geneviève Simonet. + + @author Matthieu Sozeau + @author Pierre-Loic Garoche *) + +module P(G : Sig.P) : sig + + type edgeset = (G.V.t * G.V.t) list + + val md : G.t -> G.t * edgeset * G.V.t list + (** [md g] return a tuple [(g', e, o)] where [g'] is + a triangulated graph, [e] is the triangulation of [g] and + [o] is a perfect elimination order of [g'] *) + + val triangulate : G.t -> G.t + (** [triangulate g] return the graph [g'] produced by applying + miminum degree to [g]. *) + +end + +module I(G : Sig.I) : sig + + type edgeset = (G.V.t * G.V.t) list + + val md : G.t -> G.t * edgeset * G.V.t list + (** [md g] return a tuple [(g', e, o)] where [g'] is + a triangulated graph, [e] is the triangulation of [g] and + [o] is a perfect elimination order of [g'] *) + + val triangulate : G.t -> G.t + (** [triangulate g] return the graph [g'] produced by applying + miminum degree to [g]. *) + +end diff --git a/external/ocamlgraph/src/minsep.ml b/external/ocamlgraph/src/minsep.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/minsep.ml @@ -0,0 +1,131 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(*i $Id: minsep.ml,v 1.7 2004-10-25 15:46:16 signoles Exp $ i*) + +module type G = sig + type t + module V : Sig.COMPARABLE + val succ: t -> V.t -> V.t list + val iter_succ: (V.t -> unit) -> t -> V.t -> unit + val fold_succ: (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a + val iter_vertex: (V.t -> unit) -> t -> unit + val fold_vertex: (V.t -> 'a -> 'a) -> t -> 'a -> 'a +end + +module type MINSEP = sig + module G : G + module Vertex_Set : Set.S with type elt = G.V.t + module VSetset : Set.S with type elt = Vertex_Set.t + val allminsep : G.t -> Vertex_Set.t list + val list_of_allminsep : G.t -> G.V.t list list + val set_of_allminsep : G.t -> VSetset.t +end + +module Make + (G : sig + include G + val cc: t -> V.t list -> V.t list list + (** compute the set of connected components of G(V \ l) *) + end) = +struct + + module N = Oper.Neighbourhood(G) + module Vertex_Set = N.Vertex_Set + module VSetset = Set.Make(Vertex_Set) + + let initialisation g = + let cc = G.cc g in + let neighbourhood = N.list_from_vertex g in + let neighbourhoods = N.set_from_vertices g in + G.fold_vertex + (fun v s -> + List.fold_left + (fun s l -> neighbourhoods l :: s) + s (cc (v :: neighbourhood v))) + g [] + + let generation g = + let neighbourhood = N.list_from_vertex g in + let neighbourhoods = N.set_from_vertices g in + let cc = G.cc g in + let rec gen_aux seen bigs = function + | [] -> bigs + | s :: tl -> + let l = Vertex_Set.elements s in + let seen = VSetset.add s seen in + let bigs, tl = + Vertex_Set.fold + (fun v c -> + let add_neighbourhoods (bigs, tl) l = + let s = neighbourhoods l in + s :: bigs, if VSetset.mem s seen then tl else s :: tl + in + List.fold_left + add_neighbourhoods + (bigs, tl) (cc (l @ neighbourhood v))) + s (bigs, tl) + in + gen_aux seen bigs tl + in + fun bigs -> gen_aux VSetset.empty bigs bigs + + let allminsep g = generation g (initialisation g) + + let set_of_allminsep g = + List.fold_left + (fun bigs s -> VSetset.add s bigs) VSetset.empty (allminsep g) + + let list_of_allminsep g = List.map Vertex_Set.elements (allminsep g) + +end + +module P(G : sig include G val remove_vertex : t -> V.t -> t end) = struct + module G = G + include Make(struct + include G + let cc = + let module CC = Components.Make(G) in + fun g l -> + let g = List.fold_left remove_vertex g l in + CC.scc_list g + end) +end + +module I(G : sig + include G + module Mark : Sig.MARK with type graph = t and type vertex = V.t + end) = +struct + module G = G + include Make(struct + include G + let cc = + let module CC = + Components.Make + (struct + include G + let iter_vertex f = + iter_vertex (fun v -> if Mark.get v=0 then f v) + end) + in + fun g l -> + G.Mark.clear g; + List.iter (fun v -> G.Mark.set v 1) l; + CC.scc_list g + end) +end diff --git a/external/ocamlgraph/src/minsep.mli b/external/ocamlgraph/src/minsep.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/minsep.mli @@ -0,0 +1,70 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(*i $Id: minsep.mli,v 1.4 2004-10-22 16:31:03 conchon Exp $ i*) + +(** + Minimal separators of a graph + + Based on the article: + Generating all the minimal separators of a graph. + by A. Berry, J.-P. Bordat and O.Cogis + http://www.isima.fr/berry/generating.html + + A set [S] of vertices is a minimal separator if it exists 2 distinct + connected components [C] and [D] in [G \ S] such that each vertex of [S] has + a successor in [C] and [D]. *) + +(** Minimal signature for computing the minimal separators *) +module type G = sig + type t + module V : Sig.COMPARABLE + val succ: t -> V.t -> V.t list + val iter_succ: (V.t -> unit) -> t -> V.t -> unit + val fold_succ: (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a + val iter_vertex: (V.t -> unit) -> t -> unit + val fold_vertex: (V.t -> 'a -> 'a) -> t -> 'a -> 'a +end + +module type MINSEP = sig + module G : G + (** Implementation of a graph *) + module Vertex_Set : Set.S with type elt = G.V.t + (** Implementation of a set of vertex *) + module VSetset : Set.S with type elt = Vertex_Set.t + (** Implementation of a set of [Vertex_Set] *) + + val allminsep : G.t -> Vertex_Set.t list + (** [allminsep g] computes the list of all minimal separators of g. *) + val list_of_allminsep : G.t -> G.V.t list list + (** Less efficient that [allminsep] *) + val set_of_allminsep : G.t -> VSetset.t + (** Less efficient that [allminsep] *) +end + +(** Implementation for a persistent graph *) +module P(G : sig include G val remove_vertex : t -> V.t -> t end) : + MINSEP with module G = G + +(** Implementation for an imperative graph. + Less efficient that the implementation for a persistent graph *) +module I(G : sig + include G + module Mark : Sig.MARK with type graph = t and type vertex = V.t + end) : + MINSEP with module G = G + diff --git a/external/ocamlgraph/src/oper.ml b/external/ocamlgraph/src/oper.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/oper.ml @@ -0,0 +1,171 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: oper.ml,v 1.13 2005-06-30 10:48:55 filliatr Exp $ *) + +(* Basic operations over graphs *) + +module type S = sig + type g + val transitive_closure : ?reflexive:bool -> g -> g + val add_transitive_closure : ?reflexive:bool -> g -> g + val mirror : g -> g + val complement : g -> g + val intersect : g -> g -> g + val union : g -> g -> g +end + +module Make(B : Builder.S) = struct + + open B + + (* Roy-Warshall's algorithm *) + + type g = G.t + + let add_transitive_closure ?(reflexive=false) g0 = + let phi v g = + let g = if reflexive then B.add_edge g v v else g in + G.fold_succ + (fun sv g -> G.fold_pred (fun pv g -> B.add_edge g pv sv) g v g) + g v g + in + G.fold_vertex phi g0 g0 + + let transitive_closure ?(reflexive=false) g0 = + add_transitive_closure ~reflexive (B.copy g0) + + module H = Hashtbl.Make(G.V) + + let mirror g = + if G.is_directed then begin + let g' = B.empty () in + G.fold_edges_e + (fun e g' -> + let v1 = (G.E.src e) in + let v2 = (G.E.dst e) in + B.add_edge_e g' (G.E.create v2 (G.E.label e) v1)) + g g' + end else + B.copy g + + let complement g = + G.fold_vertex + (fun v g' -> + G.fold_vertex + (fun w g' -> + if G.mem_edge g v w then g' + else B.add_edge g' v w) + g g') + g (B.empty ()) + + let intersect g1 g2 = + G.fold_vertex + (fun v g -> + try + let succ = G.succ_e g2 v in + G.fold_succ_e + (fun e g -> + if List.mem e succ + then B.add_edge_e g e + else B.add_vertex g (G.E.dst e)) + g1 v (B.add_vertex g v) + with Invalid_argument _ -> + (* $v \notin g2$ *) + g) + g1 (B.empty ()) + + let union g1 g2 = + let add g1 g2 = + (* add the graph [g1] in [g2] *) + G.fold_vertex + (fun v g -> + G.fold_succ_e (fun e g -> B.add_edge_e g e) g1 v (B.add_vertex g v)) + g1 g2 + in + add g1 (B.copy g2) + +end + +module P(G : Sig.P) = Make(Builder.P(G)) +module I(G : Sig.I) = Make(Builder.I(G)) + +module Choose(G : sig + type t + type vertex + type edge + val iter_vertex : (vertex -> unit) -> t -> unit + val iter_edges_e : (edge -> unit) -> t -> unit + end) = +struct + + exception Found_Vertex of G.vertex + let choose_vertex g = + try + G.iter_vertex (fun v -> raise (Found_Vertex v)) g; + invalid_arg "choose_vertex" + with Found_Vertex v -> + v + + exception Found_Edge of G.edge + let choose_edge g = + try + G.iter_edges_e (fun v -> raise (Found_Edge v)) g; + invalid_arg "choose_vertex" + with Found_Edge v -> + v + +end + +module Neighbourhood(G : sig + type t + module V : Sig.COMPARABLE + val fold_succ: (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a + val succ: t -> V.t -> V.t list + end) = +struct + + module Vertex_Set = Set.Make(G.V) + + let set_from_vertex g v = + G.fold_succ + (fun v' s -> if G.V.equal v v' then s else Vertex_Set.add v' s) + g v Vertex_Set.empty + + let list_from_vertex g v = + let rec aux = function + | [] -> [] + | v' :: l -> + if G.V.equal v v' then begin + assert (not (List.exists (G.V.equal v) l)); + l + end else + v' :: aux l + in + aux (G.succ g v) + + let set_from_vertices g l = + let fold_left f = List.fold_left f Vertex_Set.empty l in + let env_init = fold_left (fun s v -> Vertex_Set.add v s) in + let add x s = + if Vertex_Set.mem x env_init then s else Vertex_Set.add x s + in + fold_left (fun s v -> G.fold_succ add g v s) + + let list_from_vertices g l = Vertex_Set.elements (set_from_vertices g l) + +end diff --git a/external/ocamlgraph/src/oper.mli b/external/ocamlgraph/src/oper.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/oper.mli @@ -0,0 +1,124 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: oper.mli,v 1.15 2005-01-18 16:40:14 signoles Exp $ *) + +(** Basic operations over graphs *) + +(** {1 Basic operations over graphs} *) + +module type S = sig + + type g + + val transitive_closure : ?reflexive:bool -> g -> g + (** [transitive_closure ?reflexive g] returns the transitive closure + of [g] (as a new graph). Loops (i.e. edges from a vertex to itself) + are added only if [reflexive] is [true] (default is [false]). *) + + val add_transitive_closure : ?reflexive:bool -> g -> g + (** [add_transitive_closure ?reflexive g] replaces [g] by its + transitive closure. Meaningless for persistent implementations + (then acts as [transitive_closure]). *) + + val mirror : g -> g + (** [mirror g] returns a new graph which is the mirror image of [g]: + each edge from [u] to [v] has been replaced by an edge from [v] to [u]. + For undirected graphs, it simply returns a copy of [g]. *) + + val complement : g -> g + (** [complement g] returns a new graph which is the complement of [g]: + each edge present in [g] is not present in the resulting graph and + vice-versa. Edges of the returned graph are unlabeled. *) + + val intersect : g -> g -> g + (** [intersect g1 g2] returns a new graph which is the intersection of [g1] + and [g2]: each vertex and edge present in [g1] *and* [g2] is present + in the resulting graph. *) + + val union : g -> g -> g + (** [union g1 g2] returns a new graph which is the union of [g1] and [g2]: + each vertex and edge present in [g1] *or* [g2] is present in the + resulting graph. *) + +end + +module Make(B : Builder.S) : S with type g = B.G.t + (** Basic operations over graphs *) + +module P(G : Sig.P) : S with type g = G.t + (** Basic operations over persistent graphs *) + +module I(G : Sig.I) : S with type g = G.t + (** Basic operations over imperative graphs *) + +(** {1 Choose} *) + +(** Choose an element in a graph *) +module Choose(G : sig + type t + type vertex + type edge + val iter_vertex : (vertex -> unit) -> t -> unit + val iter_edges_e : (edge -> unit) -> t -> unit + end) : +sig + + val choose_vertex : G.t -> G.vertex + (** [choose_vertex g] returns a vertex from the graph. + @raise Invalid_argument if the graph is empty. *) + + val choose_edge : G.t -> G.edge + (** [choose_edge g] returns an edge from the graph. + @raise Invalid_argument if the graph has no edge. *) + +end + +(** {1 Neighbourhood } *) + +(** Neighbourhood of vertex / vertices *) +module Neighbourhood(G : sig + type t + module V : Sig.COMPARABLE + val fold_succ: (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a + val succ: t -> V.t -> V.t list + end) : +sig + + module Vertex_Set : Set.S with type elt = G.V.t + + (** The neighbourhood of a vertex [v] is + \{ v' | (succ g v) and (v <> v') \} *) + + val list_from_vertex : G.t -> G.V.t -> G.V.t list + (** Neighbourhood of a vertex as a list. *) + + val set_from_vertex : G.t -> G.V.t -> Vertex_Set.t + (** Neighbourhood of a vertex as a set. + Less efficient that [list_from_vertex]. *) + + (** The neighbourhood of a set [S] of vertices is [U \ S] where + [U] is the union of neighbourhoods of each vertex of [S]. *) + + val list_from_vertices : G.t -> G.V.t list -> G.V.t list + (** Neighbourhood of a list of vertices as a list. *) + + val set_from_vertices : G.t -> G.V.t list -> Vertex_Set.t + (** Neighbourhood of a list of vertices as a set. + More efficient that [list_from_vertices]. *) + +end diff --git a/external/ocamlgraph/src/pack.ml b/external/ocamlgraph/src/pack.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/pack.ml @@ -0,0 +1,180 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: pack.ml,v 1.13 2006-05-12 14:07:16 filliatr Exp $ *) + +module Generic(G : Sig.IM with type V.label = int and type E.label = int) = +struct + + include G + + exception Found of V.t + let find_vertex g i = + try + iter_vertex (fun v -> if V.label v = i then raise (Found v)) g; + raise Not_found + with Found v -> + v + + module Builder = Builder.I(G) + + module Dfs = Traverse.Dfs(G) + module Bfs = Traverse.Bfs(G) + module Marking = Traverse.Mark(G) + + module Classic = Classic.I(G) + + module Rand = Rand.I(G) + + module Components = Components.Make(G) + + module W = struct + type label = int + type t = int + let weight x = x + let zero = 0 + let add = (+) + let compare = compare + end + + include Gpath.Dijkstra(G)(W) + + module F = struct + type label = int + type t = int + let max_capacity x = x + let min_capacity _ = 0 + let flow _ = 0 + let add = (+) + let sub = (-) + let compare = compare + let max = max_int + let min = 0 + let zero = 0 + end + + module FF = Flow.Ford_Fulkerson(G)(F) + let ford_fulkerson g = + if not G.is_directed then + invalid_arg "ford_fulkerson: not a directed graph"; + FF.maxflow g + + module Goldberg = Flow.Goldberg(G)(F) + let goldberg g = + if not G.is_directed then invalid_arg "goldberg: not a directed graph"; + Goldberg.maxflow g + + include Oper.Make(Builder) + + module PathCheck = Gpath.Check(G) + + module Topological = Topological.Make(G) + + module Int = struct + type t = int + let compare = Pervasives.compare + end + + include Kruskal.Make(G)(Int) + + module Display = struct + include G + let vertex_name v = string_of_int (V.label v) + let graph_attributes _ = [] + let default_vertex_attributes _ = [] + let vertex_attributes _ = [] + let default_edge_attributes _ = [] + let edge_attributes _ = [] + let get_subgraph _ = None + end + module Dot_ = Graphviz.Dot(Display) + module Neato = Graphviz.Neato(Display) + + let dot_output g f = + let oc = open_out f in + if is_directed then Dot_.output_graph oc g else Neato.output_graph oc g; + close_out oc + + let display_with_gv g = + let tmp = Filename.temp_file "graph" ".dot" in + dot_output g tmp; + ignore (Sys.command ("dot -Tps " ^ tmp ^ " | gv -")); + Sys.remove tmp + + module GmlParser = + Gml.Parse + (Builder) + (struct + let node l = + try match List.assoc "id" l with Gml.Int n -> n | _ -> -1 + with Not_found -> -1 + let edge _ = + 0 + end) + + let parse_gml_file = GmlParser.parse + + module DotParser = + Dot.Parse + (Builder) + (struct + let nodes = Hashtbl.create 97 + let new_node = ref 0 + let node (id,_) _ = + try + Hashtbl.find nodes id + with Not_found -> + incr new_node; + Hashtbl.add nodes id !new_node; + !new_node + let edge _ = + 0 + end) + + let parse_dot_file = DotParser.parse + + open Format + + module GmlPrinter = + Gml.Print + (G) + (struct + let node n = ["label", Gml.Int n] + let edge n = ["label", Gml.Int n] + end) + + let print_gml_file g f = + let c = open_out f in + let fmt = formatter_of_out_channel c in + fprintf fmt "%a@." GmlPrinter.print g; + close_out c + +end + +module I = struct + type t = int + let compare = compare + let hash = Hashtbl.hash + let equal = (=) + let default = 0 +end + +module Digraph = Generic(Imperative.Digraph.AbstractLabeled(I)(I)) + +module Graph = Generic(Imperative.Graph.AbstractLabeled(I)(I)) + + diff --git a/external/ocamlgraph/src/pack.mli b/external/ocamlgraph/src/pack.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/pack.mli @@ -0,0 +1,28 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: pack.mli,v 1.1 2004-02-04 11:52:02 filliatr Exp $ *) + +(** Immediate access to the library. *) + +module Digraph : Sig_pack.S + (** Directed graphs *) + +module Graph : Sig_pack.S + (** Undirected graphs *) + + diff --git a/external/ocamlgraph/src/persistent.ml b/external/ocamlgraph/src/persistent.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/persistent.ml @@ -0,0 +1,297 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: persistent.ml,v 1.18 2005-01-17 15:22:03 signoles Exp $ *) + +open Sig +open Util +open Blocks + +module type S = sig + + (** Persistent Unlabeled Graphs *) + module Concrete (V: COMPARABLE) : + Sig.P with type V.t = V.t and type V.label = V.t and type E.t = V.t * V.t + + (** Abstract Persistent Unlabeled Graphs *) + module Abstract(V: sig type t end) : Sig.P with type V.label = V.t + + (** Persistent Labeled Graphs *) + module ConcreteLabeled (V: COMPARABLE)(E: ORDERED_TYPE_DFT) : + Sig.P with type V.t = V.t and type V.label = V.t + and type E.t = V.t * E.t * V.t and type E.label = E.t + + (** Abstract Persistent Labeled Graphs *) + module AbstractLabeled (V: sig type t end)(E: ORDERED_TYPE_DFT) : + Sig.P with type V.label = V.t and type E.label = E.t + +end + +module P = Make(Make_Map) + +type 'a abstract_vertex = { tag : int; label : 'a } + +(* Vertex for the abstract persistent graphs. *) +module AbstractVertex(V: sig type t end) = struct + + type label = V.t + type t = label abstract_vertex + + let compare x y = compare x.tag y.tag + let hash x = Hashtbl.hash x.tag + let equal x y = x.tag = y.tag + let label x = x.label + + let create l = + assert (!cpt_vertex < max_int); + incr cpt_vertex; + { tag = !cpt_vertex; label = l } + +end + +module Digraph = struct + + module Concrete = P.Digraph.Concrete + + module ConcreteLabeled(V: COMPARABLE)(Edge: ORDERED_TYPE_DFT) = struct + + include P.Digraph.ConcreteLabeled(V)(Edge) + + let add_edge_e g (v1, l, v2) = + let g = add_vertex g v1 in + let g = add_vertex g v2 in + unsafe_add_edge g v1 (v2, l) + + let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) + + let remove_vertex g v = + if HM.mem v g then + let remove v s = + S.fold + (fun (v2, _ as e) s -> if not (V.equal v v2) then S.add e s else s) + s S.empty + in + let g = HM.remove v g in + HM.fold (fun k s g -> HM.add k (remove v s) g) g HM.empty + else + g + + end + + module Abstract(V: sig type t end) = struct + + include P.Digraph.Abstract(AbstractVertex(V)) + + let empty = { edges = G.empty; size = 0 } + + let add_vertex g v = + if mem_vertex g v then + g + else + { edges = G.unsafe_add_vertex g.edges v; + size = Pervasives.succ g.size } + + let add_edge g v1 v2 = + let g = add_vertex g v1 in + let g = add_vertex g v2 in + { g with edges = G.unsafe_add_edge g.edges v1 v2 } + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_vertex g v = + if HM.mem v g.edges then + let e = HM.remove v g.edges in + let e = HM.fold (fun k s g -> HM.add k (S.remove v s) g) e HM.empty in + { edges = e; size = Pervasives.pred g.size } + else + g + + let remove_edge g v1 v2 = { g with edges = remove_edge g v1 v2 } + let remove_edge_e g e = { g with edges = remove_edge_e g e } + + end + + module AbstractLabeled(V: sig type t end)(Edge: ORDERED_TYPE_DFT) = struct + + include P.Digraph.AbstractLabeled(AbstractVertex(V))(Edge) + + let empty = { edges = G.empty; size = 0 } + + let add_vertex g v = + if mem_vertex g v then + g + else + { edges = G.unsafe_add_vertex g.edges v; + size = Pervasives.succ g.size } + + let add_edge_e g (v1, l, v2) = + let g = add_vertex g v1 in + let g = add_vertex g v2 in + { g with edges = G.unsafe_add_edge g.edges v1 (v2, l) } + + let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) + + let remove_vertex g v = + if HM.mem v g.edges then + let remove v s = + S.fold + (fun (v2, _ as e) s -> if not (V.equal v v2) then S.add e s else s) + s S.empty + in + let edges = HM.remove v g.edges in + { edges = + HM.fold (fun k s g -> HM.add k (remove v s) g) edges HM.empty; + size = Pervasives.pred g.size } + else + g + + let remove_edge g v1 v2 = { g with edges = remove_edge g v1 v2 } + let remove_edge_e g e = { g with edges = remove_edge_e g e } + + end + +end + +module Graph = struct + + module Concrete(V: COMPARABLE) = struct + + module G = Digraph.Concrete(V) + + include Graph(G) + + (* Export some definitions of [G] *) + + let empty = G.empty + let add_vertex = G.add_vertex + let remove_vertex = G.remove_vertex + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge g v1 v2 = + let g = G.add_edge g v1 v2 in + assert (G.HM.mem v1 g && G.HM.mem v2 g); + G.unsafe_add_edge g v2 v1 + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_edge g v1 v2 = + let g = G.remove_edge g v1 v2 in + assert (G.HM.mem v1 g && G.HM.mem v2 g); + G.unsafe_remove_edge g v2 v1 + + let remove_edge_e g (v1, v2) = remove_edge g v1 v2 + + end + + module ConcreteLabeled(V: COMPARABLE)(Edge: ORDERED_TYPE_DFT) = struct + + module G = Digraph.ConcreteLabeled(V)(Edge) + + include Graph(G) + + (* Export some definitions of [G] *) + + let empty = G.empty + let add_vertex = G.add_vertex + let remove_vertex = G.remove_vertex + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge_e g (v1, l, v2 as e) = + let g = G.add_edge_e g e in + assert (G.HM.mem v1 g && G.HM.mem v2 g); + G.unsafe_add_edge g v2 (v1, l) + + let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) + + let remove_edge g v1 v2 = + let g = G.remove_edge g v1 v2 in + assert (G.HM.mem v1 g && G.HM.mem v2 g); + G.unsafe_remove_edge g v2 v1 + + let remove_edge_e g (v1, l, v2 as e) = + let g = G.remove_edge_e g e in + assert (G.HM.mem v1 g && G.HM.mem v2 g); + G.unsafe_remove_edge_e g (v2, l, v1) + + end + + module Abstract(V: sig type t end) = struct + + module G = Digraph.Abstract(V) + + include Graph(G) + + (* Export some definitions of [G] *) + + let empty = G.empty + let add_vertex = G.add_vertex + let remove_vertex = G.remove_vertex + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge g v1 v2 = + let g = G.add_edge g v1 v2 in + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + { g with G.edges = G.unsafe_add_edge g.G.edges v2 v1 } + + let add_edge_e g (v1, v2) = add_edge g v1 v2 + + let remove_edge g v1 v2 = + let g = G.remove_edge g v1 v2 in + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + { g with G.edges = G.unsafe_remove_edge g.G.edges v2 v1 } + + let remove_edge_e g (v1, v2) = remove_edge g v1 v2 + + end + + module AbstractLabeled (V: sig type t end)(Edge: ORDERED_TYPE_DFT) = struct + + module G = Digraph.AbstractLabeled(V)(Edge) + + include Graph(G) + + (* Export some definitions of [G] *) + + let empty = G.empty + let add_vertex = G.add_vertex + let remove_vertex = G.remove_vertex + + (* Redefine the [add_edge] and [remove_edge] operations *) + + let add_edge_e g (v1, l, v2 as e) = + let g = G.add_edge_e g e in + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + { g with G.edges = G.unsafe_add_edge g.G.edges v2 (v1, l) } + + let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) + + let remove_edge g v1 v2 = + let g = G.remove_edge g v1 v2 in + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + { g with G.edges = G.unsafe_remove_edge g.G.edges v2 v1 } + + let remove_edge_e g (v1, l, v2 as e) = + let g = G.remove_edge_e g e in + assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); + { g with G.edges = G.unsafe_remove_edge_e g.G.edges (v2, l, v1) } + + end + +end diff --git a/external/ocamlgraph/src/persistent.mli b/external/ocamlgraph/src/persistent.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/persistent.mli @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: persistent.mli,v 1.13 2006-05-12 14:07:16 filliatr Exp $ *) + +(** Persistent Implementations *) + +open Sig + +(** Signature of persistent graphs *) +module type S = sig + + (** Persistent Unlabeled Graphs *) + module Concrete (V: COMPARABLE) : + Sig.P with type V.t = V.t and type V.label = V.t and type E.t = V.t * V.t + + (** Abstract Persistent Unlabeled Graphs *) + module Abstract(V: ANY_TYPE) : Sig.P with type V.label = V.t + + (** Persistent Labeled Graphs *) + module ConcreteLabeled (V: COMPARABLE)(E: ORDERED_TYPE_DFT) : + Sig.P with type V.t = V.t and type V.label = V.t + and type E.t = V.t * E.t * V.t and type E.label = E.t + + (** Abstract Persistent Labeled Graphs *) + module AbstractLabeled (V: ANY_TYPE)(E: ORDERED_TYPE_DFT) : + Sig.P with type V.label = V.t and type E.label = E.t + +end + +(** Persistent Directed Graphs *) +module Digraph : S + +(** Persistent Undirected Graphs *) +module Graph : S + diff --git a/external/ocamlgraph/src/rand.ml b/external/ocamlgraph/src/rand.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/rand.ml @@ -0,0 +1,207 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: rand.ml,v 1.18 2005-03-31 13:32:51 filliatr Exp $ *) + +module type S = sig + type graph + type vertex + type edge_label + val graph : ?loops:bool -> v:int -> e:int -> unit -> graph + val labeled : + (vertex -> vertex -> edge_label) -> + ?loops:bool -> v:int -> e:int -> unit -> graph + (* DEBUG *) + val random_few_edges : loops:bool -> v:int -> e:int -> graph + val random_many_edges : loops:bool -> v:int -> e:int -> graph +end + +module Make(B : Builder.INT) = struct + + open B + type graph = G.t + type vertex = G.V.t + type edge_label = G.E.label + + open Int64 + + let max_edges ~loops ~v ~e = + if v <= 0 || e < 0 then invalid_arg "random"; + let v64 = of_int v in + let max_e = mul v64 (pred v64) in + let max_e = if G.is_directed then max_e else div max_e (of_int 2) in + let max_e = if loops then add max_e v64 else max_e in + if of_int e > max_e then invalid_arg "random: too many edges"; + max_e + + let fold_for i0 i1 f = + let rec loop i v = if i > i1 then v else loop (i + 1) (f v i) in + loop i0 + + (* naive implementation: we randomly chose edges up to [e] different edges *) + let random_few_edges add_edge ~loops ~v ~e = + let _ = max_edges ~loops ~v ~e in + let a = Array.init v G.V.create in + let g = Array.fold_left add_vertex (empty ()) a in + let rec random_edge g = + let i = Random.int v in + let j = Random.int v in + if (i = j && not loops) || G.mem_edge g a.(i) a.(j) then + random_edge g + else + add_edge g a.(i) a.(j) + in + fold_for 1 e (fun g _ -> random_edge g) g + + (* other implementation in O(v * v); faster when [e] is large *) + let random_many_edges add_edge ~loops ~v ~e = + let v64 = of_int v in + let max_e = max_edges ~loops ~v ~e in + let a = Array.init v G.V.create in + let g = Array.fold_left add_vertex (empty ()) a in + let rec add_edges i j max nb g = + assert + (max >= 0L && + max_e = + add max (add (mul (of_int i) v64) + (of_int + (j - + (match G.is_directed, loops with + | true, true -> 0 + | true, false -> if j > i then i + 1 else i + | false, true -> i * (i - 1) / 2 + if j > i then i else j + | false, false -> i*(i+1)/2 + if j > i then i+1 else j))))); + if nb = 0 then + g + else + let add_edges = + let i, j = if j = v - 1 then i + 1, 0 else i, j + 1 in + add_edges i j + in + if (i = j && not loops) || (not G.is_directed && i > j) then + add_edges max nb g + else + let add_edges = add_edges (pred max) in + if Random.int64 max < of_int nb then + add_edges (nb - 1) (add_edge g a.(i) a.(j)) + else + add_edges nb g + in + add_edges 0 0 max_e e g + + let random ~loops ~v ~e = + let r = float e /. (float v *. float v) in + (if r < 0.4 then random_few_edges else random_many_edges) ~loops ~v ~e + + let graph ?(loops=false) ~v ~e () = random B.add_edge ~loops ~v ~e + + let labeled f ?(loops=false) ~v ~e () = + random + (fun g v1 v2 -> B.add_edge_e g (G.E.create v1 (f v1 v2) v2)) + ~loops ~v ~e + + (* DEBUG *) + let random_few_edges = random_few_edges B.add_edge + let random_many_edges = random_many_edges B.add_edge + +end + +module P (G : Sig.P with type V.label = int) = Make(Builder.P(G)) + +module I (G : Sig.I with type V.label = int) = Make(Builder.I(G)) + + +(** Random planar graphs *) + +module Planar = struct + + module type S = sig + type graph + val graph : + ?loops:bool -> xrange:int*int -> yrange:int*int -> + prob:float -> int -> graph + end + + module Make + (B : Builder.S with type G.V.label = int * int and type G.E.label = int) = + struct + + type graph = B.G.t + open B.G + + module Point = struct + type point = V.t + let ccw v1 v2 v3 = + Delaunay.IntPoints.ccw (V.label v1) (V.label v2) (V.label v3) + let in_circle v1 v2 v3 v4 = + Delaunay.IntPoints.in_circle + (V.label v1) (V.label v2) (V.label v3) (V.label v4) + let distance v1 v2 = + let x1,y1 = V.label v1 in + let x2,y2 = V.label v2 in + let sqr x = let x = float x in x *. x in + truncate (sqrt (sqr (x1 - x2) +. sqr (y1 - y2))) + end + + module Triangulation = Delaunay.Make(Point) + + let graph ?(loops=false) ~xrange:(xmin,xmax) ~yrange:(ymin,ymax) ~prob v = + if not (0.0 <= prob && prob <= 1.0) then invalid_arg "Planar.graph"; + if v < 2 then invalid_arg "Planar.graph"; + (* [v] random points and their Delaunay triangulation *) + let random_point () = + xmin + Random.int (1 + xmax - xmin), + ymin + Random.int (1 + ymax - ymin) + in + let vertices = Array.init v (fun _ -> V.create (random_point ())) in + let t = Triangulation.triangulate vertices in + (* a graph with [v] vertices and random loops if any *) + let g = Array.fold_left B.add_vertex (B.empty ()) vertices in + let g = + if loops then + Array.fold_left + (fun g v -> + if Random.float 1.0 < prob then + g + else + let e = E.create v 0 v in B.add_edge_e g e) + g vertices + else + g + in + (* we keep some edges from the triangulation according to [prob] *) + let add_edge v1 v2 g = + if Random.float 1.0 < prob then + g + else + let e = E.create v1 (Point.distance v1 v2) v2 in B.add_edge_e g e + in + Triangulation.fold + (fun v1 v2 g -> + let g = add_edge v1 v2 g in + if is_directed then add_edge v2 v1 g else g) + t g + + end + + module P (G : Sig.P with type V.label = int * int and type E.label = int) = + Make(Builder.P(G)) + + module I (G : Sig.I with type V.label = int * int and type E.label = int) = + Make(Builder.I(G)) + +end diff --git a/external/ocamlgraph/src/rand.mli b/external/ocamlgraph/src/rand.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/rand.mli @@ -0,0 +1,111 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: rand.mli,v 1.12 2005-03-31 13:32:51 filliatr Exp $ *) + +(** Random graph generation *) + +(** {1 Random graphs} *) + +module type S = sig + + type graph + type vertex + type edge_label + + val graph : ?loops:bool -> v:int -> e:int -> unit -> graph + (** [graph v e] generates a random graph with exactly [v] vertices + and [e] edges. Vertices are labeled with [0] ... [v-1]. + The boolean [loops] indicates whether loops are allowed; + default value is no loop ([false]). + @raise Invalid_argument if [e] exceeds the maximal number of edges. *) + + val labeled : + (vertex -> vertex -> edge_label) -> + ?loops:bool -> v:int -> e:int -> unit -> graph + (** [labeled f] is similar to [graph] except that edges are labeled + using function [f]. + @raise Invalid_argument if there are too many edges. *) + + (** The two functions above actually make a choice between two + different implementations according to the ratio e/(v*v). + When this ratio is small, [random_few_edges] is selected; + otherwise [random_many_edges] is selected. *) + + val random_few_edges : loops:bool -> v:int -> e:int -> graph + val random_many_edges : loops:bool -> v:int -> e:int -> graph + +end + +module Make(B: Builder.INT) : + S with type graph = B.G.t + and type vertex = B.G.V.t + and type edge_label = B.G.E.label + (** Random graphs *) + +module P (G : Sig.P with type V.label = int) : + S with type graph = G.t + and type vertex = G.V.t + and type edge_label = G.E.label + (** Random persistent graphs *) + +module I (G : Sig.I with type V.label = int) : + S with type graph = G.t + and type vertex = G.V.t + and type edge_label = G.E.label + (** Random imperative graphs *) + +(** {1 Random planar graphs} *) + +module Planar : sig + + module type S = sig + + type graph + + val graph : + ?loops:bool -> xrange:int*int -> yrange:int*int -> + prob:float -> int -> graph + (** [graph xrange yrange prob v] + generates a random planar graph with exactly [v] vertices. + Vertices are labeled with integer coordinates, randomly distributed + according to [xrange] and [yrange]. + Edges are built as follows: the full Delaunay triangulation is + constructed and then each edge is discarded with probabiblity [prob] + (which should lie in [0..1]). In particular [prob = 0.0] gives the + full triangulation. + Edges are labeled with the (rounded) Euclidean distance between + the two vertices. + The boolean [loops] indicates whether loops are allowed; + default value is no loop ([false]). *) + + end + + module Make + (B : Builder.S with type G.V.label = int * int and type G.E.label = int) : + S with type graph = B.G.t + (** Random planar graphs *) + + module P (G : Sig.P with type V.label = int * int and type E.label = int) : + S with type graph = G.t + (** Random persistent planar graphs *) + + module I (G : Sig.I with type V.label = int * int and type E.label = int) : + S with type graph = G.t + (** Random imperative planar graphs *) + +end diff --git a/external/ocamlgraph/src/sig.mli b/external/ocamlgraph/src/sig.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/sig.mli @@ -0,0 +1,309 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: sig.mli,v 1.21 2006-05-12 14:07:16 filliatr Exp $ *) + +(** Signatures for graph implementations *) + +(** {2 Signatures for graph implementations} *) + +(** Interface for vertices *) + +module type VERTEX = sig + + (** Vertices are [COMPARABLE] *) + + type t + val compare : t -> t -> int + val hash : t -> int + val equal : t -> t -> bool + + (** Vertices are labeled. *) + + type label + val create : label -> t + val label : t -> label + +end + +(** Interface for edges *) + +module type EDGE = sig + + (** Edges are [ORDERED]. *) + + type t + val compare : t -> t -> int + + (** Edges are directed. *) + + type vertex + val src : t -> vertex + val dst : t -> vertex + + (** Edges are labeled. *) + + type label + val create : vertex -> label -> vertex -> t + (** [create v1 l v2] creates an edge from [v1] to [v2] with label [l] *) + val label : t -> label + +end + +(** Common interface for all graph implementations *) + +module type G = sig + + (** {2 Graph structure} *) + + (** Abstract type of graphs *) + type t + + (** Vertices have type [V.t] and are labeled with type [V.label] + (note that an implementation may identify the vertex with its + label) *) + module V : VERTEX + + type vertex = V.t + + (** Edges have type [E.t] and are labeled with type [E.label]. + [src] (resp. [dst]) returns the origin (resp. the destination) of a + given edge. *) + module E : EDGE with type vertex = vertex + + type edge = E.t + + (** Is this an implementation of directed graphs? *) + val is_directed : bool + + (** {2 Size functions} *) + + val is_empty : t -> bool + val nb_vertex : t -> int + val nb_edges : t -> int + + (** Degree of a vertex *) + + val out_degree : t -> vertex -> int + (** [out_degree g v] returns the out-degree of [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + val in_degree : t -> vertex -> int + (** [in_degree g v] returns the in-degree of [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + (** {2 Membership functions} *) + + val mem_vertex : t -> vertex -> bool + val mem_edge : t -> vertex -> vertex -> bool + val mem_edge_e : t -> edge -> bool + + val find_edge : t -> vertex -> vertex -> edge + (** [find_edge g v1 v2] returns the edge from [v1] to [v2] if it exists. + The behaviour is unspecified if [g] has several edges from [v1] to [v2]. + @raise Not_found if no such edge exists. *) + + (** {2 Successors and predecessors} *) + + val succ : t -> vertex -> vertex list + (** [succ g v] returns the successors of [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + val pred : t -> vertex -> vertex list + (** [pred g v] returns the predecessors of [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + (** Labeled edges going from/to a vertex *) + + val succ_e : t -> vertex -> edge list + (** [succ_e g v] returns the edges going from [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + val pred_e : t -> vertex -> edge list + (** [pred_e g v] returns the edges going to [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + (** {2 Graph iterators} *) + + (** iter/fold on all vertices/edges of a graph *) + + val iter_vertex : (vertex -> unit) -> t -> unit + val iter_edges : (vertex -> vertex -> unit) -> t -> unit + val fold_vertex : (vertex -> 'a -> 'a) -> t -> 'a -> 'a + val fold_edges : (vertex -> vertex -> 'a -> 'a) -> t -> 'a -> 'a + + (** map iterator on vertex *) + val map_vertex : (vertex -> vertex) -> t -> t + + (** iter/fold on all labeled edges of a graph *) + + val iter_edges_e : (edge -> unit) -> t -> unit + val fold_edges_e : (edge -> 'a -> 'a) -> t -> 'a -> 'a + + (** {2 Vertex iterators} + + Each iterator [iterator f v g] iters [f] to the successors/predecessors + of [v] in the graph [g] and raises [Invalid_argument] if [v] is not in + [g]. *) + + (** iter/fold on all successors/predecessors of a vertex. *) + + val iter_succ : (vertex -> unit) -> t -> vertex -> unit + val iter_pred : (vertex -> unit) -> t -> vertex -> unit + val fold_succ : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + val fold_pred : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + + (** iter/fold on all edges going from/to a vertex. *) + + val iter_succ_e : (edge -> unit) -> t -> vertex -> unit + val fold_succ_e : (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + val iter_pred_e : (edge -> unit) -> t -> vertex -> unit + val fold_pred_e : (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + +end + +(** Persistent (i.e. immutable) implementation *) + +module type P = sig + include G + + val empty : t + (** The empty graph. *) + + val add_vertex : t -> vertex -> t + (** [add_vertex g v] adds the vertex [v] from the graph [g]. + Just return [g] if [v] is already in [g]. *) + + val remove_vertex : t -> vertex -> t + (** [remove g v] removes the vertex [v] from the graph [g] + (and all the edges going from [v] in [g]). + Just return [g] if [v] is not in [g]. *) + + val add_edge : t -> vertex -> vertex -> t + (** [add_edge g v1 v2] adds an edge from the vertex [v1] to the vertex [v2] + in the graph [g]. + Add also [v1] (resp. [v2]) in [g] if [v1] (resp. [v2]) is not in [g]. + Just return [g] if this edge is already in [g]. *) + + val add_edge_e : t -> edge -> t + (** [add_edge_e g e] adds the edge [e] in the graph [g]. + Add also [E.src e] (resp. [E.dst e]) in [g] if [E.src e] (resp. [E.dst + e]) is not in [g]. + Just return [g] if [e] is already in [g]. *) + + val remove_edge : t -> vertex -> vertex -> t + (** [remove_edge g v1 v2] removes the edge going from [v1] to [v2] from the + graph [g]. If the graph is labelled, all the edges going from [v1] to + [v2] are removed from [g]. + Just return [g] if this edge is not in [g]. + @raise Invalid_argument if [v1] or [v2] are not in [g]. *) + + val remove_edge_e : t -> edge -> t + (** [remove_edge_e g e] removes the edge [e] from the graph [g]. + Just return [g] if [e] is not in [g]. + @raise Invalid_argument if [E.src e] or [E.dst e] are not in [g]. *) + +end + +(** Imperative (i.e. mutable) implementation *) + +module type I = sig + include G + + val create : ?size:int -> unit -> t + (** [create ()] returns an empty graph. Optionally, a size can be + given, which should be on the order of the expected number of + vertices that will be in the graph (for hash tables-based + implementations). The graph grows as needed, so [size] is + just an initial guess. *) + + val copy : t -> t + (** [copy g] returns a copy of [g]. Vertices and edges (and eventually + marks, see module [Mark]) are duplicated. *) + + val add_vertex : t -> vertex -> unit + (** [add_vertex g v] adds the vertex [v] from the graph [g]. + Do nothing if [v] is already in [g]. *) + + val remove_vertex : t -> vertex -> unit + (** [remove g v] removes the vertex [v] from the graph [g] + (and all the edges going from [v] in [g]). + Do nothing if [v] is not in [g]. *) + + val add_edge : t -> vertex -> vertex -> unit + (** [add_edge g v1 v2] adds an edge from the vertex [v1] to the vertex [v2] + in the graph [g]. + Add also [v1] (resp. [v2]) in [g] if [v1] (resp. [v2]) is not in [g]. + Do nothing if this edge is already in [g]. *) + + val add_edge_e : t -> edge -> unit + (** [add_edge_e g e] adds the edge [e] in the graph [g]. + Add also [E.src e] (resp. [E.dst e]) in [g] if [E.src e] (resp. [E.dst + e]) is not in [g]. + Do nothing if [e] is already in [g]. *) + + val remove_edge : t -> vertex -> vertex -> unit + (** [remove_edge g v1 v2] removes the edge going from [v1] to [v2] from the + graph [g]. If the graph is labelled, all the edges going from [v1] to + [v2] are removed from [g]. + Do nothing if this edge is not in [g]. + @raise Invalid_argument if [v1] or [v2] are not in [g]. *) + + val remove_edge_e : t -> edge -> unit + (** [remove_edge_e g e] removes the edge [e] from the graph [g]. + Do nothing if [e] is not in [g]. + @raise Invalid_argument if [E.src e] or [E.dst e] are not in [g]. *) + +end + +(** Imperative implementation with marks *) + +module type MARK = sig + type graph + type vertex + val clear : graph -> unit + (** [clear g] sets all the marks to 0 for all the vertices of [g]. *) + val get : vertex -> int + val set : vertex -> int -> unit +end + +module type IM = sig + include I + module Mark : MARK with type graph = t and type vertex = vertex +end + +(** {2 Signature for ordered and hashable types} *) + +module type ANY_TYPE = sig type t end + +module type ORDERED_TYPE = sig type t val compare : t -> t -> int end + +module type ORDERED_TYPE_DFT = sig include ORDERED_TYPE val default : t end + +module type HASHABLE = sig + type t + val hash : t -> int + val equal : t -> t -> bool +end + +(** Comparable = Ordered + Hashable *) +module type COMPARABLE = sig + type t + val compare : t -> t -> int + val hash : t -> int + val equal : t -> t -> bool +end diff --git a/external/ocamlgraph/src/sig_pack.mli b/external/ocamlgraph/src/sig_pack.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/sig_pack.mli @@ -0,0 +1,376 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: sig_pack.mli,v 1.23 2005-07-18 07:10:35 filliatr Exp $ *) + +(** Immediate access to the library. + Signature [S] gathers an imperative implementation and all algorithms into + a single module. + Vertices and edges are labeled with integers. *) + +module type S = sig + + (** {2 Graph structure} *) + + (** abstract type of graphs *) + type t + + (** Vertices *) + module V : sig + (** Vertices are [COMPARABLE] *) + + type t + val compare : t -> t -> int + val hash : t -> int + val equal : t -> t -> bool + + (** vertices are labeled with integers *) + + type label = int + val create : label -> t + val label : t -> label + end + + type vertex = V.t + + (** Edges *) + module E : sig + (** Edges are [ORDERED]. *) + + type t + val compare : t -> t -> int + + (** Edges are directed. *) + + val src : t -> V.t + val dst : t -> V.t + + (** Edges are labeled with integers. *) + + type label = int + val create : V.t -> label -> V.t -> t + (** [create v1 l v2] creates an edge from [v1] to [v2] with label [l] *) + val label : t -> label + + type vertex = V.t + end + + type edge = E.t + + (** is this an implementation of directed graphs? *) + val is_directed : bool + + (** {2 Graph constructors and destructors} *) + + val create : ?size:int -> unit -> t + (** Return an empty graph. Optionally, a size can be + given, which should be on the order of the expected number of + vertices that will be in the graph (for hash tables-based + implementations). The graph grows as needed, so [size] is + just an initial guess. *) + + val copy : t -> t + (** [copy g] returns a copy of [g]. Vertices and edges (and eventually + marks, see module [Mark]) are duplicated. *) + + val add_vertex : t -> V.t -> unit + (** [add_vertex g v] adds the vertex [v] from the graph [g]. + Do nothing if [v] is already in [g]. *) + + val remove_vertex : t -> V.t -> unit + (** [remove g v] removes the vertex [v] from the graph [g] + (and all the edges going from [v] in [g]). + Do nothing if [v] is not in [g]. *) + + val add_edge : t -> V.t -> V.t -> unit + (** [add_edge g v1 v2] adds an edge from the vertex [v1] to the vertex [v2] + in the graph [g]. + Add also [v1] (resp. [v2]) in [g] if [v1] (resp. [v2]) is not in [g]. + Do nothing if this edge is already in [g]. *) + + val add_edge_e : t -> E.t -> unit + (** [add_edge_e g e] adds the edge [e] in the graph [g]. + Add also [E.src e] (resp. [E.dst e]) in [g] if [E.src e] (resp. [E.dst + e]) is not in [g]. + Do nothing if [e] is already in [g]. *) + + val remove_edge : t -> V.t -> V.t -> unit + (** [remove_edge g v1 v2] removes the edge going from [v1] to [v2] from the + graph [g]. + Do nothing if this edge is not in [g]. + @raise Invalid_argument if [v1] or [v2] are not in [g]. *) + + val remove_edge_e : t -> E.t -> unit + (** [remove_edge_e g e] removes the edge [e] from the graph [g]. + Do nothing if [e] is not in [g]. + @raise Invalid_argument if [E.src e] or [E.dst e] are not in [g]. *) + + (** Vertices contains integers marks, which can be set or used by some + algorithms (see for instance module [Marking] below) *) + module Mark : sig + type graph = t + type vertex = V.t + val clear : t -> unit + (** [clear g] sets all marks to 0 from all the vertives of [g]. *) + val get : V.t -> int + val set : V.t -> int -> unit + end + + (** {2 Size functions} *) + + val is_empty : t -> bool + val nb_vertex : t -> int + val nb_edges : t -> int + + (** Degree of a vertex *) + + val out_degree : t -> V.t -> int + (** [out_degree g v] returns the out-degree of [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + val in_degree : t -> V.t -> int + (** [in_degree g v] returns the in-degree of [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + (** {2 Membership functions} *) + + val mem_vertex : t -> V.t -> bool + val mem_edge : t -> V.t -> V.t -> bool + val mem_edge_e : t -> E.t -> bool + val find_edge : t -> V.t -> V.t -> E.t + + (** {2 Successors and predecessors of a vertex} *) + + val succ : t -> V.t -> V.t list + (** [succ g v] returns the successors of [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + val pred : t -> V.t -> V.t list + (** [pred g v] returns the predecessors of [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + (** Labeled edges going from/to a vertex *) + + val succ_e : t -> V.t -> E.t list + (** [succ_e g v] returns the edges going from [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + val pred_e : t -> V.t -> E.t list + (** [pred_e g v] returns the edges going to [v] in [g]. + @raise Invalid_argument if [v] is not in [g]. *) + + (** {2 Graph iterators} *) + + (** iter/fold on all vertices/edges of a graph *) + + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_edges : (V.t -> V.t -> unit) -> t -> unit + val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a + val fold_edges : (V.t -> V.t -> 'a -> 'a) -> t -> 'a -> 'a + + (** map iterator on vertex *) + val map_vertex : (V.t -> V.t) -> t -> t + + (** iter/fold on all labeled edges of a graph *) + + val iter_edges_e : (E.t -> unit) -> t -> unit + val fold_edges_e : (E.t -> 'a -> 'a) -> t -> 'a -> 'a + + (** {2 Vertex iterators} + + Each iterator [iterator f v g] iters [f] to the successors/predecessors + of [v] in the graph [g] and raises [Invalid_argument] if [v] is not in + [g]. *) + + (** iter/fold on all successors/predecessors of a vertex. *) + + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + val iter_pred : (V.t -> unit) -> t -> V.t -> unit + val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a + val fold_pred : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a + + (** iter/fold on all edges going from/to a vertex. *) + + val iter_succ_e : (E.t -> unit) -> t -> V.t -> unit + val fold_succ_e : (E.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a + val iter_pred_e : (E.t -> unit) -> t -> V.t -> unit + val fold_pred_e : (E.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a + + (** {2 Basic operations} *) + + val find_vertex : t -> int -> V.t + (** [vertex g i] returns a vertex of label [i] in [g]. The behaviour is + unspecified if [g] has several vertices with label [i]. + Note: this function is inefficient (linear in the number of vertices); + you should better keep the vertices as long as you create them. *) + + val transitive_closure : ?reflexive:bool -> t -> t + (** [transitive_closure ?reflexive g] returns the transitive closure + of [g] (as a new graph). Loops (i.e. edges from a vertex to itself) + are added only if [reflexive] is [true] (default is [false]). *) + + val add_transitive_closure : ?reflexive:bool -> t -> t + (** [add_transitive_closure ?reflexive g] replaces [g] by its + transitive closure. Meaningless for persistent implementations + (then acts as [transitive_closure]). *) + + val mirror : t -> t + (** [mirror g] returns a new graph which is the mirror image of [g]: + each edge from [u] to [v] has been replaced by an edge from [v] to [u]. + For undirected graphs, it simply returns a copy of [g]. *) + + val complement : t -> t + (** [complement g] builds a new graph which is the complement of [g]: + each edge present in [g] is not present in the resulting graph and + vice-versa. Edges of the returned graph are unlabeled. *) + + val intersect : t -> t -> t + (** [intersect g1 g2] returns a new graph which is the intersection of [g1] + and [g2]: each vertex and edge present in [g1] *and* [g2] is present + in the resulting graph. *) + + val union : t -> t -> t + (** [union g1 g2] returns a new graph which is the union of [g1] and [g2]: + each vertex and edge present in [g1] *or* [g2] is present in the + resulting graph. *) + + (** {2 Traversal} *) + + (** Depth-first search *) + module Dfs : sig + val iter : ?pre:(V.t -> unit) -> + ?post:(V.t -> unit) -> t -> unit + (** [iter pre post g] visits all nodes of [g] in depth-first search, + applying [pre] to each visited node before its successors, + and [post] after them. Each node is visited exactly once. *) + val prefix : (V.t -> unit) -> t -> unit + (** applies only a prefix function *) + val postfix : (V.t -> unit) -> t -> unit + (** applies only a postfix function *) + + (** Same thing, but for a single connected component *) + + val iter_component : + ?pre:(V.t -> unit) -> + ?post:(V.t -> unit) -> t -> V.t -> unit + val prefix_component : (V.t -> unit) -> t -> V.t -> unit + val postfix_component : (V.t -> unit) -> t -> V.t -> unit + + val has_cycle : t -> bool + end + + (** Breadth-first search *) + module Bfs : sig + val iter : (V.t -> unit) -> t -> unit + val iter_component : (V.t -> unit) -> t -> V.t -> unit + end + + (** Graph traversal with marking *) + module Marking : sig + val dfs : t -> unit + val has_cycle : t -> bool + end + + (** {2 Graph generators} *) + + (** Classic graphs *) + module Classic : sig + val divisors : int -> t + (** [divisors n] builds the graph of divisors. + Vertices are integers from [2] to [n]. [i] is connected to [j] if + and only if [i] divides [j]. + @raise Invalid_argument is [n < 2]. *) + + val de_bruijn : int -> t + (** [de_bruijn n] builds the de Bruijn graph of order [n]. + Vertices are bit sequences of length [n] (encoded as their + interpretation as binary integers). The sequence [xw] is connected + to the sequence [wy] for any bits [x] and [y] and any bit sequence + [w] of length [n-1]. + @raise Invalid_argument is [n < 1] or [n > Sys.word_size-1]. *) + + val vertex_only : int -> t + (** [vertex_only n] builds a graph with [n] vertices and no edge. *) + + val full : ?self:bool -> int -> t + (** [full n] builds a graph with [n] vertices and all possible edges. + The optional argument [self] indicates if loop edges should be added + (default value is [true]). *) + end + + (** Random graphs *) + module Rand : sig + val graph : ?loops:bool -> v:int -> e:int -> unit -> t + (** [random v e] generates a random with [v] vertices and [e] edges. *) + + val labeled : + (V.t -> V.t -> E.label) -> + ?loops:bool -> v:int -> e:int -> unit -> t + (** [random_labeled f] is similar to [random] except that edges are + labeled using function [f] *) + end + + (** Strongly connected components *) + module Components : sig + val scc : t -> int*(V.t -> int) + (** strongly connected components *) + val scc_array : t -> V.t list array + val scc_list : t -> V.t list list + end + + (** {2 Classical algorithms} *) + + val shortest_path : t -> V.t -> V.t -> E.t list * int + (** Dijkstra's shortest path algorithm. Weights are the labels. *) + + val ford_fulkerson : t -> V.t -> V.t -> (E.t -> int) * int + (** Ford Fulkerson maximum flow algorithm *) + + val goldberg : t -> V.t -> V.t -> (E.t -> int) * int + (** Goldberg maximum flow algorithm *) + + (** Path checking *) + module PathCheck : sig + type path_checker + val create : t -> path_checker + val check_path : path_checker -> V.t -> V.t -> bool + end + + (** Topological order *) + module Topological : sig + val fold : (V.t -> 'a -> 'a) -> t -> 'a -> 'a + val iter : (V.t -> unit) -> t -> unit + end + + val spanningtree : t -> E.t list + (** Kruskal algorithm *) + + (** {2 Input / Output} *) + + val dot_output : t -> string -> unit + (** DOT output *) + + val display_with_gv : t -> unit + (** Displays the given graph using the external tools "dot" and "gv" + and returns when gv's window is closed *) + + val parse_gml_file : string -> t + val parse_dot_file : string -> t + + val print_gml_file : t -> string -> unit + +end diff --git a/external/ocamlgraph/src/strat.ml b/external/ocamlgraph/src/strat.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/strat.ml @@ -0,0 +1,233 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id:$ *) + +(* Signature for graphs *) +module type G = sig + + type t + + module V : Sig.ORDERED_TYPE + + type vertex = V.t + + val mem_vertex : t -> vertex -> bool + + val succ : t -> vertex -> vertex list + + val fold_vertex : (vertex -> 'a -> 'a) -> t -> 'a -> 'a + val fold_succ : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a +end + + +(* Signature for graph add-ons: an initial vertex, final vertices + and membership of vertices to either true or false, + i.e. first or second player *) +module type PLAYER = sig + + type t + type vertex + + val get_initial : t -> vertex + val is_final : t -> vertex -> bool + + val turn : t -> vertex -> bool + +end + + +(* Signature for strategies : for a given state, the strategy tells + which state to go to *) +module type STRAT = sig + + type t + type vertex + + val empty : t + val add : t -> vertex -> vertex -> t + + val next : t -> vertex -> vertex + (* Raises Invalid_argument if vertex's image is not defined *) + +end + + +(* Implements strategy algorithms on graphs *) +module Algo (G : G) (P : PLAYER with type vertex = G.vertex) + (S : STRAT with type vertex = G.vertex) : +sig + + (* coherent_player g p returns true iff + the completion p is coherent w.r.t. + the graph g *) + val coherent_player : G.t -> P.t -> bool + + (* coherent_strat g s returns true iff + the strategy s is coherent w.r.t. + the graph g *) + val coherent_strat : G.t -> S.t -> bool + + (* game g p a b returns true iff a wins in g + given the completion p (i.e. the game + goes through a final state). *) + val game : G.t -> P.t -> S.t -> S.t -> bool + + (* strategy g p s returns true iff s wins in g + given the completion p, whatever strategy + plays the other player. *) + val strategy : G.t -> P.t -> S.t -> bool + + (* strategyA g p returns true iff there + exists a winning stragegy for the true + player. In this case, the winning + strategy is provided. *) + val strategyA : G.t -> P.t -> (bool * S.t) +end = struct + + module SetV = Set.Make (G.V) + + + let rec eq l1 l2 = match l1, l2 with + [], [] -> true + | e1 :: l1', e2 :: l2' -> + (e1 = e2) && (eq l1' l2') + | _ -> false + + let rec eq_mem i l1 l2 = match l1, l2 with + [], [] -> (true, false) + | e1 :: l1', e2 :: l2' -> + if e1 = e2 then + if e1 = i then (eq l1' l2', true) + else eq_mem i l1' l2' + else (false, false) + | _ -> (false, false) + + let puit g v = match G.succ g v with + [] -> true + | _ -> false + + + let get_finals g p = + let f a l = + if P.is_final p a then a :: l + else l + in G.fold_vertex f g [] + + + let coherent_player g p = + G.mem_vertex g (P.get_initial p) + + + let coherent_strat g s = + let f v b = + try + let v' = S.next s v in + b && (G.mem_vertex g v') + with Invalid_argument _ -> true + in + G.fold_vertex f g true + + + let game g p a b = + + let rec game_aux l pi = + let continue x = + try + game_aux (SetV.add pi l) (S.next x pi) + with Invalid_argument _ -> false + in + (P.is_final p pi) || + (if SetV.mem pi l then false + else + if P.turn p pi then continue a + else continue b) + + in + game_aux SetV.empty (P.get_initial p) + + + let rec attract1 g p s l = + let f v l1 = + if not (List.mem v l1) then + if P.turn p v then + try + if List.mem (S.next s v) l1 then v :: l1 + else l1 + with Invalid_argument _ -> l1 + else + if puit g v then l1 + else + if G.fold_succ (fun v' b -> b && (List.mem v' l1)) g v true + then v :: l1 + else l1 + else l1 + in + G.fold_vertex f g l + + + let rec strategy g p s = + + let rec strategy_aux l1 l2 = + let (b1, b2) = eq_mem (P.get_initial p) l1 l2 in + if b1 then b2 + else strategy_aux (attract1 g p s l1) l1 + + in + let finaux = get_finals g p in + strategy_aux (attract1 g p s finaux) finaux + + + let rec attract g p (l, l') = + let f v (l1, l1') = + if not (List.mem v l1) then + if P.turn p v then + let f' v' l2 = + (match l2 with + [] -> + if List.mem v' l1 then [v'] + else [] + | _ -> l2) in + (match G.fold_succ f' g v [] with + [] -> (l1, l1') + | v' :: _ -> (v :: l1, S.add l1' v v' )) + else + if puit g v then (l1, l1') + else + if G.fold_succ (fun v' b -> b && (List.mem v' l1)) g v true + then (v :: l1, l1') + else (l1, l1') + else (l1, l1') + in + G.fold_vertex f g (l, l') + + + let rec strategyA g p = + + let rec strategyA_aux l1 l2 f = + let (b1, b2) = eq_mem (P.get_initial p) l1 l2 in + if b1 then (b2, f) + else + let (new_l1, new_f) = attract g p (l1, f) in + strategyA_aux new_l1 l1 new_f + + in + let finaux = get_finals g p in + let (l, r) = attract g p (finaux, S.empty) in + strategyA_aux l finaux r;; + + end diff --git a/external/ocamlgraph/src/strat.mli b/external/ocamlgraph/src/strat.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/strat.mli @@ -0,0 +1,103 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id:$ *) + +(** Strategies + + Implementation of a winning strategy of a graph: the graph + represents a two players game, each vertex belongs to either player + (whose turn it is to play) and describes a configuration of the + game. The algorithm computes the winning strategy of a player, if any; + i.e. the moves to play (which vertex to go to) so that for all + possible moves of the other player, the game goes through a final + state. + + @author Nicolas Ayache *) + +(** Signature for graphs *) +module type G = sig + type t + module V : Sig.ORDERED_TYPE + type vertex = V.t + val mem_vertex : t -> vertex -> bool + val succ : t -> vertex -> vertex list + val fold_vertex : (vertex -> 'a -> 'a) -> t -> 'a -> 'a + val fold_succ : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a +end + +(** Signature for graph add-ons: an initial vertex, final vertices + and membership of vertices to either true or false, + i.e. first or second player *) +module type PLAYER = sig + + type t + type vertex + + val get_initial : t -> vertex + val is_final : t -> vertex -> bool + + val turn : t -> vertex -> bool + +end + +(** Signature for strategies: for a given state, the strategy tells + which state to go to *) +module type STRAT = sig + + type t + type vertex + + val empty : t + val add : t -> vertex -> vertex -> t + + val next : t -> vertex -> vertex + (* Raises [Invalid_argument] if vertex's image is not defined *) + +end + +(** Implements strategy algorithms on graphs *) +module Algo (G : G) (P : PLAYER with type vertex = G.vertex) + (S : STRAT with type vertex = G.vertex) : +sig + + (** [coherent_player g p] returns [true] iff + the completion [p] is coherent w.r.t. + the graph g *) + val coherent_player : G.t -> P.t -> bool + + (** [coherent_strat g s] returns [true] iff + the strategy [s] is coherent w.r.t. + the graph [g] *) + val coherent_strat : G.t -> S.t -> bool + + (** [game g p a b] returns [true] iff [a] wins in [g] + given the completion [p] (i.e. the game + goes through a final state). *) + val game : G.t -> P.t -> S.t -> S.t -> bool + + (** [strategy g p s] returns [true] iff [s] wins in [g] + given the completion [p], whatever strategy + plays the other player. *) + val strategy : G.t -> P.t -> S.t -> bool + + (** [strategyA g p] returns [true] iff there + exists [a] winning stragegy for the true + player. In this case, the winning + strategy is provided. *) + val strategyA : G.t -> P.t -> (bool * S.t) +end diff --git a/external/ocamlgraph/src/topological.ml b/external/ocamlgraph/src/topological.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/topological.ml @@ -0,0 +1,57 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(*i $Id: topological.ml,v 1.5 2004-02-20 14:37:41 signoles Exp $ i*) + +module type G = sig + type t + module V : Sig.HASHABLE + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + val in_degree : t -> V.t -> int +end + +module Make(G: G) = struct + + module H = Hashtbl.Make(G.V) + + let fold f g acc = + let degree = H.create 997 in + let todo = Queue.create () in + let rec walk acc = + try + let v = Queue.pop todo in + let acc = f v acc in + G.iter_succ + (fun x-> let d = H.find degree x in + if d=1 then Queue.push x todo + else H.replace degree x (d-1)) + g v; + walk acc + with Queue.Empty -> acc + in + G.iter_vertex + (fun v -> + let d = G.in_degree g v in + if d = 0 then Queue.push v todo + else H.add degree v d) + g; + walk acc + + let iter f g = fold (fun v () -> f v) g () + +end diff --git a/external/ocamlgraph/src/topological.mli b/external/ocamlgraph/src/topological.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/topological.mli @@ -0,0 +1,48 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: topological.mli,v 1.7 2004-12-20 13:35:42 filliatr Exp $ *) + +(** Topological order. + + This functor provides functions which allow iterating over a + directed graph in topological order *) + +(** Minimal graph signature to provide *) +module type G = sig + type t + module V : Sig.HASHABLE + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + val in_degree : t -> V.t -> int +end + +module Make(G: G) : sig + + val fold : (G.V.t -> 'a -> 'a) -> G.t -> 'a -> 'a + (** [fold action g seed] allows iterating over the graph [g] + in topological order. [action node accu] is called repeatedly, + where [node] is the node being visited, and [accu] is the result of + the [action]'s previous invocation, if any, and [seed] otherwise. *) + + val iter : (G.V.t -> unit) -> G.t -> unit + (** [iter action] calls [action node] repeatedly. Nodes are (again) + presented to [action] in topological order. *) + +end + + diff --git a/external/ocamlgraph/src/traverse.ml b/external/ocamlgraph/src/traverse.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/traverse.ml @@ -0,0 +1,284 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: traverse.ml,v 1.17 2004-11-04 13:10:28 filliatr Exp $ *) + +(* Graph traversal *) + +module type G = sig + type t + module V : Sig.COMPARABLE + val iter_vertex : (V.t -> unit) -> t -> unit + val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a +end + +(* depth-first search *) +module Dfs(G : G) = struct + module H = Hashtbl.Make(G.V) + + let iter ?(pre=fun _ -> ()) ?(post=fun _ -> ()) g = + let h = H.create 65537 in + let rec visit v = + if not (H.mem h v) then begin + H.add h v (); + pre v; + G.iter_succ visit g v; + post v + end + in + G.iter_vertex visit g + + let postfix post g = iter ~post g + + let iter_component ?(pre=fun _ -> ()) ?(post=fun _ -> ()) g v = + let h = H.create 65537 in + let rec visit v = + H.add h v (); + pre v; + G.iter_succ (fun w -> if not (H.mem h w) then visit w) g v; + post v + in + visit v + + let prefix_component pre g = iter_component ~pre g + let postfix_component post g = iter_component ~post g + + (* invariant: not in [h] means not visited at all; [h v = true] means + already visited in the current component; [h v = false] means + already visited in another tree *) + let has_cycle g = + let h = H.create 65537 in + let rec visit v = + H.add h v true; + G.iter_succ + (fun w -> try if H.find h w then raise Exit with Not_found -> visit w) + g v; + H.replace h v false + in + try G.iter_vertex (fun v -> if not (H.mem h v) then visit v) g; false + with Exit -> true + + module Tail = struct + + let iter f g = + let h = H.create 65537 in + let stack = Stack.create () in + (* invariant: [h] contains exactly the vertices which have been pushed *) + let push v = + if not (H.mem h v) then begin H.add h v (); Stack.push v stack end + in + let loop () = + while not (Stack.is_empty stack) do + let v = Stack.pop stack in + f v; + G.iter_succ push g v + done + in + G.iter_vertex (fun v -> push v; loop ()) g + + let iter_component f g v0 = + let h = H.create 65537 in + let stack = Stack.create () in + (* invariant: [h] contains exactly the vertices which have been pushed *) + let push v = + if not (H.mem h v) then begin H.add h v (); Stack.push v stack end + in + push v0; + while not (Stack.is_empty stack) do + let v = Stack.pop stack in + f v; + G.iter_succ push g v + done + + end + + let prefix = Tail.iter + let prefix_component = Tail.iter_component + + (* step-by-step iterator *) + module S = Set.Make(G.V) + + (* state is [(s,st,g)] : [s] contains elements never been pushed in [st] *) + type iterator = S.t * G.V.t list * G.t + + let start g = + let s = G.fold_vertex S.add g S.empty in + s, [], g + + let get (s,st,_) = match st with + | [] -> if S.is_empty s then raise Exit else S.choose s + | v :: _ -> v + + let step (s,st,g) = + let push v (s,st as acc) = + if S.mem v s then + S.remove v s, v :: st + else + acc + in + let v,s',st' = match st with + | [] -> + if S.is_empty s then raise Exit; + let v = S.choose s in + (v, S.remove v s, []) + | v :: st' -> + (v, s, st') + in + let s'',st'' = G.fold_succ push g v (s',st') in + (s'',st'',g) + +end + +(* breadth-first search *) +module Bfs(G : G) = struct + module H = Hashtbl.Make(G.V) + + let iter f g = + let h = H.create 65537 in + let q = Queue.create () in + (* invariant: [h] contains exactly the vertices which have been pushed *) + let push v = + if not (H.mem h v) then begin H.add h v (); Queue.add v q end + in + let loop () = + while not (Queue.is_empty q) do + let v = Queue.pop q in + f v; + G.iter_succ push g v + done + in + G.iter_vertex (fun v -> push v; loop ()) g + + let iter_component f g v0 = + let h = H.create 65537 in + let q = Queue.create () in + (* invariant: [h] contains exactly the vertices which have been pushed *) + let push v = + if not (H.mem h v) then begin H.add h v (); Queue.add v q end + in + push v0; + while not (Queue.is_empty q) do + let v = Queue.pop q in + f v; + G.iter_succ push g v + done + + (* step-by-step iterator *) + + (* simple, yet O(1)-amortized, persistent queues *) + module Q = struct + type 'a t = 'a list * 'a list + exception Empty + let empty = [], [] + let is_empty = function [], [] -> true | _ -> false + let push x (i,o) = (x :: i, o) + let pop = function + | i, y :: o -> y, (i,o) + | [], [] -> raise Empty + | i, [] -> match List.rev i with + | x :: o -> x, ([], o) + | [] -> assert false + let peek q = fst (pop q) + end + + module S = Set.Make(G.V) + + (* state is [(s,q,g)] : [s] contains elements never been pushed in [q] *) + type iterator = S.t * G.V.t Q.t * G.t + + let start g = + let s = G.fold_vertex S.add g S.empty in + s, Q.empty, g + + let get (s,q,g) = + if Q.is_empty q then + if S.is_empty s then raise Exit else S.choose s + else + Q.peek q + + let step (s,q,g) = + let push v (s,q as acc) = + if S.mem v s then + S.remove v s, Q.push v q + else + acc + in + let v,s',q' = + if Q.is_empty q then begin + if S.is_empty s then raise Exit; + let v = S.choose s in + v, S.remove v s, q + end else + let v,q' = Q.pop q in + v, s, q' + in + let s'',q'' = G.fold_succ push g v (s',q') in + (s'',q'',g) + +end + + +(* Graph traversal with marking. *) + +module type GM = sig + type t + module V : sig type t end + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + module Mark : sig + val clear : t -> unit + val get : V.t -> int + val set : V.t -> int -> unit + end +end + +module Mark(G : GM) = struct + + let dfs g = + G.Mark.clear g; + let n = ref 0 in + let rec visit v = + if G.Mark.get v = 0 then begin + incr n; + G.Mark.set v !n; + G.iter_succ visit g v + end + in + G.iter_vertex visit g + + (* invariant: [h v = 0] means not visited at all; [h v = 1] means + already visited in the current component; [h v = 2] means + already visited in another tree *) + let has_cycle g = + G.Mark.clear g; + let rec visit v = + G.Mark.set v 1; + G.iter_succ + (fun w -> + let m = G.Mark.get w in + if m = 1 then raise Exit; + if m = 0 then visit w) + g v; + G.Mark.set v 2 + in + try G.iter_vertex (fun v -> if G.Mark.get v = 0 then visit v) g; false + with Exit -> true + +end + diff --git a/external/ocamlgraph/src/traverse.mli b/external/ocamlgraph/src/traverse.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/traverse.mli @@ -0,0 +1,127 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: traverse.mli,v 1.14 2005-04-01 07:13:24 filliatr Exp $ *) + +(** Graph traversal *) + +(** {1 Dfs and Bfs} *) + +(** Minimal graph signature for [Dfs] or [Bfs] *) +module type G = sig + type t + module V : Sig.COMPARABLE + val iter_vertex : (V.t -> unit) -> t -> unit + val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a +end + +(** Depth-first search *) +module Dfs(G : G) : sig + (** {2 Classical big-step iterators} *) + + val iter : ?pre:(G.V.t -> unit) -> + ?post:(G.V.t -> unit) -> G.t -> unit + (** [iter pre post g] visits all nodes of [g] in depth-first search, + applying [pre] to each visited node before its successors, + and [post] after them. Each node is visited exactly once. + Not tail-recursive. *) + + val prefix : (G.V.t -> unit) -> G.t -> unit + (** applies only a prefix function; note that this function is more + efficient than [iter] and is tail-recursive. *) + + val postfix : (G.V.t -> unit) -> G.t -> unit + (** applies only a postfix function. Not tail-recursive. *) + + (** Same thing, but for a single connected component + (only [prefix_component] is tail-recursive) *) + + val iter_component : ?pre:(G.V.t -> unit) -> + ?post:(G.V.t -> unit) -> G.t -> G.V.t -> unit + val prefix_component : (G.V.t -> unit) -> G.t -> G.V.t -> unit + val postfix_component : (G.V.t -> unit) -> G.t -> G.V.t -> unit + + (** {2 Step-by-step iterator} + + This is a variant of the iterators above where you can move on + step by step. The abstract type [iterator] represents the current + state of the iteration. The [step] function returns the next state. + In each state, function [get] returns the currently visited vertex. + On the final state both [get] and [step] raises exception [Exit]. + + Note: the iterator type is persistent (i.e. is not modified by the + [step] function) and thus can be used in backtracking algorithms. *) + + type iterator + val start : G.t -> iterator + val step : iterator -> iterator + val get : iterator -> G.V.t + + (** {2 Cycle detection} *) + + val has_cycle : G.t -> bool + (** [has_cycle g] checks for a cycle in [g]. Linear in time and space. *) + +end + +(** Breadth-first search *) +module Bfs(G : G) : sig + (** {2 Classical big-step iterators} *) + + val iter : (G.V.t -> unit) -> G.t -> unit + val iter_component : (G.V.t -> unit) -> G.t -> G.V.t -> unit + + (** {2 Step-by-step iterator} + See module [Dfs] *) + + type iterator + val start : G.t -> iterator + val step : iterator -> iterator + val get : iterator -> G.V.t + +end + +(** {1 Traversal with marking} *) + +(** Minimal graph signature for graph traversal with marking. *) +module type GM = sig + type t + module V : sig type t end + val iter_vertex : (V.t -> unit) -> t -> unit + val iter_succ : (V.t -> unit) -> t -> V.t -> unit + module Mark : sig + val clear : t -> unit + val get : V.t -> int + val set : V.t -> int -> unit + end +end + +(** Graph traversal with marking. + Only applies to imperative graphs with marks. *) +module Mark(G : GM) : sig + + val dfs : G.t -> unit + (** [dfs g] traverses [g] in depth-first search, marking all nodes. *) + + val has_cycle : G.t -> bool + (** [has_cycle g] checks for a cycle in [g]. Modifies the marks. + Linear time, constant space. *) + +end + diff --git a/external/ocamlgraph/src/util.ml b/external/ocamlgraph/src/util.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/util.ml @@ -0,0 +1,67 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: util.ml,v 1.14 2004-10-19 15:21:45 signoles Exp $ *) + +open Sig + +module OTProduct(X: ORDERED_TYPE)(Y: ORDERED_TYPE) = struct + + type t = X.t * Y.t + + let compare (x1, y1) (x2, y2) = + let cv = X.compare x1 x2 in + if cv != 0 then cv else Y.compare y1 y2 + +end + +module HTProduct(X: HASHABLE)(Y: HASHABLE) = struct + + type t = X.t * Y.t + + let equal (x1, y1) (x2, y2) = + X.equal x1 x2 && Y.equal y1 y2 + + let hash (x, y) = + Hashtbl.hash (X.hash x, Y.hash y) + +end + +module CMPProduct(X: COMPARABLE)(Y: COMPARABLE) = struct + include HTProduct(X)(Y) + include (OTProduct(X)(Y): sig val compare : t -> t -> int end) +end + +module DataV(L : sig type t end)(V : Sig.COMPARABLE) = +struct + type data = L.t + type label = V.t + type t = data ref * V.t + + let compare ((_, x) : t) ((_, x') : t) = + V.compare x x' + + let hash ((_, x) : t) = V.hash x + + let equal ((_, x) : t) ((_, x') : t) = V.equal x x' + + let create y lbl = (ref y, lbl) + let label (_, z) = z + let data (y, _) = !y + let set_data (y, _) = (:=) y +end + diff --git a/external/ocamlgraph/src/util.mli b/external/ocamlgraph/src/util.mli new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/util.mli @@ -0,0 +1,47 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2007 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* $Id: util.mli,v 1.12 2005-03-31 13:32:51 filliatr Exp $ *) + +open Sig + +module OTProduct(X: ORDERED_TYPE)(Y: ORDERED_TYPE) : + ORDERED_TYPE with type t = X.t * Y.t + +module HTProduct(X: HASHABLE)(Y: HASHABLE) : + HASHABLE with type t = X.t * Y.t + +module CMPProduct(X: COMPARABLE)(Y: COMPARABLE) : + COMPARABLE with type t = X.t * Y.t + +(** Create a vertex type with some data attached to it *) +module DataV + (L : sig type t end) + (V : Sig.COMPARABLE) : +sig + type data = L.t + and label = V.t + and t = data ref * V.t + val compare : t -> t -> int + val hash : t -> int + val equal : t -> t -> bool + val create : data -> V.t -> t + val label : t -> V.t + val data : t -> data + val set_data : t -> data -> unit +end + diff --git a/external/ocamlgraph/src/version.ml b/external/ocamlgraph/src/version.ml new file mode 100644 --- /dev/null +++ b/external/ocamlgraph/src/version.ml @@ -0,0 +1,2 @@ +let version = "0.99b" +let date = "Sun Sep 22 21:13:17 PDT 2013" diff --git a/external/z3/include/z3.h b/external/z3/include/z3.h new file mode 100644 --- /dev/null +++ b/external/z3/include/z3.h @@ -0,0 +1,70 @@ +/*++ +Copyright (c) 2007 Microsoft Corporation + +Module Name: + + msmt.h + +Abstract: + + Z3 API. + +Author: + + Nikolaj Bjorner (nbjorner) + Leonardo de Moura (leonardo) 2007-06-8 + +Notes: + +--*/ + +#ifndef _Z3__H_ +#define _Z3__H_ + +#include + +#ifndef __in +#define __in +#endif + +#ifndef __in_z +#define __in_z __in +#endif + +#ifndef __out +#define __out +#endif + +#ifndef __out_z +#define __out_z +#endif + +#ifndef __ecount +#define __ecount(num_args) +#endif + +#ifndef __in_ecount +#define __in_ecount(num_args) __in __ecount(num_args) +#endif + +#ifndef __out_ecount +#define __out_ecount(num_args) __out __ecount(num_args) +#endif + +#ifndef __inout_ecount +#define __inout_ecount(num_args) __in __out __ecount(num_args) +#endif + +#ifndef __inout +#define __inout __in __out +#endif + +#define Z3_API + +#define DEFINE_TYPE(T) typedef struct _ ## T *T +#define DEFINE_VOID(T) typedef void* T + +#include"z3_api.h" + +#endif + diff --git a/external/z3/include/z3_api.h b/external/z3/include/z3_api.h new file mode 100644 --- /dev/null +++ b/external/z3/include/z3_api.h @@ -0,0 +1,4824 @@ +DEFINE_TYPE(Z3_config); +DEFINE_TYPE(Z3_context); +DEFINE_TYPE(Z3_sort); +DEFINE_TYPE(Z3_func_decl); +DEFINE_TYPE(Z3_ast); +DEFINE_TYPE(Z3_app); +DEFINE_TYPE(Z3_pattern); +DEFINE_TYPE(Z3_symbol); +DEFINE_TYPE(Z3_parameter); +DEFINE_TYPE(Z3_model); +DEFINE_TYPE(Z3_literals); +DEFINE_TYPE(Z3_constructor); +DEFINE_TYPE(Z3_constructor_list); +DEFINE_TYPE(Z3_theory); +DEFINE_VOID(Z3_theory_data); + + +#ifndef __int64 +#define __int64 long long +#endif + +#ifndef __uint64 +#define __uint64 unsigned long long +#endif + +// Backwards compatibility +#define Z3_type_ast Z3_sort +#define Z3_const_decl_ast Z3_func_decl +#define Z3_const Z3_app +#define Z3_pattern_ast Z3_pattern +#define Z3_UNINTERPRETED_TYPE Z3_UNINTERPRETED_SORT +#define Z3_BOOL_TYPE Z3_BOOL_SORT +#define Z3_INT_TYPE Z3_INT_SORT +#define Z3_REAL_TYPE Z3_REAL_SORT +#define Z3_BV_TYPE Z3_BV_SORT +#define Z3_ARRAY_TYPE Z3_ARRAY_SORT +#define Z3_TUPLE_TYPE Z3_DATATYPE_SORT +#define Z3_UNKNOWN_TYPE Z3_UNKNOWN_SORT +#define Z3_CONST_DECL_AST Z3_FUNC_DECL_AST +#define Z3_TYPE_AST Z3_SORT_AST +#define Z3_SORT_ERROR Z3_TYPE_ERROR +#define Z3_mk_uninterpreted_type Z3_mk_uninterpreted_sort +#define Z3_mk_bool_type Z3_mk_bool_sort +#define Z3_mk_int_type Z3_mk_int_sort +#define Z3_mk_real_type Z3_mk_real_sort +#define Z3_mk_bv_type Z3_mk_bv_sort +#define Z3_mk_array_type Z3_mk_array_sort +#define Z3_mk_tuple_type Z3_mk_tuple_sort +#define Z3_get_type Z3_get_sort +#define Z3_get_pattern_ast Z3_get_pattern +#define Z3_get_type_kind Z3_get_sort_kind +#define Z3_get_type_name Z3_get_sort_name +#define Z3_get_bv_type_size Z3_get_bv_sort_size +#define Z3_get_array_type_domain Z3_get_array_sort_domain +#define Z3_get_array_type_range Z3_get_array_sort_range +#define Z3_get_tuple_type_num_fields Z3_get_tuple_sort_num_fields +#define Z3_get_tuple_type_field_decl Z3_get_tuple_sort_field_decl +#define Z3_get_tuple_type_mk_decl Z3_get_tuple_sort_mk_decl +#define Z3_to_const_ast Z3_to_app +#define Z3_get_numeral_value_string Z3_get_numeral_string +#define Z3_get_const_ast_decl Z3_get_app_decl +#define Z3_get_value Z3_eval_func_decl + +/** + \defgroup capi C API + +*/ +/*@{*/ + +/** + \conly @name Types + + \conly Most of the types in the C API are opaque pointers. + + \conly - \c Z3_config: a configuration object used to initialize logical contexts. + \conly - \c Z3_context: logical context. This is the main Z3 data-structure. + \conly - \c Z3_symbol: a Lisp-link symbol. It is used to name types, constants, and functions. A symbol can be created using + \conly string or integers. + \conly - \c Z3_ast: abstract syntax tree node. That is, the data-structure used in Z3 to represent terms, formulas and types. + \conly - \c Z3_sort: a kind of AST used to represent types. + \conly - \c Z3_app: a kind of AST used to represent constant and function declarations. + \conly - \c Z3_pattern: a kind of AST used to represent pattern and multi-patterns used to guide quantifier instantiation. + \conly - \c Z3_model: a model for the constraints asserted into the logical context. +*/ + +#ifndef CAMLIDL +/** + \conly \brief Z3 Boolean type. It is just an alias for \c int. +*/ +typedef int Z3_bool; +#else +/** + \conly \brief Z3 Boolean type. It is just an alias for \c Boolean. +*/ +#define Z3_bool boolean +#endif // CAMLIDL + +#ifndef CAMLIDL +/** + \conly \brief Z3 string type. It is just an alias for const char *. +*/ +typedef const char * Z3_string; +typedef Z3_string * Z3_string_ptr; +#else +/** + \conly \brief Z3 string type. It is just an alias for [string] const char *. +*/ +#define Z3_string [string] const char * +/* hack to make the IDL compiler happy */ +#define Z3_string_ptr const char * * +#endif // CAMLIDL + +#ifndef CAMLIDL +/** + \conly \brief True value. It is just an alias for \c 1. +*/ +#define Z3_TRUE 1 + +/** + \conly \brief False value. It is just an alias for \c 0. +*/ +#define Z3_FALSE 0 + +#endif // CAMLIDL + +/** + \conly \brief Lifted Boolean type: \c false, \c undefined, \c true. +*/ +typedef enum +{ + Z3_L_FALSE = -1, + Z3_L_UNDEF, + Z3_L_TRUE +} Z3_lbool; + +/** + \conly \brief In Z3, a symbol can be represented using integers and strings (See #Z3_get_symbol_kind). + + \conly \sa Z3_mk_int_symbol + \conly \sa Z3_mk_string_symbol +*/ +typedef enum +{ + Z3_INT_SYMBOL, + Z3_STRING_SYMBOL +} Z3_symbol_kind; + + +/** + \conly \brief The different kinds of parameters that can be associated with function symbols. + \conly \sa Z3_get_decl_num_parameters + \conly \sa Z3_get_decl_parameter_kind + + \conly - Z3_PARAMETER_INT is used for integer parameters. + \conly - Z3_PARAMETER_DOUBLE is used for double parameters. + \conly - Z3_PARAMETER_RATIONAL is used for parameters that are rational numbers. + \conly - Z3_PARAMETER_SORT is used for sort parameters. + \conly - Z3_PARAMETER_AST is used for expression parameters. + \conly - Z3_PARAMETER_FUNC_DECL is used for function declaration parameters. +*/ +typedef enum +{ + Z3_PARAMETER_INT, + Z3_PARAMETER_DOUBLE, + Z3_PARAMETER_RATIONAL, + Z3_PARAMETER_SYMBOL, + Z3_PARAMETER_SORT, + Z3_PARAMETER_AST, + Z3_PARAMETER_FUNC_DECL, +} Z3_parameter_kind; + +/** + \conly \brief The different kinds of Z3 types (See #Z3_get_sort_kind). +*/ +typedef enum +{ + Z3_UNINTERPRETED_SORT, + Z3_BOOL_SORT, + Z3_INT_SORT, + Z3_REAL_SORT, + Z3_BV_SORT, + Z3_ARRAY_SORT, + Z3_DATATYPE_SORT, + Z3_RELATION_SORT, + Z3_FINITE_DOMAIN_SORT, + Z3_UNKNOWN_SORT = 1000 +} Z3_sort_kind; + +/** + \conly \brief The different kinds of Z3 AST (abstract syntax trees). That is, terms, formulas and types. + + \conly - Z3_APP_AST: constant and applications + \conly - Z3_NUMERAL_AST: numeral constants + \conly - Z3_VAR_AST: bound variables + \conly - Z3_QUANTIFIER_AST: quantifiers + \conly - Z3_UNKNOWN_AST: internal +*/ +typedef enum +{ + Z3_NUMERAL_AST, + Z3_APP_AST, + Z3_VAR_AST, + Z3_QUANTIFIER_AST, + Z3_UNKNOWN_AST = 1000 +} Z3_ast_kind; + +/** + \conly \brief The different kinds of interpreted function kinds. + + (* + - Z3_OP_TRUE The constant true. + + - Z3_OP_FALSE The constant false. + + - Z3_OP_EQ The equality predicate. + + - Z3_OP_DISTINCT The n-ary distinct predicate (every argument is mutually distinct). + + - Z3_OP_ITE The ternary if-then-else term. + + - Z3_OP_AND n-ary conjunction. + + - Z3_OP_OR n-ary disjunction. + + - Z3_OP_IFF equivalence (binary). + + - Z3_OP_XOR Exclusive or. + + - Z3_OP_NOT Negation. + + - Z3_OP_IMPLIES Implication. + + - Z3_OP_OEQ Binary equivalence modulo namings. This binary predicate is used in proof terms. + It captures equisatisfiability and equivalence modulo renamings. + + - Z3_OP_ANUM Arithmetic numeral. + + - Z3_OP_LE <=. + + - Z3_OP_GE >=. + + - Z3_OP_LT <. + + - Z3_OP_GT >. + + - Z3_OP_ADD Addition - Binary. + + - Z3_OP_SUB Binary subtraction. + + - Z3_OP_UMINUS Unary minus. + + - Z3_OP_MUL Multiplication - Binary. + + - Z3_OP_DIV Division - Binary. + + - Z3_OP_IDIV Integer division - Binary. + + - Z3_OP_REM Remainder - Binary. + + - Z3_OP_MOD Modulus - Binary. + + - Z3_OP_TO_REAL Coercion of integer to real - Unary. + + - Z3_OP_TO_INT Coercion of real to integer - Unary. + + - Z3_OP_IS_INT Check if real is also an integer - Unary. + + - Z3_OP_STORE Array store. It satisfies select(store(a,i,v),j) = if i = j then v else select(a,j). + Array store takes at least 3 arguments. + + - Z3_OP_SELECT Array select. + + - Z3_OP_CONST_ARRAY The constant array. For example, select(const(v),i) = v holds for every v and i. The function is unary. + + - Z3_OP_ARRAY_DEFAULT Default value of arrays. For example default(const(v)) = v. The function is unary. + + - Z3_OP_ARRAY_MAP Array map operator. + It satisfies map[f](a1,..,a_n)[i] = f(a1[i],...,a_n[i]) for every i. + + - Z3_OP_SET_UNION Set union between two Booelan arrays (two arrays whose range type is Boolean). The function is binary. + + - Z3_OP_SET_INTERSECT Set intersection between two Boolean arrays. The function is binary. + + - Z3_OP_SET_DIFFERENCE Set difference between two Boolean arrays. The function is binary. + + - Z3_OP_SET_COMPLEMENT Set complement of a Boolean array. The function is unary. + + - Z3_OP_SET_SUBSET Subset predicate between two Boolean arrays. The relation is binary. + + - Z3_OP_AS_ARRAY An array value that behaves as the function graph of the + function passed as parameter. + + - Z3_OP_BNUM Bit-vector numeral. + + - Z3_OP_BIT1 One bit bit-vector. + + - Z3_OP_BIT0 Zero bit bit-vector. + + - Z3_OP_BNEG Unary minus. + + - Z3_OP_BADD Binary addition. + + - Z3_OP_BSUB Binary subtraction. + + - Z3_OP_BMUL Binary multiplication. + + - Z3_OP_BSDIV Binary signed division. + + - Z3_OP_BUDIV Binary unsigned division. + + - Z3_OP_BSREM Binary signed remainder. + + - Z3_OP_BUREM Binary unsigned remainder. + + - Z3_OP_BSMOD Binary signed modulus. + + - Z3_OP_BSDIV0 Unary function. bsdiv(x,0) is congruent to bsdiv0(x). + + - Z3_OP_BUDIV0 Unary function. budiv(x,0) is congruent to budiv0(x). + + - Z3_OP_BSREM0 Unary function. bsrem(x,0) is congruent to bsrem0(x). + + - Z3_OP_BUREM0 Unary function. burem(x,0) is congruent to burem0(x). + + - Z3_OP_BSMOD0 Unary function. bsmod(x,0) is congruent to bsmod0(x). + + - Z3_OP_ULEQ Unsigned bit-vector <= - Binary relation. + + - Z3_OP_SLEQ Signed bit-vector <= - Binary relation. + + - Z3_OP_UGEQ Unsigned bit-vector >= - Binary relation. + + - Z3_OP_SGEQ Signed bit-vector >= - Binary relation. + + - Z3_OP_ULT Unsigned bit-vector < - Binary relation. + + - Z3_OP_SLT Signed bit-vector < - Binary relation. + + - Z3_OP_UGT Unsigned bit-vector > - Binary relation. + + - Z3_OP_SGT Signed bit-vector > - Binary relation. + + - Z3_OP_BAND Bit-wise and - Binary. + + - Z3_OP_BOR Bit-wise or - Binary. + + - Z3_OP_BNOT Bit-wise not - Unary. + + - Z3_OP_BXOR Bit-wise xor - Binary. + + - Z3_OP_BNAND Bit-wise nand - Binary. + + - Z3_OP_BNOR Bit-wise nor - Binary. + + - Z3_OP_BXNOR Bit-wise xnor - Binary. + + - Z3_OP_CONCAT Bit-vector concatenation - Binary. + + - Z3_OP_SIGN_EXT Bit-vector sign extension. + + - Z3_OP_ZERO_EXT Bit-vector zero extension. + + - Z3_OP_EXTRACT Bit-vector extraction. + + - Z3_OP_REPEAT Repeat bit-vector n times. + + - Z3_OP_BREDOR Bit-vector reduce or - Unary. + + - Z3_OP_BREDAND Bit-vector reduce and - Unary. + + - Z3_OP_BCOMP . + + - Z3_OP_BSHL Shift left. + + - Z3_OP_BLSHR Logical shift right. + + - Z3_OP_BASHR Arithmetical shift right. + + - Z3_OP_ROTATE_LEFT Left rotation. + + - Z3_OP_ROTATE_RIGHT Right rotation. + + - Z3_OP_EXT_ROTATE_LEFT (extended) Left rotation. Similar to Z3_OP_ROTATE_LEFT, but it is a binary operator instead of a parametric one. + + - Z3_OP_EXT_ROTATE_RIGHT (extended) Right rotation. Similar to Z3_OP_ROTATE_RIGHT, but it is a binary operator instead of a parametric one. + + - Z3_OP_INT2BV Coerce integer to bit-vector. NB. This function + is not supported by the decision procedures. Only the most + rudimentary simplification rules are applied to this function. + + - Z3_OP_BV2INT Coerce bit-vector to integer. NB. This function + is not supported by the decision procedures. Only the most + rudimentary simplification rules are applied to this function. + + - Z3_OP_CARRY Compute the carry bit in a full-adder. + The meaning is given by the equivalence + (carry l1 l2 l3) <=> (or (and l1 l2) (and l1 l3) (and l2 l3))) + + - Z3_OP_XOR3 Compute ternary XOR. + The meaning is given by the equivalence + (xor3 l1 l2 l3) <=> (xor (xor l1 l2) l3) + + - Z3_OP_PR_TRUE: Proof for the expression 'true'. + + - Z3_OP_PR_ASSERTED: Proof for a fact asserted by the user. + + - Z3_OP_PR_GOAL: Proof for a fact (tagged as goal) asserted by the user. + + - Z3_OP_PR_MODUS_PONENS: Given a proof for p and a proof for (implies p q), produces a proof for q. + \nicebox{ + T1: p + T2: (implies p q) + [mp T1 T2]: q + } + The second antecedents may also be a proof for (iff p q). + + - Z3_OP_PR_REFLEXIVITY: A proof for (R t t), where R is a reflexive relation. This proof object has no antecedents. + The only reflexive relations that are used are + equivalence modulo namings, equality and equivalence. + That is, R is either '~', '=' or 'iff'. + + - Z3_OP_PR_SYMMETRY: Given an symmetric relation R and a proof for (R t s), produces a proof for (R s t). + \nicebox{ + T1: (R t s) + [symmetry T1]: (R s t) + } + T1 is the antecedent of this proof object. + + - Z3_OP_PR_TRANSITIVITY: Given a transitive relation R, and proofs for (R t s) and (R s u), produces a proof + for (R t u). + \nicebox{ + T1: (R t s) + T2: (R s u) + [trans T1 T2]: (R t u) + } + + - Z3_OP_PR_TRANSITIVITY_STAR: Condensed transitivity proof. This proof object is only used if the parameter PROOF_MODE is 1. + It combines several symmetry and transitivity proofs. + + Example: + \nicebox{ + T1: (R a b) + T2: (R c b) + T3: (R c d) + [trans* T1 T2 T3]: (R a d) + } + R must be a symmetric and transitive relation. + + Assuming that this proof object is a proof for (R s t), then + a proof checker must check if it is possible to prove (R s t) + using the antecedents, symmetry and transitivity. That is, + if there is a path from s to t, if we view every + antecedent (R a b) as an edge between a and b. + + - Z3_OP_PR_MONOTONICITY: Monotonicity proof object. + \nicebox{ + T1: (R t_1 s_1) + ... + Tn: (R t_n s_n) + [monotonicity T1 ... Tn]: (R (f t_1 ... t_n) (f s_1 ... s_n)) + } + Remark: if t_i == s_i, then the antecedent Ti is suppressed. + That is, reflexivity proofs are supressed to save space. + + - Z3_OP_PR_QUANT_INTRO: Given a proof for (~ p q), produces a proof for (~ (forall (x) p) (forall (x) q)). + + T1: (~ p q) + [quant-intro T1]: (~ (forall (x) p) (forall (x) q)) + + - Z3_OP_PR_DISTRIBUTIVITY: Distributivity proof object. + Given that f (= or) distributes over g (= and), produces a proof for + + (= (f a (g c d)) + (g (f a c) (f a d))) + + If f and g are associative, this proof also justifies the following equality: + + (= (f (g a b) (g c d)) + (g (f a c) (f a d) (f b c) (f b d))) + + where each f and g can have arbitrary number of arguments. + + This proof object has no antecedents. + Remark. This rule is used by the CNF conversion pass and + instantiated by f = or, and g = and. + + - Z3_OP_PR_AND_ELIM: Given a proof for (and l_1 ... l_n), produces a proof for l_i + + \nicebox{ + T1: (and l_1 ... l_n) + [and-elim T1]: l_i + } + - Z3_OP_PR_NOT_OR_ELIM: Given a proof for (not (or l_1 ... l_n)), produces a proof for (not l_i). + + \nicebox{ + T1: (not (or l_1 ... l_n)) + [not-or-elim T1]: (not l_i) + } + + - Z3_OP_PR_REWRITE: A proof for a local rewriting step (= t s). + The head function symbol of t is interpreted. + + This proof object has no antecedents. + The conclusion of a rewrite rule is either an equality (= t s), + an equivalence (iff t s), or equi-satisfiability (~ t s). + Remark: if f is bool, then = is iff. + + + Examples: + \nicebox{ + (= (+ x 0) x) + (= (+ x 1 2) (+ 3 x)) + (iff (or x false) x) + } + + - Z3_OP_PR_REWRITE_STAR: A proof for rewriting an expression t into an expression s. + This proof object is used if the parameter PROOF_MODE is 1. + This proof object can have n antecedents. + The antecedents are proofs for equalities used as substitution rules. + The object is also used in a few cases if the parameter PROOF_MODE is 2. + The cases are: + - When applying contextual simplification (CONTEXT_SIMPLIFIER=true) + - When converting bit-vectors to Booleans (BIT2BOOL=true) + - When pulling ite expression up (PULL_CHEAP_ITE_TREES=true) + + - Z3_OP_PR_PULL_QUANT: A proof for (iff (f (forall (x) q(x)) r) (forall (x) (f (q x) r))). This proof object has no antecedents. + + - Z3_OP_PR_PULL_QUANT_STAR: A proof for (iff P Q) where Q is in prenex normal form. + This proof object is only used if the parameter PROOF_MODE is 1. + This proof object has no antecedents. + + - Z3_OP_PR_PUSH_QUANT: A proof for: + + \nicebox{ + (iff (forall (x_1 ... x_m) (and p_1[x_1 ... x_m] ... p_n[x_1 ... x_m])) + (and (forall (x_1 ... x_m) p_1[x_1 ... x_m]) + ... + (forall (x_1 ... x_m) p_n[x_1 ... x_m]))) + } + This proof object has no antecedents. + + - Z3_OP_PR_ELIM_UNUSED_VARS: + A proof for (iff (forall (x_1 ... x_n y_1 ... y_m) p[x_1 ... x_n]) + (forall (x_1 ... x_n) p[x_1 ... x_n])) + + It is used to justify the elimination of unused variables. + This proof object has no antecedents. + + - Z3_OP_PR_DER: A proof for destructive equality resolution: + (iff (forall (x) (or (not (= x t)) P[x])) P[t]) + if x does not occur in t. + + This proof object has no antecedents. + + Several variables can be eliminated simultaneously. + + - Z3_OP_PR_QUANT_INST: A proof of (or (not (forall (x) (P x))) (P a)) + + - Z3_OP_PR_HYPOTHESIS: Mark a hypothesis in a natural deduction style proof. + + - Z3_OP_PR_LEMMA: + + \nicebox{ + T1: false + [lemma T1]: (or (not l_1) ... (not l_n)) + } + This proof object has one antecedent: a hypothetical proof for false. + It converts the proof in a proof for (or (not l_1) ... (not l_n)), + when T1 contains the hypotheses: l_1, ..., l_n. + + - Z3_OP_PR_UNIT_RESOLUTION: + \nicebox{ + T1: (or l_1 ... l_n l_1' ... l_m') + T2: (not l_1) + ... + T(n+1): (not l_n) + [unit-resolution T1 ... T(n+1)]: (or l_1' ... l_m') + } + + - Z3_OP_PR_IFF_TRUE: + \nicebox{ + T1: p + [iff-true T1]: (iff p true) + } + + - Z3_OP_PR_IFF_FALSE: + \nicebox{ + T1: (not p) + [iff-false T1]: (iff p false) + } + + - Z3_OP_PR_COMMUTATIVITY: + + [comm]: (= (f a b) (f b a)) + + f is a commutative operator. + + This proof object has no antecedents. + Remark: if f is bool, then = is iff. + + - Z3_OP_PR_DEF_AXIOM: Proof object used to justify Tseitin's like axioms: + + \nicebox{ + (or (not (and p q)) p) + (or (not (and p q)) q) + (or (not (and p q r)) p) + (or (not (and p q r)) q) + (or (not (and p q r)) r) + ... + (or (and p q) (not p) (not q)) + (or (not (or p q)) p q) + (or (or p q) (not p)) + (or (or p q) (not q)) + (or (not (iff p q)) (not p) q) + (or (not (iff p q)) p (not q)) + (or (iff p q) (not p) (not q)) + (or (iff p q) p q) + (or (not (ite a b c)) (not a) b) + (or (not (ite a b c)) a c) + (or (ite a b c) (not a) (not b)) + (or (ite a b c) a (not c)) + (or (not (not a)) (not a)) + (or (not a) a) + } + This proof object has no antecedents. + Note: all axioms are propositional tautologies. + Note also that 'and' and 'or' can take multiple arguments. + You can recover the propositional tautologies by + unfolding the Boolean connectives in the axioms a small + bounded number of steps (=3). + + - Z3_OP_PR_DEF_INTRO: Introduces a name for a formula/term. + Suppose e is an expression with free variables x, and def-intro + introduces the name n(x). The possible cases are: + + When e is of Boolean type: + [def-intro]: (and (or n (not e)) (or (not n) e)) + + or: + [def-intro]: (or (not n) e) + when e only occurs positively. + + When e is of the form (ite cond th el): + [def-intro]: (and (or (not cond) (= n th)) (or cond (= n el))) + + Otherwise: + [def-intro]: (= n e) + + - Z3_OP_PR_APPLY_DEF: + [apply-def T1]: F ~ n + F is 'equivalent' to n, given that T1 is a proof that + n is a name for F. + + - Z3_OP_PR_IFF_OEQ: + T1: (iff p q) + [iff~ T1]: (~ p q) + + - Z3_OP_PR_NNF_POS: Proof for a (positive) NNF step. Example: + \nicebox{ + T1: (not s_1) ~ r_1 + T2: (not s_2) ~ r_2 + T3: s_1 ~ r_1' + T4: s_2 ~ r_2' + [nnf-pos T1 T2 T3 T4]: (~ (iff s_1 s_2) + (and (or r_1 r_2') (or r_1' r_2))) + } + The negation normal form steps NNF_POS and NNF_NEG are used in the following cases: + (a) When creating the NNF of a positive force quantifier. + The quantifier is retained (unless the bound variables are eliminated). + Example + \nicebox{ + T1: q ~ q_new + [nnf-pos T1]: (~ (forall (x T) q) (forall (x T) q_new)) + } + (b) When recursively creating NNF over Boolean formulas, where the top-level + connective is changed during NNF conversion. The relevant Boolean connectives + for NNF_POS are 'implies', 'iff', 'xor', 'ite'. + NNF_NEG furthermore handles the case where negation is pushed + over Boolean connectives 'and' and 'or'. + + + - Z3_OP_PR_NFF_NEG: Proof for a (negative) NNF step. Examples: + \nicebox{ + T1: (not s_1) ~ r_1 + ... + Tn: (not s_n) ~ r_n + [nnf-neg T1 ... Tn]: (not (and s_1 ... s_n)) ~ (or r_1 ... r_n) + and + T1: (not s_1) ~ r_1 + ... + Tn: (not s_n) ~ r_n + [nnf-neg T1 ... Tn]: (not (or s_1 ... s_n)) ~ (and r_1 ... r_n) + and + T1: (not s_1) ~ r_1 + T2: (not s_2) ~ r_2 + T3: s_1 ~ r_1' + T4: s_2 ~ r_2' + [nnf-neg T1 T2 T3 T4]: (~ (not (iff s_1 s_2)) + (and (or r_1 r_2) (or r_1' r_2'))) + } + - Z3_OP_PR_NNF_STAR: A proof for (~ P Q) where Q is in negation normal form. + + This proof object is only used if the parameter PROOF_MODE is 1. + + This proof object may have n antecedents. Each antecedent is a PR_DEF_INTRO. + + - Z3_OP_PR_CNF_STAR: A proof for (~ P Q) where Q is in conjunctive normal form. + This proof object is only used if the parameter PROOF_MODE is 1. + This proof object may have n antecedents. Each antecedent is a PR_DEF_INTRO. + + - Z3_OP_PR_SKOLEMIZE: Proof for: + + \nicebox{ + [sk]: (~ (not (forall x (p x y))) (not (p (sk y) y))) + [sk]: (~ (exists x (p x y)) (p (sk y) y)) + } + + This proof object has no antecedents. + + - Z3_OP_PR_MODUS_PONENS_OEQ: Modus ponens style rule for equi-satisfiability. + \nicebox{ + T1: p + T2: (~ p q) + [mp~ T1 T2]: q + } + + - Z3_OP_PR_TH_LEMMA: Generic proof for theory lemmas. + + The theory lemma function comes with one or more parameters. + The first parameter indicates the name of the theory. + For the theory of arithmetic, additional parameters provide hints for + checking the theory lemma. + The hints for arithmetic are: + + - farkas - followed by rational coefficients. Multiply the coefficients to the + inequalities in the lemma, add the (negated) inequalities and obtain a contradiction. + + - triangle-eq - Indicates a lemma related to the equivalence: + \nicebox{ + (iff (= t1 t2) (and (<= t1 t2) (<= t2 t1))) + } + + - gcd-test - Indicates an integer linear arithmetic lemma that uses a gcd test. + + + - Z3_OP_RA_STORE: Insert a record into a relation. + The function takes \c n+1 arguments, where the first argument is the relation and the remaining \c n elements + correspond to the \c n columns of the relation. + + - Z3_OP_RA_EMPTY: Creates the empty relation. + + - Z3_OP_RA_IS_EMPTY: Tests if the relation is empty. + + - Z3_OP_RA_JOIN: Create the relational join. + + - Z3_OP_RA_UNION: Create the union or convex hull of two relations. + The function takes two arguments. + + - Z3_OP_RA_WIDEN: Widen two relations. + The function takes two arguments. + + - Z3_OP_RA_PROJECT: Project the columns (provided as numbers in the parameters). + The function takes one argument. + + - Z3_OP_RA_FILTER: Filter (restrict) a relation with respect to a predicate. + The first argument is a relation. + The second argument is a predicate with free de-Brujin indices + corresponding to the columns of the relation. + So the first column in the relation has index 0. + + - Z3_OP_RA_NEGATION_FILTER: Intersect the first relation with respect to negation + of the second relation (the function takes two arguments). + Logically, the specification can be described by a function + + target = filter_by_negation(pos, neg, columns) + + where columns are pairs c1, d1, .., cN, dN of columns from pos and neg, such that + target are elements in x in pos, such that there is no y in neg that agrees with + x on the columns c1, d1, .., cN, dN. + + + - Z3_OP_RA_RENAME: rename columns in the relation. + The function takes one argument. + The parameters contain the renaming as a cycle. + + - Z3_OP_RA_COMPLEMENT: Complement the relation. + + - Z3_OP_RA_SELECT: Check if a record is an element of the relation. + The function takes \c n+1 arguments, where the first argument is a relation, + and the remaining \c n arguments correspond to a record. + + - Z3_OP_RA_CLONE: Create a fresh copy (clone) of a relation. + \conly The function is logically the identity, but + \conly in the context of a register machine allows + \conly for #Z3_OP_RA_UNION to perform destructive updates to the first argument. + + + - Z3_OP_FD_LT: A less than predicate over the finite domain Z3_FINITE_DOMAIN_SORT. + + *) + +*/ +typedef enum { + Z3_OP_TRUE = 0x100, + Z3_OP_FALSE, + Z3_OP_EQ, + Z3_OP_DISTINCT, + Z3_OP_ITE, + Z3_OP_AND, + Z3_OP_OR, + Z3_OP_IFF, + Z3_OP_XOR, + Z3_OP_NOT, + Z3_OP_IMPLIES, + Z3_OP_OEQ, + + + Z3_OP_ANUM = 0x200, + Z3_OP_LE, + Z3_OP_GE, + Z3_OP_LT, + Z3_OP_GT, + Z3_OP_ADD, + Z3_OP_SUB, + Z3_OP_UMINUS, + Z3_OP_MUL, + Z3_OP_DIV, + Z3_OP_IDIV, + Z3_OP_REM, + Z3_OP_MOD, + Z3_OP_TO_REAL, + Z3_OP_TO_INT, + Z3_OP_IS_INT, + + Z3_OP_STORE = 0x300, + Z3_OP_SELECT, + Z3_OP_CONST_ARRAY, + Z3_OP_ARRAY_MAP, + Z3_OP_ARRAY_DEFAULT, + Z3_OP_SET_UNION, + Z3_OP_SET_INTERSECT, + Z3_OP_SET_DIFFERENCE, + Z3_OP_SET_COMPLEMENT, + Z3_OP_SET_SUBSET, + Z3_OP_AS_ARRAY, + + Z3_OP_BNUM = 0x400, + Z3_OP_BIT1, + Z3_OP_BIT0, + Z3_OP_BNEG, + Z3_OP_BADD, + Z3_OP_BSUB, + Z3_OP_BMUL, + + Z3_OP_BSDIV, + Z3_OP_BUDIV, + Z3_OP_BSREM, + Z3_OP_BUREM, + Z3_OP_BSMOD, + + // special functions to record the division by 0 cases + // these are internal functions + Z3_OP_BSDIV0, + Z3_OP_BUDIV0, + Z3_OP_BSREM0, + Z3_OP_BUREM0, + Z3_OP_BSMOD0, + + Z3_OP_ULEQ, + Z3_OP_SLEQ, + Z3_OP_UGEQ, + Z3_OP_SGEQ, + Z3_OP_ULT, + Z3_OP_SLT, + Z3_OP_UGT, + Z3_OP_SGT, + + Z3_OP_BAND, + Z3_OP_BOR, + Z3_OP_BNOT, + Z3_OP_BXOR, + Z3_OP_BNAND, + Z3_OP_BNOR, + Z3_OP_BXNOR, + + Z3_OP_CONCAT, + Z3_OP_SIGN_EXT, + Z3_OP_ZERO_EXT, + Z3_OP_EXTRACT, + Z3_OP_REPEAT, + + Z3_OP_BREDOR, + Z3_OP_BREDAND, + Z3_OP_BCOMP, + + Z3_OP_BSHL, + Z3_OP_BLSHR, + Z3_OP_BASHR, + Z3_OP_ROTATE_LEFT, + Z3_OP_ROTATE_RIGHT, + Z3_OP_EXT_ROTATE_LEFT, + Z3_OP_EXT_ROTATE_RIGHT, + + Z3_OP_INT2BV, + Z3_OP_BV2INT, + Z3_OP_CARRY, + Z3_OP_XOR3, + + Z3_OP_PR_UNDEF = 0x500, + Z3_OP_PR_TRUE, + Z3_OP_PR_ASSERTED, + Z3_OP_PR_GOAL, + Z3_OP_PR_MODUS_PONENS, + Z3_OP_PR_REFLEXIVITY, + Z3_OP_PR_SYMMETRY, + Z3_OP_PR_TRANSITIVITY, + Z3_OP_PR_TRANSITIVITY_STAR, + Z3_OP_PR_MONOTONICITY, + Z3_OP_PR_QUANT_INTRO, + Z3_OP_PR_DISTRIBUTIVITY, + Z3_OP_PR_AND_ELIM, + Z3_OP_PR_NOT_OR_ELIM, + Z3_OP_PR_REWRITE, + Z3_OP_PR_REWRITE_STAR, + Z3_OP_PR_PULL_QUANT, + Z3_OP_PR_PULL_QUANT_STAR, + Z3_OP_PR_PUSH_QUANT, + Z3_OP_PR_ELIM_UNUSED_VARS, + Z3_OP_PR_DER, + Z3_OP_PR_QUANT_INST, + Z3_OP_PR_HYPOTHESIS, + Z3_OP_PR_LEMMA, + Z3_OP_PR_UNIT_RESOLUTION, + Z3_OP_PR_IFF_TRUE, + Z3_OP_PR_IFF_FALSE, + Z3_OP_PR_COMMUTATIVITY, + Z3_OP_PR_DEF_AXIOM, + Z3_OP_PR_DEF_INTRO, + Z3_OP_PR_APPLY_DEF, + Z3_OP_PR_IFF_OEQ, + Z3_OP_PR_NNF_POS, + Z3_OP_PR_NNF_NEG, + Z3_OP_PR_NNF_STAR, + Z3_OP_PR_CNF_STAR, + Z3_OP_PR_SKOLEMIZE, + Z3_OP_PR_MODUS_PONENS_OEQ, + Z3_OP_PR_TH_LEMMA, + + Z3_OP_RA_STORE = 0x600, + Z3_OP_RA_EMPTY, + Z3_OP_RA_IS_EMPTY, + Z3_OP_RA_JOIN, + Z3_OP_RA_UNION, + Z3_OP_RA_WIDEN, + Z3_OP_RA_PROJECT, + Z3_OP_RA_FILTER, + Z3_OP_RA_NEGATION_FILTER, + Z3_OP_RA_RENAME, + Z3_OP_RA_COMPLEMENT, + Z3_OP_RA_SELECT, + Z3_OP_RA_CLONE, + Z3_OP_FD_LT, + + + Z3_OP_UNINTERPRETED +} Z3_decl_kind; + + + +/** + \conly \brief The different kinds of search failure types. + + \conly - Z3_NO_FAILURE: The last search was successful + \conly - Z3_UNKNOWN: Undocumented failure reason + \conly - Z3_TIMEOUT: Timeout + \conly - Z3_MEMOUT_WATERMAK: Search hit a memory high-watermak limit + \conly - Z3_CANCELED: External cancel flag was set + \conly - Z3_NUM_CONFLICTS: Maximum number of conflicts was reached + \conly - Z3_THEORY: Theory is incomplete + \conly - Z3_QUANTIFIERS: Logical context contains universal quantifiers +*/ +typedef enum { + Z3_NO_FAILURE, + Z3_UNKNOWN, + Z3_TIMEOUT, + Z3_MEMOUT_WATERMARK, + Z3_CANCELED, + Z3_NUM_CONFLICTS, + Z3_THEORY, + Z3_QUANTIFIERS +} Z3_search_failure; + +/** + \conly \brief Z3 pretty printing modes (See #Z3_set_ast_print_mode). + + \conly - Z3_PRINT_SMTLIB_FULL: Print AST nodes in SMTLIB verbose format. + \conly - Z3_PRINT_LOW_LEVEL: Print AST nodes using a low-level format. + \conly - Z3_PRINT_SMTLIB_COMPLIANT: Print AST nodes in SMTLIB 1.x compliant format. + \conly - Z3_PRINT_SMTLIB2_COMPLIANT: Print AST nodes in SMTLIB 2.x compliant format. +*/ +typedef enum { + Z3_PRINT_SMTLIB_FULL, + Z3_PRINT_LOW_LEVEL, + Z3_PRINT_SMTLIB_COMPLIANT, + Z3_PRINT_SMTLIB2_COMPLIANT +} Z3_ast_print_mode; + +#ifndef CAMLIDL + +/** + \conly \brief Z3 error codes (See #Z3_get_error_code). + + \conly - Z3_OK, + \conly - Z3_SORT_ERROR: User tried to build an invalid (type incorrect) AST. + \conly - Z3_IOB: Index out of bounds + \conly - Z3_INVALID_ARG: Invalid argument was provided + \conly - Z3_PARSER_ERROR: An error occurred when parsing a string or file. + \conly - Z3_NO_PARSER: Parser output is not available, that is, user didn't invoke Z3_parse_smtlib_string or Z3_parse_smtlib_file. + \conly - Z3_INVALID_PATTERN: Invalid pattern was used to build a quantifier. + \conly - Z3_MEMOUT_FAIL: A memory allocation failure was encountered. + \conly - Z3_FILE_ACCESS_ERRROR: A file could not be accessed. + \conly - Z3_INVALID_USAGE: API call is invalid in the current state. + \conly - Z3_INTERNAL_FATAL: An error internal to Z3 occurred. + \conly - Z3_DEC_REF_ERROR: Trying decrement the reference counter of an AST that was deleted or the reference counter was not initialized with #Z3_inc_ref. +*/ +typedef enum +{ + Z3_OK, + Z3_SORT_ERROR, + Z3_IOB, + Z3_INVALID_ARG, + Z3_PARSER_ERROR, + Z3_NO_PARSER, + Z3_INVALID_PATTERN, + Z3_MEMOUT_FAIL, + Z3_FILE_ACCESS_ERROR, + Z3_INTERNAL_FATAL, + Z3_INVALID_USAGE, + Z3_DEC_REF_ERROR +} Z3_error_code; + + + +/** + \conly \brief Z3 custom error handler (See #Z3_set_error_handler). +*/ +typedef void Z3_error_handler(Z3_error_code e); + + +#endif // CAMLIDL + +/*@}*/ + +#ifndef CAMLIDL +#ifdef __cplusplus +extern "C" { +#endif // __cplusplus +#else +[pointer_default(ref)] interface Z3 { +#endif // CAMLIDL + + /** + @name Create configuration + */ + /*@{*/ + + /** + \brief Create a configuration. + + Configurations are created in order to assign parameters prior to creating + contexts for Z3 interaction. For example, if the users whishes to use model + generation, then call: + + \ccode{Z3_set_param_value(cfg\, "MODEL"\, "true")} + + \mlonly \remark Consider using {!Z3.mk_context_x} instead of using + explicit configuration objects. The function {!Z3.mk_context_x} + receives an array of string pairs. This array represents the + configuration options. \endmlonly + + \sa Z3_set_param_value + \sa Z3_del_config + */ + Z3_config Z3_API Z3_mk_config(); + + /** + \brief Delete the given configuration object. + + \sa Z3_mk_config + */ + void Z3_API Z3_del_config(__in Z3_config c); + + /** + \brief Set a configuration parameter. + + The list of all configuration parameters can be obtained using the Z3 executable: + + \verbatim + z3.exe -ini? + \endverbatim + + \sa Z3_mk_config + */ + void Z3_API Z3_set_param_value(__in Z3_config c, __in_z Z3_string param_id, __in_z Z3_string param_value); + + + /*@}*/ + + /** + @name Create context + */ + /*@{*/ + + /** + \brief Create a context using the given configuration. + + After a context is created, the configuration cannot be changed. + All main interaction with Z3 happens in the context of a \c Z3_context. + + \mlonly \remark Consider using {!Z3.mk_context_x} instead of using + explicit configuration objects. The function {!Z3.mk_context_x} + receives an array of string pairs. This array represents the + configuration options. \endmlonly + + \sa Z3_del_context + */ + Z3_context Z3_API Z3_mk_context(__in Z3_config c); + + /** + \brief Create a context using the given configuration. + This function is similar to #Z3_mk_context. However, + in the context returned by this function, the user + is responsible for managing Z3_ast reference counters. + Managing reference counters is a burden and error-prone, + but allows the user to use the memory more efficiently. + The user must invoke #Z3_inc_ref for any Z3_ast returned + by Z3, and #Z3_dec_ref whenever the Z3_ast is not needed + anymore. This idiom is similar to the one used in + BDD (binary decision diagrams) packages such as CUDD. + + Remark: Z3_sort, Z3_func_decl, Z3_app, Z3_pattern are + Z3_ast's. + + After a context is created, the configuration cannot be changed. + All main interaction with Z3 happens in the context of a \c Z3_context. + */ + Z3_context Z3_API Z3_mk_context_rc(__in Z3_config c); + + /** + \brief Set the SMTLIB logic to be used in the given logical context. + It is incorrect to invoke this function after invoking + #Z3_check, #Z3_check_and_get_model, #Z3_check_assumptions and #Z3_push. + Return \c Z3_TRUE if the logic was changed successfully, and \c Z3_FALSE otherwise. + */ + Z3_bool Z3_API Z3_set_logic(__in Z3_context c, __in_z Z3_string logic); + + /** + \brief Delete the given logical context. + + \sa Z3_mk_config + */ + void Z3_API Z3_del_context(__in Z3_context c); + + /** + \brief Increment the reference counter of the given AST. + The context \c c should have been created using #Z3_mk_context_rc. + This function is a NOOP if \c c was created using #Z3_mk_context. + */ + void Z3_API Z3_inc_ref(__in Z3_context c, __in Z3_ast a); + + /** + \brief Decrement the reference counter of the given AST. + The context \c c should have been created using #Z3_mk_context_rc. + This function is a NOOP if \c c was created using #Z3_mk_context. + */ + void Z3_API Z3_dec_ref(__in Z3_context c, __in Z3_ast a); + + /** + \brief Enable trace messages to a file + + When trace messages are enabled, Z3 will record the operations performed on a context in the given file file. + Return \c Z3_TRUE if the file was opened successfully, and \c Z3_FALSE otherwise. + + \sa Z3_trace_off + */ + Z3_bool Z3_API Z3_trace_to_file(__in Z3_context c, __in_z Z3_string trace_file); + + /** + \brief Enable trace messages to a standard error. + + \sa Z3_trace_off + */ + void Z3_API Z3_trace_to_stderr(__in Z3_context c); + + /** + \brief Enable trace messages to a standard output. + + \sa Z3_trace_off + */ + void Z3_API Z3_trace_to_stdout(__in Z3_context c); + + /** + \brief Disable trace messages. + + \sa Z3_trace_to_file + \sa Z3_trace_to_stdout + \sa Z3_trace_to_stderr + */ + void Z3_API Z3_trace_off(__in Z3_context c); + + /** + \brief Enable/disable printing warning messages to the console. + + Warnings are printed after passing \c true, warning messages are + suppressed after calling this method with \c false. + */ + void Z3_API Z3_toggle_warning_messages(__in Z3_bool enabled); + + /** + \brief Update a mutable configuration parameter. + + The list of all configuration parameters can be obtained using the Z3 executable: + + \verbatim + z3.exe -ini? + \endverbatim + + Only a few configuration parameters are mutable once the context is created. + The error handler is invoked when trying to modify an immutable parameter. + + \sa Z3_set_param_value + */ + void Z3_API Z3_update_param_value(__in Z3_context c, __in_z Z3_string param_id, __in_z Z3_string param_value); + + /** + \brief Get a configuration parameter. + + Returns false if the parameter value does not exist. + + \sa Z3_mk_config + \sa Z3_set_param_value + */ + +#ifndef CAMLIDL + Z3_bool Z3_API Z3_get_param_value(__in Z3_context c, __in_z Z3_string param_id, __out_z Z3_string_ptr param_value); +#endif + + /*@}*/ + + /** + @name Symbols + */ + /*@{*/ + /** + \brief Create a Z3 symbol using an integer. + + Symbols are used to name several term and type constructors. + + NB. Not all integers can be passed to this function. + The legal range of unsigned integers is 0 to 2^30-1. + + \sa Z3_mk_string_symbol + */ + Z3_symbol Z3_API Z3_mk_int_symbol(__in Z3_context c, __in int i); + + /** + \brief Create a Z3 symbol using a C string. + + Symbols are used to name several term and type constructors. + + \sa Z3_mk_int_symbol + */ + Z3_symbol Z3_API Z3_mk_string_symbol(__in Z3_context c, __in_z Z3_string s); + /*@}*/ + + + /** + @name Sorts + */ + /*@{*/ + + /** + \brief compare sorts. + */ + Z3_bool Z3_API Z3_is_eq_sort(__in Z3_context c, __in Z3_sort s1, __in Z3_sort s2); + + /** + \brief Create a free (uninterpreted) type using the given name (symbol). + + Two free types are considered the same iff the have the same name. + */ + Z3_sort Z3_API Z3_mk_uninterpreted_sort(__in Z3_context c, __in Z3_symbol s); + + + /** + \brief Create the Boolean type. + + This type is used to create propositional variables and predicates. + */ + Z3_sort Z3_API Z3_mk_bool_sort(__in Z3_context c); + + /** + \brief Create an integer type. + + This type is not the int type found in programming languages. + A machine integer can be represented using bit-vectors. The function + #Z3_mk_bv_sort creates a bit-vector type. + + \sa Z3_mk_bv_sort + */ + Z3_sort Z3_API Z3_mk_int_sort(__in Z3_context c); + + /** + \brief Create a real type. + + This type is not a floating point number. + Z3 does not have support for floating point numbers yet. + */ + Z3_sort Z3_API Z3_mk_real_sort(__in Z3_context c); + + /** + \brief Create a bit-vector type of the given size. + + This type can also be seen as a machine integer. + + \remark The size of the bitvector type must be greater than zero. + */ + Z3_sort Z3_API Z3_mk_bv_sort(__in Z3_context c, __in unsigned sz); + + /** + \brief Create an array type. + + We usually represent the array type as: [domain -> range]. + Arrays are usually used to model the heap/memory in software verification. + + \sa Z3_mk_select + \sa Z3_mk_store + */ + Z3_sort Z3_API Z3_mk_array_sort(__in Z3_context c, __in Z3_sort domain, __in Z3_sort range); + + /** + \brief Create a tuple type. + + \mlonly [mk_tuple_sort c name field_names field_sorts] creates a tuple with a constructor named [name], + a [n] fields, where [n] is the size of the arrays [field_names] and [field_sorts]. + \endmlonly + + \conly A tuple with \c n fields has a constructor and \c n projections. + \conly This function will also declare the constructor and projection functions. + + \param c logical context + \param mk_tuple_name name of the constructor function associated with the tuple type. + \param num_fields number of fields in the tuple type. + \param field_names name of the projection functions. + \param field_sorts type of the tuple fields. + \param mk_tuple_decl output parameter that will contain the constructor declaration. + \param proj_decl output parameter that will contain the projection function declarations. This field must be a buffer of size \c num_fields allocated by the user. + */ + Z3_sort Z3_API Z3_mk_tuple_sort(__in Z3_context c, + __in Z3_symbol mk_tuple_name, + __in unsigned num_fields, + __in_ecount(num_fields) Z3_symbol const field_names[], + __in_ecount(num_fields) Z3_sort const field_sorts[], + __out Z3_func_decl * mk_tuple_decl, + __out_ecount(num_fields) Z3_func_decl proj_decl[]); + + /** + \brief Create a enumeration sort. + + \mlonly [mk_enumeration_sort c enums] creates an enumeration sort with enumeration names [enums], + it also returns [n] predicates, where [n] is the number of [enums] corresponding + to testing whether an element is one of the enumerants. + \endmlonly + + \conly An enumeration sort with \c n elements. + \conly This function will also declare the functions corresponding to the enumerations. + + \param c logical context + \param name name of the enumeration sort. + \param n number of elemenets in enumeration sort. + \param enum_names names of the enumerated elements. + \param enum_consts constants corresponding to the enumerated elements. + \param enum_testers predicates testing if terms of the enumeration sort correspond to an enumeration. + */ + Z3_sort Z3_API Z3_mk_enumeration_sort(__in Z3_context c, + __in Z3_symbol name, + __in unsigned n, + __in_ecount(n) Z3_symbol const enum_names[], + __out_ecount(n) Z3_func_decl enum_consts[], + __out_ecount(n) Z3_func_decl enum_testers[]); + + /** + \brief Create a list sort + + \mlonly [mk_list_sort c name elem_sort] creates a list sort of [name], over elements of sort [elem_sort]. + \endmlonly + + \conly A list sort over \c elem_sort + \conly This function declares the corresponding constructors and testers for lists. + + \param c logical context + \param name name of the list sort. + \param elem_sort sort of list elements. + \param nil_decl declaration for the empty list. + \param is_nil_decl test for the empty list. + \param cons_decl declaration for a cons cell. + \param is_cons_decl cons cell test. + \param head_decl list head. + \param tail_decl list tail. + */ + + Z3_sort Z3_API Z3_mk_list_sort(__in Z3_context c, + __in Z3_symbol name, + __in Z3_sort elem_sort, + __out Z3_func_decl* nil_decl, + __out Z3_func_decl* is_nil_decl, + __out Z3_func_decl* cons_decl, + __out Z3_func_decl* is_cons_decl, + __out Z3_func_decl* head_decl, + __out Z3_func_decl* tail_decl + ); + + /** + \brief Create a constructor. + + \param c logical context. + \param name constructor name. + \param recognizer name of recognizer function. + \param num_fields number of fields in constructor. + \param field_names names of the constructor fields. + \param sorts field sorts, 0 if the field sort refers to a recursive sort. + \param sort_refs reference to datatype sort that is an argument to the constructor; if the corresponding + sort reference is 0, then the value in sort_refs should be an index referring to + one of the recursive datatypes that is declared. + */ + + Z3_constructor Z3_API Z3_mk_constructor(__in Z3_context c, + __in Z3_symbol name, + __in Z3_symbol recognizer, + __in unsigned num_fields, + __in_ecount(num_fields) Z3_symbol const field_names[], + __in_ecount(num_fields) Z3_sort const sorts[], + __in_ecount(num_fields) unsigned sort_refs[] + ); + + /** + \brief Query constructor for declared funcions. + + \param c logical context. + \param constr constructor container. The container must have been passed in to a #Z3_mk_datatype call. + \param num_fields number of accessor fields in the constructor. + \param constructor constructor function declaration. + \param tester constructor test function declaration. + \param accessors array of accessor function declarations. + */ + + void Z3_API Z3_query_constructor(__in Z3_context c, + __in Z3_constructor constr, + __in unsigned num_fields, + __out Z3_func_decl* constructor, + __out Z3_func_decl* tester, + __out_ecount(num_fields) Z3_func_decl accessors[]); + + /** + \brief Reclaim memory allocated to constructor. + + \param c logical context. + \param constr constructor. + */ + + void Z3_API Z3_del_constructor(__in Z3_context c, __in Z3_constructor constr); + + /** + \brief Create recursive datatype. Return the datatype sort. + + \param c logical context. + \param name name of datatype. + \param num_constructors number of constructors passed in. + \param constructors array of constructor containers. + */ + + Z3_sort Z3_API Z3_mk_datatype(__in Z3_context c, + __in Z3_symbol name, + __in unsigned num_constructors, + __inout_ecount(num_constructors) Z3_constructor constructors[]); + + + /** + \brief Create list of constructors. + + \param c logical context. + \param num_constructors number of constructors in list. + \param constructors list of constructors. + */ + + Z3_constructor_list Z3_API Z3_mk_constructor_list(__in Z3_context c, + __in unsigned num_constructors, + __in_ecount(num_constructors) Z3_constructor constructors[]); + + /** + \brief reclaim memory allocated for constructor list. + + Each constructor inside the constructor list must be independently reclaimed using #Z3_del_constructor. + + \param c logical context. + \param clist constructor list container. + + */ + + void Z3_API Z3_del_constructor_list(__in Z3_context c, __in Z3_constructor_list clist); + + /** + \brief Create mutually recursive datatypes. + + \param c logical context. + \param num_sorts number of datatype sorts. + \param sort_names names of datatype sorts. + \param sorts array of datattype sorts. + \param constructor_lists list of constructors, one list per sort. + */ + + void Z3_API Z3_mk_datatypes(__in Z3_context c, + __in unsigned num_sorts, + __in_ecount(num_sorts) Z3_symbol sort_names[], + __out_ecount(num_sorts) Z3_sort sorts[], + __inout_ecount(num_sorts) Z3_constructor_list constructor_lists[]); + + /*@}*/ + + + + + /** + @name Injective functions + */ + /*@{*/ + + + /** + \brief Create injective function declaration + */ + Z3_func_decl Z3_API Z3_mk_injective_function( + __in Z3_context c, + __in Z3_symbol s, + unsigned domain_size, __in_ecount(domain_size) Z3_sort const domain[], + __in Z3_sort range + ); + + /*@}*/ + + /** + @name Constants and Applications + */ + /*@{*/ + + /** + \brief compare terms. + */ + Z3_bool Z3_API Z3_is_eq_ast(__in Z3_context c, __in Z3_ast t1, Z3_ast t2); + + + /** + \brief compare terms. + */ + Z3_bool Z3_API Z3_is_eq_func_decl(__in Z3_context c, __in Z3_func_decl f1, Z3_func_decl f2); + + + /** + \brief Declare a constant or function. + + \mlonly [mk_func_decl c n d r] creates a function with name [n], domain [d], and range [r]. + The arity of the function is the size of the array [d]. \endmlonly + + \param c logical context. + \param s name of the constant or function. + \param domain_size number of arguments. It is 0 when declaring a constant. + \param domain array containing the sort of each argument. The array must contain domain_size elements. It is 0 whe declaring a constant. + \param range sort of the constant or the return sort of the function. + + After declaring a constant or function, the function + #Z3_mk_app can be used to create a constant or function + application. + + \sa Z3_mk_app + */ + Z3_func_decl Z3_API Z3_mk_func_decl(__in Z3_context c, __in Z3_symbol s, + __in unsigned domain_size, __in_ecount(domain_size) Z3_sort const domain[], + __in Z3_sort range); + + + /** + \brief Create a constant or function application. + + \sa Z3_mk_func_decl + */ + Z3_ast Z3_API Z3_mk_app( + __in Z3_context c, + __in Z3_func_decl d, + __in unsigned num_args, + __in_ecount(num_args) Z3_ast const args[]); + + /** + \brief Declare and create a constant. + + \conly This function is a shorthand for: + \conly \code + \conly Z3_func_decl d = Z3_mk_func_decl(c, s, 0, 0, ty); + \conly Z3_ast n = Z3_mk_app(c, d, 0, 0); + \conly \endcode + + \mlonly [mk_const c s t] is a shorthand for [mk_app c (mk_func_decl c s [||] t) [||]] \endmlonly + + \sa Z3_mk_func_decl + \sa Z3_mk_app + */ + Z3_ast Z3_API Z3_mk_const(__in Z3_context c, __in Z3_symbol s, __in Z3_sort ty); + + /** + \brief Create a labeled formula. + + \param c logical context. + \param s name of the label. + \param is_pos label polarity. + \param f formula being labeled. + + A label behaves as an identity function, so the truth value of the + labeled formula is unchanged. Labels are used for identifying + useful sub-formulas when generating counter-examples. + */ + Z3_ast Z3_API Z3_mk_label(__in Z3_context c, __in Z3_symbol s, Z3_bool is_pos, Z3_ast f); + + /** + \brief Declare a fresh constant or function. + + Z3 will generate an unique name for this function declaration. + \conly If prefix is different from \c NULL, then the name generate by Z3 will start with \c prefix. + + \conly \remark If \c prefix is NULL, then it is assumed to be the empty string. + + \sa Z3_mk_func_decl + */ + Z3_func_decl Z3_API Z3_mk_fresh_func_decl(__in Z3_context c, __in_z Z3_string prefix, + __in unsigned domain_size, __in_ecount(domain_size) Z3_sort const domain[], + __in Z3_sort range); + + /** + \brief Declare and create a fresh constant. + + \conly This function is a shorthand for: + \conly \code Z3_func_decl d = Z3_mk_fresh_func_decl(c, prefix, 0, 0, ty); Z3_ast n = Z3_mk_app(c, d, 0, 0); \endcode + + \mlonly [mk_fresh_const c p t] is a shorthand for [mk_app c (mk_fresh_func_decl c p [||] t) [||]]. \endmlonly + + \conly \remark If \c prefix is NULL, then it is assumed to be the empty string. + + \sa Z3_mk_func_decl + \sa Z3_mk_app + */ + Z3_ast Z3_API Z3_mk_fresh_const(__in Z3_context c, __in_z Z3_string prefix, __in Z3_sort ty); + + + /** + \brief Create an AST node representing \c true. + */ + Z3_ast Z3_API Z3_mk_true(__in Z3_context c); + + /** + \brief Create an AST node representing \c false. + */ + Z3_ast Z3_API Z3_mk_false(__in Z3_context c); + + /** + \brief \mlh mk_eq c l r \endmlh + Create an AST node representing l = r. + + The nodes \c l and \c r must have the same type. + */ + Z3_ast Z3_API Z3_mk_eq(__in Z3_context c, __in Z3_ast l, __in Z3_ast r); + + /** + \conly \brief Create an AST node representing distinct(args[0], ..., args[num_args-1]). + \mlonly \brief \[ [mk_distinct c [| t_1; ...; t_n |]] \] Create an AST + node represeting a distinct construct. It is used for declaring + the arguments t_i pairwise distinct. \endmlonly + + \conly The \c distinct construct is used for declaring the arguments pairwise distinct. + \conly That is, Forall 0 <= i < j < num_args. not args[i] = args[j]. + + All arguments must have the same sort. + + \remark The number of arguments of a distinct construct must be greater than one. + */ + Z3_ast Z3_API Z3_mk_distinct(__in Z3_context c, __in unsigned num_args, __in_ecount(num_args) Z3_ast const args[]); + + /** + \brief \mlh mk_not c a \endmlh + Create an AST node representing not(a). + + The node \c a must have Boolean sort. + */ + Z3_ast Z3_API Z3_mk_not(__in Z3_context c, __in Z3_ast a); + + /** + \brief \mlh mk_ite c t1 t2 t2 \endmlh + Create an AST node representing an if-then-else: ite(t1, t2, + t3). + + The node \c t1 must have Boolean sort, \c t2 and \c t3 must have the same sort. + The sort of the new node is equal to the sort of \c t2 and \c t3. + */ + Z3_ast Z3_API Z3_mk_ite(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2, __in Z3_ast t3); + + /** + \brief \mlh mk_iff c t1 t2 \endmlh + Create an AST node representing t1 iff t2. + + The nodes \c t1 and \c t2 must have Boolean sort. + */ + Z3_ast Z3_API Z3_mk_iff(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_implies c t1 t2 \endmlh + Create an AST node representing t1 implies t2. + + The nodes \c t1 and \c t2 must have Boolean sort. + */ + Z3_ast Z3_API Z3_mk_implies(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_xor c t1 t2 \endmlh + Create an AST node representing t1 xor t2. + + The nodes \c t1 and \c t2 must have Boolean sort. + */ + Z3_ast Z3_API Z3_mk_xor(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \conly \brief Create an AST node representing args[0] and ... and args[num_args-1]. + \mlonly \brief \[ [mk_and c [| t_1; ...; t_n |]] \] Create the conjunction: {e t_1 and ... and t_n}. \endmlonly + + \conly The array \c args must have \c num_args elements. + All arguments must have Boolean sort. + + \remark The number of arguments must be greater than zero. + */ + Z3_ast Z3_API Z3_mk_and(__in Z3_context c, __in unsigned num_args, __in_ecount(num_args) Z3_ast const args[]); + + /** + \conly \brief Create an AST node representing args[0] or ... or args[num_args-1]. + \mlonly \brief \[ [mk_or c [| t_1; ...; t_n |]] \] Create the disjunction: {e t_1 or ... or t_n}. \endmlonly + + \conly The array \c args must have \c num_args elements. + All arguments must have Boolean sort. + + \remark The number of arguments must be greater than zero. + */ + Z3_ast Z3_API Z3_mk_or(__in Z3_context c, __in unsigned num_args, __in_ecount(num_args) Z3_ast const args[]); + + /** + \conly \brief Create an AST node representing args[0] + ... + args[num_args-1]. + \mlonly \brief \[ [mk_add c [| t_1; ...; t_n |]] \] Create the term: {e t_1 + ... + t_n}. \endmlonly + + \conly The array \c args must have \c num_args elements. + All arguments must have int or real sort. + + \remark The number of arguments must be greater than zero. + */ + Z3_ast Z3_API Z3_mk_add(__in Z3_context c, __in unsigned num_args, __in_ecount(num_args) Z3_ast const args[]); + + /** + \conly \brief Create an AST node representing args[0] * ... * args[num_args-1]. + \mlonly \brief \[ [mk_mul c [| t_1; ...; t_n |]] \] Create the term: {e t_1 * ... * t_n}. \endmlonly + + \conly The array \c args must have \c num_args elements. + All arguments must have int or real sort. + + \remark Z3 has limited support for non-linear arithmetic. + \remark The number of arguments must be greater than zero. + */ + Z3_ast Z3_API Z3_mk_mul(__in Z3_context c, __in unsigned num_args, __in_ecount(num_args) Z3_ast const args[]); + + /** + \conly \brief Create an AST node representing args[0] - ... - args[num_args - 1]. + \mlonly \brief \[ [mk_sub c [| t_1; ...; t_n |]] \] Create the term: {e t_1 - ... - t_n}. \endmlonly + + \conly The array \c args must have \c num_args elements. + All arguments must have int or real sort. + + \remark The number of arguments must be greater than zero. + */ + Z3_ast Z3_API Z3_mk_sub(__in Z3_context c, __in unsigned num_args, __in_ecount(num_args) Z3_ast const args[]); + + /** + \conly \brief Create an AST node representing -arg. + \mlonly \brief \[ [mk_unary_minus c arg] \] Create the term: {e - arg}. \endmlonly + + The argument must have int or real type. + + */ + Z3_ast Z3_API Z3_mk_unary_minus(__in Z3_context c, __in Z3_ast arg); + + + /** + \conly \brief Create an AST node representing arg1 div arg2. + \mlonly \brief \[ [mk_div c t_1 t_2] \] Create the term: {e t_1 div t_2}. \endmlonly + + The arguments must either both have int type or both have real type. + If the arguments have int type, then the result type is an int type, otherwise the + the result type is real. + + */ + Z3_ast Z3_API Z3_mk_div(__in Z3_context c, __in Z3_ast arg1, __in Z3_ast arg2); + + + /** + \conly \brief Create an AST node representing arg1 mod arg2. + \mlonly \brief \[ [mk_mod c t_1 t_2] \] Create the term: {e t_1 mod t_2}. \endmlonly + + The arguments must have int type. + + */ + Z3_ast Z3_API Z3_mk_mod(__in Z3_context c, __in Z3_ast arg1, __in Z3_ast arg2); + + /** + \conly \brief Create an AST node representing arg1 rem arg2. + \mlonly \brief \[ [mk_rem c t_1 t_2] \] Create the term: {e t_1 rem t_2}. \endmlonly + + The arguments must have int type. + + */ + Z3_ast Z3_API Z3_mk_rem(__in Z3_context c, __in Z3_ast arg1, __in Z3_ast arg2); + + /** + \brief \mlh mk_lt c t1 t2 \endmlh + Create less than. + + The nodes \c t1 and \c t2 must have the same sort, and must be int or real. + */ + Z3_ast Z3_API Z3_mk_lt(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_le c t1 t2 \endmlh + Create less than or equal to. + + The nodes \c t1 and \c t2 must have the same sort, and must be int or real. + */ + Z3_ast Z3_API Z3_mk_le(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_gt c t1 t2 \endmlh + Create greater than. + + The nodes \c t1 and \c t2 must have the same sort, and must be int or real. + */ + Z3_ast Z3_API Z3_mk_gt(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_ge c t1 t2 \endmlh + Create greater than or equal to. + + The nodes \c t1 and \c t2 must have the same sort, and must be int or real. + */ + Z3_ast Z3_API Z3_mk_ge(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_int2real c t1 \endmlh + Coerce an integer to a real. + + There is also a converse operation exposed. + It follows the semantics prescribed by the SMT-LIB standard. + + You can take the floor of a real by + creating an auxiliary integer constant \c k and + and asserting mk_int2real(k) <= t1 < mk_int2real(k)+1. + + The node \c t1 must have sort integer. + + \sa Z3_mk_real2int + \sa Z3_mk_is_int + */ + Z3_ast Z3_API Z3_mk_int2real(__in Z3_context c, __in Z3_ast t1); + + /** + \brief \mlh mk_real2int c t1 \endmlh + Coerce a real to an integer. + + The semantics of this function follows the SMT-LIB standard + for the function to_int + + \sa Z3_mk_int2real + \sa Z3_mk_is_int + */ + Z3_ast Z3_API Z3_mk_real2int(__in Z3_context c, __in Z3_ast t1); + + /** + \brief \mlh mk_is_int c t1 \endmlh + Check if a real number is an integer. + + \sa Z3_mk_int2real + \sa Z3_mk_real2int + */ + Z3_ast Z3_API Z3_mk_is_int(__in Z3_context c, __in Z3_ast t1); + + /** + \brief \mlh mk_bvnot c t1 \endmlh + Bitwise negation. + + The node \c t1 must have a bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvnot(__in Z3_context c, __in Z3_ast t1); + + /** + \brief \mlh mk_bvredand c t1 \endmlh + Take conjunction of bits in vector, return vector of length 1. + + The node \c t1 must have a bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvredand(__in Z3_context c, __in Z3_ast t1); + + /** + \brief \mlh mk_bvredor c t1 \endmlh + Take disjunction of bits in vector, return vector of length 1. + + The node \c t1 must have a bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvredor(__in Z3_context c, __in Z3_ast t1); + + /** + \brief \mlh mk_bvand c t1 t2 \endmlh + Bitwise and. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvand(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvor c t1 t2 \endmlh + Bitwise or. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvor(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvxor c t1 t2 \endmlh + Bitwise exclusive-or. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvxor(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvnand c t1 t2 \endmlh + Bitwise nand. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvnand(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvnor c t1 t2 \endmlh + Bitwise nor. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvnor(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvxnor c t1 t2 \endmlh + Bitwise xnor. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvxnor(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvneg c t1 \endmlh + Standard two's complement unary minus. + + The node \c t1 must have bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvneg(__in Z3_context c, __in Z3_ast t1); + + /** + \brief \mlh mk_bvadd c t1 t2 \endmlh + Standard two's complement addition. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvadd(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvsub c t1 t2 \endmlh + Standard two's complement subtraction. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvsub(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvmul c t1 t2 \endmlh + Standard two's complement multiplication. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvmul(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvudiv c t1 t2 \endmlh + Unsigned division. + + It is defined as the \c floor of t1/t2 if \c t2 is + different from zero. If t2 is zero, then the result + is undefined. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvudiv(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvsdiv c t1 t2 \endmlh + Two's complement signed division. + + It is defined in the following way: + + - The \c floor of t1/t2 if \c t2 is different from zero, and t1*t2 >= 0. + + - The \c ceiling of t1/t2 if \c t2 is different from zero, and t1*t2 < 0. + + If t2 is zero, then the result is undefined. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvsdiv(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvurem c t1 t2 \endmlh + Unsigned remainder. + + It is defined as t1 - (t1 /u t2) * t2, where /u represents unsigned division. + + If t2 is zero, then the result is undefined. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvurem(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvsrem c t1 t2 \endmlh + Two's complement signed remainder (sign follows dividend). + + It is defined as t1 - (t1 /s t2) * t2, where /s represents signed division. + The most significant bit (sign) of the result is equal to the most significant bit of \c t1. + + If t2 is zero, then the result is undefined. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + + \sa Z3_mk_bvsmod + */ + Z3_ast Z3_API Z3_mk_bvsrem(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvsmod c t1 t2 \endmlh + Two's complement signed remainder (sign follows divisor). + + If t2 is zero, then the result is undefined. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + + \sa Z3_mk_bvsrem + */ + Z3_ast Z3_API Z3_mk_bvsmod(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvult c t1 t2 \endmlh + Unsigned less than. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvult(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvslt c t1 t2 \endmlh + Two's complement signed less than. + + It abbreviates: + \code + (or (and (= (extract[|m-1|:|m-1|] t1) bit1) + (= (extract[|m-1|:|m-1|] t2) bit0)) + (and (= (extract[|m-1|:|m-1|] t1) (extract[|m-1|:|m-1|] t2)) + (bvult t1 t2))) + \endcode + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvslt(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvule c t1 t2 \endmlh + Unsigned less than or equal to. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvule(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvsle c t1 t2 \endmlh + Two's complement signed less than or equal to. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvsle(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvuge c t1 t2 \endmlh + Unsigned greater than or equal to. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvuge(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvsge c t1 t2 \endmlh + Two's complement signed greater than or equal to. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvsge(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvugt c t1 t2 \endmlh + Unsigned greater than. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvugt(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvsgt c t1 t2 \endmlh + Two's complement signed greater than. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvsgt(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_concat c t1 t2 \endmlh + Concatenate the given bit-vectors. + + The nodes \c t1 and \c t2 must have (possibly different) bit-vector sorts + + The result is a bit-vector of size n1+n2, where \c n1 (\c n2) is the size + of \c t1 (\c t2). + */ + Z3_ast Z3_API Z3_mk_concat(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_extract c high low t1 \endmlh + Extract the bits \c high down to \c low from a bitvector of + size \c m to yield a new bitvector of size \c n, where n = + high - low + 1. + + The node \c t1 must have a bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_extract(__in Z3_context c, __in unsigned high, __in unsigned low, __in Z3_ast t1); + + /** + \brief \mlh mk_sign_ext c i t1 \endmlh + Sign-extend of the given bit-vector to the (signed) equivalent bitvector of + size m+i, where \c m is the size of the given + bit-vector. + + The node \c t1 must have a bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_sign_ext(__in Z3_context c, __in unsigned i, __in Z3_ast t1); + + /** + \brief \mlh mk_zero_ext c i t1 \endmlh + Extend the given bit-vector with zeros to the (unsigned) equivalent + bitvector of size m+i, where \c m is the size of the + given bit-vector. + + The node \c t1 must have a bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_zero_ext(__in Z3_context c, __in unsigned i, __in Z3_ast t1); + + /** + \brief \mlh mk_repeat c i t1 \endmlh + Repeat the given bit-vector up length i. + + The node \c t1 must have a bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_repeat(__in Z3_context c, __in unsigned i, __in Z3_ast t1); + + /** + \brief \mlh mk_bvshl c t1 t2 \endmlh + Shift left. + + It is equivalent to multiplication by 2^x where \c x is the value of the + third argument. + + NB. The semantics of shift operations varies between environments. This + definition does not necessarily capture directly the semantics of the + programming language or assembly architecture you are modeling. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvshl(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvlshr c t1 t2 \endmlh + Logical shift right. + + It is equivalent to unsigned division by 2^x where \c x is the + value of the third argument. + + NB. The semantics of shift operations varies between environments. This + definition does not necessarily capture directly the semantics of the + programming language or assembly architecture you are modeling. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvlshr(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvashr c t1 t2 \endmlh + Arithmetic shift right. + + It is like logical shift right except that the most significant + bits of the result always copy the most significant bit of the + second argument. + + NB. The semantics of shift operations varies between environments. This + definition does not necessarily capture directly the semantics of the + programming language or assembly architecture you are modeling. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvashr(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_rotate_left c i t1 \endmlh + Rotate bits of \c t1 to the left \c i times. + + The node \c t1 must have a bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_rotate_left(__in Z3_context c, __in unsigned i, __in Z3_ast t1); + + /** + \brief \mlh mk_rotate_right c i t1 \endmlh + Rotate bits of \c t1 to the right \c i times. + + The node \c t1 must have a bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_rotate_right(__in Z3_context c, __in unsigned i, __in Z3_ast t1); + + /** + \brief \mlh mk_ext_rotate_left c t1 t2 \endmlh + Rotate bits of \c t1 to the left \c t2 times. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_ext_rotate_left(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_ext_rotate_right c t1 t2 \endmlh + Rotate bits of \c t1 to the right \c t2 times. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_ext_rotate_right(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_int2bv c n t1 \endmlh + Create an \c n bit bit-vector from the integer argument \c t1. + + NB. This function is essentially treated as uninterpreted. + So you cannot expect Z3 to precisely reflect the semantics of this function + when solving constraints with this function. + + The node \c t1 must have integer sort. + */ + Z3_ast Z3_API Z3_mk_int2bv(__in Z3_context c, __in unsigned n, __in Z3_ast t1); + + /** + \brief \mlh mk_bv2int c t1 is_signed \endmlh + Create an integer from the bit-vector argument \c t1. + If \c is_signed is false, then the bit-vector \c t1 is treated as unsigned. + So the result is non-negative + and in the range [0..2^N-1], where N are the number of bits in \c t1. + If \c is_signed is true, \c t1 is treated as a signed bit-vector. + + NB. This function is essentially treated as uninterpreted. + So you cannot expect Z3 to precisely reflect the semantics of this function + when solving constraints with this function. + + The node \c t1 must have a bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bv2int(__in Z3_context c,__in Z3_ast t1, Z3_bool is_signed); + + /** + \brief \mlh mk_bvadd_no_overflow c t1 t2 is_signed \endmlh + Create a predicate that checks that the bit-wise addition + of \c t1 and \c t2 does not overflow. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvadd_no_overflow(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2, Z3_bool is_signed); + + /** + \brief \mlh mk_bvadd_no_underflow c t1 t2 \endmlh + Create a predicate that checks that the bit-wise signed addition + of \c t1 and \c t2 does not underflow. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvadd_no_underflow(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvsub_no_overflow c t1 t2 \endmlh + Create a predicate that checks that the bit-wise signed subtraction + of \c t1 and \c t2 does not overflow. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvsub_no_overflow(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvsub_no_underflow c t1 t2 is_signed \endmlh + Create a predicate that checks that the bit-wise subtraction + of \c t1 and \c t2 does not underflow. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvsub_no_underflow(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2, Z3_bool is_signed); + + /** + \brief \mlh mk_bvsdiv_no_overflow c t1 t2 \endmlh + Create a predicate that checks that the bit-wise signed division + of \c t1 and \c t2 does not overflow. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvsdiv_no_overflow(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_bvneg_no_overflow c t1 \endmlh + Check that bit-wise negation does not overflow when + \c t1 is interpreted as a signed bit-vector. + + The node \c t1 must have bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvneg_no_overflow(__in Z3_context c, __in Z3_ast t1); + + /** + \brief \mlh mk_bvmul_no_overflow c t1 t2 is_signed \endmlh + Create a predicate that checks that the bit-wise multiplication + of \c t1 and \c t2 does not overflow. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvmul_no_overflow(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2, Z3_bool is_signed); + + /** + \brief \mlh mk_bvmul_no_underflow c t1 t2 \endmlh + Create a predicate that checks that the bit-wise signed multiplication + of \c t1 and \c t2 does not underflow. + + The nodes \c t1 and \c t2 must have the same bit-vector sort. + */ + Z3_ast Z3_API Z3_mk_bvmul_no_underflow(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); + + /** + \brief \mlh mk_select c a i \endmlh + Array read. + + The node \c a must have an array sort [domain -> range], and \c i must have the sort \c domain. + The sort of the result is \c range. + + \sa Z3_mk_array_sort + \sa Z3_mk_store + */ + Z3_ast Z3_API Z3_mk_select(__in Z3_context c, __in Z3_ast a, __in Z3_ast i); + + /** + \brief \mlh mk_store c a i v \endmlh + Array update. + + The node \c a must have an array sort [domain -> range], \c i must have sort \c domain, + \c v must have sort range. The sort of the result is [domain -> range]. + + \sa Z3_mk_array_sort + \sa Z3_mk_select + */ + Z3_ast Z3_API Z3_mk_store(__in Z3_context c, __in Z3_ast a, __in Z3_ast i, __in Z3_ast v); + + /** + \brief Create the constant array. + + \param c logical context. + \param domain domain sort for the array. + \param v value that the array maps to. + */ + Z3_ast Z3_API Z3_mk_const_array(__in Z3_context c, __in Z3_sort domain, __in Z3_ast v); + + /** + \brief \mlh mk_map f n args \endmlh + map f on the the argument arrays. + + The \c n nodes \c args must be of array sorts [domain_i -> range_i]. + The function declaration \c f must have type range_1 .. range_n -> range. + \c v must have sort range. The sort of the result is [domain_i -> range]. + + \sa Z3_mk_array_sort + \sa Z3_mk_store + \sa Z3_mk_select + */ + Z3_ast Z3_API Z3_mk_map(__in Z3_context c, __in Z3_func_decl f, unsigned n, __in Z3_ast const* args); + + /** + \brief Access the array default value. + Produces the default range value, for arrays that can be represented as + finite maps with a default range value. + + \param c logical context. + \param array array value whose default range value is accessed. + + */ + Z3_ast Z3_API Z3_mk_array_default(__in Z3_context c, __in Z3_ast array); + + + /*@}*/ + + /** + @name Sets + */ + /*@{*/ + + /** + \brief Create Set type. + */ + Z3_sort Z3_API Z3_mk_set_sort(__in Z3_context c, __in Z3_sort ty); + + /** + \brief Create the empty set. + */ + Z3_ast Z3_API Z3_mk_empty_set(__in Z3_context c, __in Z3_sort domain); + + /** + \brief Create the full set. + */ + Z3_ast Z3_API Z3_mk_full_set(__in Z3_context c, __in Z3_sort domain); + + /** + \brief Add an element to a set. + + The first argument must be a set, the second an element. + */ + Z3_ast Z3_API Z3_mk_set_add(__in Z3_context c, __in Z3_ast set, __in Z3_ast elem); + + /** + \brief Remove an element to a set. + + The first argument must be a set, the second an element. + */ + Z3_ast Z3_API Z3_mk_set_del(__in Z3_context c, __in Z3_ast set, __in Z3_ast elem); + + /** + \brief Take the union of a list of sets. + */ + Z3_ast Z3_API Z3_mk_set_union(__in Z3_context c, __in unsigned num_args, __in_ecount(num_args) Z3_ast const args[]); + + /** + \brief Take the intersection of a list of sets. + */ + Z3_ast Z3_API Z3_mk_set_intersect(__in Z3_context c, __in unsigned num_args, __in_ecount(num_args) Z3_ast const args[]); + + /** + \brief Take the set difference between two sets. + */ + Z3_ast Z3_API Z3_mk_set_difference(__in Z3_context c, __in Z3_ast arg1, __in Z3_ast arg2); + + /** + \brief Take the complement of a set. + */ + Z3_ast Z3_API Z3_mk_set_complement(__in Z3_context c, __in Z3_ast arg); + + + /** + \brief Check for set membership. + + The first argument should be an element type of the set. + */ + Z3_ast Z3_API Z3_mk_set_member(__in Z3_context c, __in Z3_ast elem, __in Z3_ast set); + + /** + \brief Check for subsetness of sets. + */ + Z3_ast Z3_API Z3_mk_set_subset(__in Z3_context c, __in Z3_ast arg1, __in Z3_ast arg2); + /*@}*/ + + /** + @name Numerals + */ + /*@{*/ + + /** + \brief Create a numeral of a given sort. + + \param c logical context. + \param numeral A string representing the numeral value in decimal notation. If the given sort is a real, then the numeral can be a rational, that is, a string of the form [num]* / [num]*. + \param ty The sort of the numeral. In the current implementation, the given sort can be an int, real, or bit-vectors of arbitrary size. + + \sa Z3_mk_int + \sa Z3_mk_unsigned_int + */ + Z3_ast Z3_API Z3_mk_numeral(__in Z3_context c, __in_z Z3_string numeral, __in Z3_sort ty); + + /** + \brief Create a real from a fraction. + + \param c logical context. + \param num numerator of rational. + \param den denomerator of rational. + + \pre den != 0 + + \sa Z3_mk_numeral + \sa Z3_mk_int + \sa Z3_mk_unsigned_int + */ + Z3_ast Z3_API Z3_mk_real(__in Z3_context c, __in_z int num, __in_z int den); + + /** + \brief Create a numeral of a given sort. + + This function can be use to create numerals that fit in a machine integer. + It is slightly faster than #Z3_mk_numeral since it is not necessary to parse a string. + + \sa Z3_mk_numeral + */ + Z3_ast Z3_API Z3_mk_int(__in Z3_context c, __in int v, __in Z3_sort ty); + + /** + \brief Create a numeral of a given sort. + + This function can be use to create numerals that fit in a machine unsinged integer. + It is slightly faster than #Z3_mk_numeral since it is not necessary to parse a string. + + \sa Z3_mk_numeral + */ + Z3_ast Z3_API Z3_mk_unsigned_int(__in Z3_context c, __in unsigned v, __in Z3_sort ty); + +#ifndef CAMLIDL + /** + \brief Create a numeral of a given sort. + + This function can be use to create numerals that fit in a machine __int64 integer. + It is slightly faster than #Z3_mk_numeral since it is not necessary to parse a string. + + \sa Z3_mk_numeral + */ + Z3_ast Z3_API Z3_mk_int64(__in Z3_context c, __in __int64 v, __in Z3_sort ty); +#endif // CAMLIDL + +#ifndef CAMLIDL + /** + \brief Create a numeral of a given sort. + + This function can be use to create numerals that fit in a machine unsigned __int64 integer. + It is slightly faster than #Z3_mk_numeral since it is not necessary to parse a string. + + \sa Z3_mk_numeral + */ + Z3_ast Z3_API Z3_mk_unsigned_int64(__in Z3_context c, __in unsigned __int64 v, __in Z3_sort ty); +#endif // CAMLIDL + + /*@}*/ + + /** + @name Quantifiers + */ + /*@{*/ + + /** + \brief Create a pattern for quantifier instantiation. + + Z3 uses pattern matching to instantiate quantifiers. If a + pattern is not provided for a quantifier, then Z3 will + automatically compute a set of patterns for it. However, for + optimal performance, the user should provide the patterns. + + Patterns comprise a list of terms. The list should be + non-empty. If the list comprises of more than one term, it is + a called a multi-pattern. + + In general, one can pass in a list of (multi-)patterns in the + quantifier constructor. + + + \sa Z3_mk_forall + \sa Z3_mk_exists + */ + Z3_pattern Z3_API Z3_mk_pattern( + __in Z3_context c, + __in unsigned num_patterns, __in_ecount(num_patterns) Z3_ast const terms[]); + + /** + \brief Create a bound variable. + + Bound variables are indexed by de-Bruijn indices. It is perhaps easiest to explain + the meaning of de-Bruijn indices by indicating the compilation process from + non-de-Bruijn formulas to de-Bruijn format. + + \verbatim + abs(forall (x1) phi) = forall (x1) abs1(phi, x1, 0) + abs(forall (x1, x2) phi) = abs(forall (x1) abs(forall (x2) phi)) + abs1(x, x, n) = b_n + abs1(y, x, n) = y + abs1(f(t1,...,tn), x, n) = f(abs1(t1,x,n), ..., abs1(tn,x,n)) + abs1(forall (x1) phi, x, n) = forall (x1) (abs1(phi, x, n+1)) + \endverbatim + + The last line is significant: the index of a bound variable is different depending + on the scope in which it appears. The deeper x appears, the higher is its + index. + + \param c logical context + \param index de-Bruijn index + \param ty sort of the bound variable + + \sa Z3_mk_forall + \sa Z3_mk_exists + */ + Z3_ast Z3_API Z3_mk_bound(__in Z3_context c, __in unsigned index, __in Z3_sort ty); + + /** + \brief Create a forall formula. + + \mlonly [mk_forall c w p t n b] creates a forall formula, where + [w] is the weight, [p] is an array of patterns, [t] is an array + with the sorts of the bound variables, [n] is an array with the + 'names' of the bound variables, and [b] is the body of the + quantifier. Quantifiers are associated with weights indicating + the importance of using the quantifier during + instantiation. \endmlonly + + \param c logical context. + \param weight quantifiers are associated with weights indicating the importance of using the quantifier during instantiation. By default, pass the weight 0. + \param num_patterns number of patterns. + \param patterns array containing the patterns created using #Z3_mk_pattern. + \param num_decls number of variables to be bound. + \param sorts the sorts of the bound variables. + \param decl_names names of the bound variables + \param body the body of the quantifier. + + \sa Z3_mk_pattern + \sa Z3_mk_bound + \sa Z3_mk_exists + */ + Z3_ast Z3_API Z3_mk_forall(__in Z3_context c, __in unsigned weight, + __in unsigned num_patterns, __in_ecount(num_patterns) Z3_pattern const patterns[], + __in unsigned num_decls, __in_ecount(num_decls) Z3_sort const sorts[], + __in_ecount(num_decls) Z3_symbol const decl_names[], + __in Z3_ast body); + + /** + \brief Create an exists formula. Similar to #Z3_mk_forall. + + \sa Z3_mk_pattern + \sa Z3_mk_bound + \sa Z3_mk_forall + */ + Z3_ast Z3_API Z3_mk_exists(__in Z3_context c, __in unsigned weight, + __in unsigned num_patterns, __in_ecount(num_patterns) Z3_pattern const patterns[], + __in unsigned num_decls, __in_ecount(num_decls) Z3_sort const sorts[], + __in_ecount(num_decls) Z3_symbol const decl_names[], + __in Z3_ast body); + + /** + \brief Create a quantifier - universal or existential, with pattern hints. + + \param c logical context. + \param is_forall flag to indicate if this is a universal or existential quantifier. + \param weight quantifiers are associated with weights indicating the importance of using the quantifier during instantiation. By default, pass the weight 0. + \param num_patterns number of patterns. + \param patterns array containing the patterns created using #Z3_mk_pattern. + \param num_decls number of variables to be bound. + \param sorts array of sorts of the bound variables. + \param decl_names names of the bound variables. + \param body the body of the quantifier. + + \sa Z3_mk_pattern + \sa Z3_mk_bound + \sa Z3_mk_forall + \sa Z3_mk_exists + */ + + Z3_ast Z3_API Z3_mk_quantifier( + __in Z3_context c, + __in Z3_bool is_forall, + __in unsigned weight, + __in unsigned num_patterns, __in_ecount(num_patterns) Z3_pattern const* patterns, + __in unsigned num_decls, __in_ecount(num_decls) Z3_sort const* sorts, + __in_ecount(num_decls) Z3_symbol const* decl_names, + __in Z3_ast body); + + + /** + \brief Create a quantifier - universal or existential, with pattern hints, no patterns, and attributes + + \param c logical context. + \param is_forall flag to indicate if this is a universal or existential quantifier. + \param quantifier_id identifier to identify quantifier + \param skolem_id identifier to identify skolem constants introduced by quantifier. + \param weight quantifiers are associated with weights indicating the importance of using the quantifier during instantiation. By default, pass the weight 0. + \param num_patterns number of patterns. + \param patterns array containing the patterns created using #Z3_mk_pattern. + \param num_no_patterns number of patterns. + \param no_patterns array containing the patterns created using #Z3_mk_pattern. + \param num_decls number of variables to be bound. + \param sorts array of sorts of the bound variables. + \param decl_names names of the bound variables. + \param body the body of the quantifier. + + \sa Z3_mk_pattern + \sa Z3_mk_bound + \sa Z3_mk_forall + \sa Z3_mk_exists + */ + + Z3_ast Z3_API Z3_mk_quantifier_ex( + __in Z3_context c, + __in Z3_bool is_forall, + __in unsigned weight, + __in Z3_symbol quantifier_id, + __in Z3_symbol skolem_id, + __in unsigned num_patterns, __in_ecount(num_patterns) Z3_pattern const* patterns, + __in unsigned num_no_patterns, __in_ecount(num_no_patterns) Z3_ast const* no_patterns, + __in unsigned num_decls, __in_ecount(num_decls) Z3_sort const* sorts, + __in_ecount(num_decls) Z3_symbol const* decl_names, + __in Z3_ast body); + + /** + \brief Create a universal quantifier using a list of constants that + will form the set of bound variables. + + \param c logical context. + \param weight quantifiers are associated with weights indicating the importance of using + the quantifier during instantiation. By default, pass the weight 0. + \param num_bound number of constants to be abstracted into bound variables. + \param bound array of constants to be abstracted into bound variables. + \param num_patterns number of patterns. + \param patterns array containing the patterns created using #Z3_mk_pattern. + \param body the body of the quantifier. + + \sa Z3_mk_pattern + \sa Z3_mk_exists_const + + */ + + Z3_ast Z3_API Z3_mk_forall_const( + __in Z3_context c, + unsigned weight, + unsigned num_bound, + __in_ecount(num_bound) Z3_app const* bound, + unsigned num_patterns, + __in_ecount(num_patterns) Z3_pattern const* patterns, + __in Z3_ast body + ); + + /** + \brief Similar to #Z3_mk_forall_const. + + \brief Create an existential quantifier using a list of constants that + will form the set of bound variables. + + \param c logical context. + \param weight quantifiers are associated with weights indicating the importance of using + the quantifier during instantiation. By default, pass the weight 0. + \param num_bound number of constants to be abstracted into bound variables. + \param bound array of constants to be abstracted into bound variables. + \param num_patterns number of patterns. + \param patterns array containing the patterns created using #Z3_mk_pattern. + \param body the body of the quantifier. + + \sa Z3_mk_pattern + \sa Z3_mk_forall_const + */ + + Z3_ast Z3_API Z3_mk_exists_const( + __in Z3_context c, + unsigned weight, + unsigned num_bound, + __in_ecount(num_bound) Z3_app const* bound, + unsigned num_patterns, + __in_ecount(num_patterns) Z3_pattern const* patterns, + __in Z3_ast body + ); + + /** + \brief Create a universal or existential + quantifier using a list of constants that + will form the set of bound variables. + */ + + Z3_ast Z3_API Z3_mk_quantifier_const( + __in Z3_context c, + Z3_bool is_forall, + unsigned weight, + unsigned num_bound, __in_ecount(num_bound) Z3_app const* bound, + unsigned num_patterns, __in_ecount(num_patterns) Z3_pattern const* patterns, + __in Z3_ast body + ); + + + + /** + \brief Create a universal or existential + quantifier using a list of constants that + will form the set of bound variables. + */ + + Z3_ast Z3_API Z3_mk_quantifier_const_ex( + __in Z3_context c, + Z3_bool is_forall, + unsigned weight, + __in Z3_symbol quantifier_id, + __in Z3_symbol skolem_id, + unsigned num_bound, __in_ecount(num_bound) Z3_app const* bound, + unsigned num_patterns, __in_ecount(num_patterns) Z3_pattern const* patterns, + unsigned num_no_patterns, __in_ecount(num_no_patterns) Z3_ast const* no_patterns, + __in Z3_ast body + ); + + + + + /*@}*/ + + + /** + @name Accessors + */ + /*@{*/ + + /** + \brief Return a unique identifier for \c t. + */ + unsigned Z3_API Z3_get_ast_id(__in Z3_context c, Z3_ast t); + + /** + \brief Return a unique identifier for \c f. + */ + unsigned Z3_API Z3_get_func_decl_id(__in Z3_context c, Z3_func_decl f); + + /** + \brief Return a unique identifier for \c s. + */ + unsigned Z3_API Z3_get_sort_id(__in Z3_context c, Z3_sort s); + + + + /** + \brief Return true if the given expression \c t is well sorted. + */ + Z3_bool Z3_API Z3_is_well_sorted(__in Z3_context c, __in Z3_ast t); + + /** + \brief Return \c Z3_INT_SYMBOL if the symbol was constructed + using #Z3_mk_int_symbol, and \c Z3_STRING_SYMBOL if the symbol + was constructed using #Z3_mk_string_symbol. + */ + Z3_symbol_kind Z3_API Z3_get_symbol_kind(__in Z3_context c, __in Z3_symbol s); + + /** + \brief \mlh get_symbol_int c s \endmlh + Return the symbol int value. + + \pre Z3_get_symbol_kind(s) == Z3_INT_SYMBOL + + \sa Z3_mk_int_symbol + */ + int Z3_API Z3_get_symbol_int(__in Z3_context c, __in Z3_symbol s); + + /** + \brief \mlh get_symbol_string c s \endmlh + Return the symbol name. + + \pre Z3_get_symbol_string(s) == Z3_STRING_SYMBOL + + \conly \warning The returned buffer is statically allocated by Z3. It will + \conly be automatically deallocated when #Z3_del_context is invoked. + \conly So, the buffer is invalidated in the next call to \c Z3_get_symbol_string. + + \sa Z3_mk_string_symbol + */ + Z3_string Z3_API Z3_get_symbol_string(__in Z3_context c, __in Z3_symbol s); + + + /** + \brief Return the kind of the given AST. + */ + Z3_ast_kind Z3_API Z3_get_ast_kind(__in Z3_context c, __in Z3_ast a); + + + /** + \brief Return numeral value, as a string of a numeric constant term + + \pre Z3_get_ast_kind(c, a) == Z3_NUMERAL_AST + */ + Z3_string Z3_API Z3_get_numeral_string(__in Z3_context c, __in Z3_ast a); + + + /** + \brief Return numeral value, as a pair of 64 bit numbers if the representation fits. + + \param c logical context. + \param a term. + \param num numerator. + \param den denominator. + + Preturn \c Z3_TRUE if the numeral value fits in 64 bit numerals, \c Z3_FALSE otherwise. + + \pre Z3_get_ast_kind(a) == Z3_NUMERAL_AST + */ + Z3_bool Z3_API Z3_get_numeral_small(__in Z3_context c, __in Z3_ast a, __out __int64* num, __out __int64* den); + + + /** + \brief \mlh get_numeral_int c v \endmlh + Similar to #Z3_get_numeral_string, but only succeeds if + the value can fit in a machine int. Return Z3_TRUE if the call succeeded. + + \pre Z3_get_ast_kind(c, v) == Z3_NUMERAL_AST + + \sa Z3_get_numeral_string + */ + Z3_bool Z3_API Z3_get_numeral_int(__in Z3_context c, __in Z3_ast v, __out int* i); + + /** + \brief \mlh get_numeral_uint c v \endmlh + Similar to #Z3_get_numeral_string, but only succeeds if + the value can fit in a machine unsigned int. Return Z3_TRUE if the call succeeded. + + \pre Z3_get_ast_kind(c, v) == Z3_NUMERAL_AST + + \sa Z3_get_numeral_string + */ + Z3_bool Z3_API Z3_get_numeral_uint(__in Z3_context c, __in Z3_ast v, __out unsigned* u); + +#ifndef CAMLIDL + /** + \brief \mlh get_numeral_uint64 c v \endmlh + Similar to #Z3_get_numeral_string, but only succeeds if + the value can fit in a machine unsigned __int64 int. Return Z3_TRUE if the call succeeded. + + \pre Z3_get_ast_kind(c, v) == Z3_NUMERAL_AST + + \sa Z3_get_numeral_string + */ + Z3_bool Z3_API Z3_get_numeral_uint64(__in Z3_context c, __in Z3_ast v, __out unsigned __int64* u); +#endif // CAMLIDL + +#ifndef CAMLIDL + /** + \brief \mlh get_numeral_int64 c v \endmlh + Similar to #Z3_get_numeral_string, but only succeeds if + the value can fit in a machine __int64 int. Return Z3_TRUE if the call succeeded. + + \pre Z3_get_ast_kind(c, v) == Z3_NUMERAL_AST + + \sa Z3_get_numeral_string + */ + Z3_bool Z3_API Z3_get_numeral_int64(__in Z3_context c, __in Z3_ast v, __out __int64* i); +#endif // CAMLIDL + +#ifndef CAMLIDL + /** + \brief \mlh get_numeral_rational_int64 c x y\endmlh + Similar to #Z3_get_numeral_string, but only succeeds if + the value can fit as a reational number as machine __int64 int. Return Z3_TRUE if the call succeeded. + + \pre Z3_get_ast_kind(c, v) == Z3_NUMERAL_AST + + \sa Z3_get_numeral_string + */ + Z3_bool Z3_API Z3_get_numeral_rational_int64(__in Z3_context c, __in Z3_ast v, __out __int64* num, __out __int64* den); +#endif // CAMLIDL + + /** + \brief Return Z3_L_TRUE if \c a is true, Z3_L_FALSE if it is false, and Z3_L_UNDEF otherwise. + */ + Z3_lbool Z3_API Z3_get_bool_value(__in Z3_context c, __in Z3_ast a); + + /** + \brief Return the declaration of a constant or function application. + */ + Z3_func_decl Z3_API Z3_get_app_decl(__in Z3_context c, __in Z3_app a); + + /** + \brief \mlh get_app_num_args c a \endmlh + Return the number of argument of an application. If \c t + is an constant, then the number of arguments is 0. + */ + unsigned Z3_API Z3_get_app_num_args(__in Z3_context c, __in Z3_app a); + + /** + \brief \mlh get_app_arg c a i \endmlh + Return the i-th argument of the given application. + + \pre i < Z3_get_num_args(c, a) + */ + Z3_ast Z3_API Z3_get_app_arg(__in Z3_context c, __in Z3_app a, __in unsigned i); + + /** + \brief Return index of de-Brujin bound variable. + + \pre Z3_get_ast_kind(a) == Z3_VAR_AST + */ + unsigned Z3_API Z3_get_index_value(__in Z3_context c, __in Z3_ast a); + + /** + \brief Determine if quantifier is universal. + + \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST + */ + Z3_bool Z3_API Z3_is_quantifier_forall(__in Z3_context c, __in Z3_ast a); + + /** + \brief Obtain weight of quantifier. + + \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST + */ + unsigned Z3_API Z3_get_quantifier_weight(__in Z3_context c, __in Z3_ast a); + + /** + \brief Return number of patterns used in quantifier. + + \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST + */ + unsigned Z3_API Z3_get_quantifier_num_patterns(__in Z3_context c, __in Z3_ast a); + + /** + \brief Return i'th pattern. + + \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST + */ + Z3_pattern Z3_API Z3_get_quantifier_pattern_ast(__in Z3_context c, __in Z3_ast a, unsigned i); + + /** + \brief Return number of no_patterns used in quantifier. + + \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST + */ + unsigned Z3_API Z3_get_quantifier_num_no_patterns(__in Z3_context c, __in Z3_ast a); + + /** + \brief Return i'th no_pattern. + + \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST + */ + Z3_ast Z3_API Z3_get_quantifier_no_pattern_ast(__in Z3_context c, __in Z3_ast a, unsigned i); + + /** + \brief Return symbol of the i'th bound variable. + + \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST + */ + Z3_symbol Z3_API Z3_get_quantifier_bound_name(__in Z3_context c, __in Z3_ast a, unsigned i); + + /** + \brief Return sort of the i'th bound variable. + + \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST + */ + Z3_sort Z3_API Z3_get_quantifier_bound_sort(__in Z3_context c, __in Z3_ast a, unsigned i); + + /** + \brief Return body of quantifier. + + \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST + */ + Z3_ast Z3_API Z3_get_quantifier_body(__in Z3_context c, __in Z3_ast a); + + + + /** + \brief Return number of bound variables of quantifier. + + \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST + */ + unsigned Z3_API Z3_get_quantifier_num_bound(__in Z3_context c, __in Z3_ast a); + + /** + \brief Return the constant declaration name as a symbol. + */ + Z3_symbol Z3_API Z3_get_decl_name(__in Z3_context c, __in Z3_func_decl d); + + /** + \brief Return the number of parameters associated with a declaration. + */ + unsigned Z3_API Z3_get_decl_num_parameters(__in Z3_context c, __in Z3_func_decl d); + + /** + \brief Return the parameter type associated with a declaration. + + \param c the context + \param d the function declaration + \param idx is the index of the named parameter it should be between 0 and the number of parameters. + */ + Z3_parameter_kind Z3_API Z3_get_decl_parameter_kind(__in Z3_context c, __in Z3_func_decl d, unsigned idx); + + /** + \brief Return the integer value associated with an integer parameter. + + \pre Z3_get_decl_parameter_kind(c, d, idx) == Z3_PARAMETER_INT + */ + int Z3_API Z3_get_decl_int_parameter(__in Z3_context c, __in Z3_func_decl d, unsigned idx); + + /** + \brief Return the double value associated with an double parameter. + + \pre Z3_get_decl_parameter_kind(c, d, idx) == Z3_PARAMETER_DOUBLE + */ + double Z3_API Z3_get_decl_double_parameter(__in Z3_context c, __in Z3_func_decl d, unsigned idx); + + /** + \brief Return the double value associated with an double parameter. + + \pre Z3_get_decl_parameter_kind(c, d, idx) == Z3_PARAMETER_SYMBOL + */ + Z3_symbol Z3_API Z3_get_decl_symbol_parameter(__in Z3_context c, __in Z3_func_decl d, unsigned idx); + /** + \brief Return the sort value associated with a sort parameter. + + \pre Z3_get_decl_parameter_kind(c, d, idx) == Z3_PARAMETER_SORT + */ + Z3_sort Z3_API Z3_get_decl_sort_parameter(__in Z3_context c, __in Z3_func_decl d, unsigned idx); + + /** + \brief Return the expresson value associated with an expression parameter. + + \pre Z3_get_decl_parameter_kind(c, d, idx) == Z3_PARAMETER_AST + */ + Z3_ast Z3_API Z3_get_decl_ast_parameter(__in Z3_context c, __in Z3_func_decl d, unsigned idx); + + /** + \brief Return the expresson value associated with an expression parameter. + + \pre Z3_get_decl_parameter_kind(c, d, idx) == Z3_PARAMETER_FUNC_DECL + */ + Z3_func_decl Z3_API Z3_get_decl_func_decl_parameter(__in Z3_context c, __in Z3_func_decl d, unsigned idx); + + /** + \brief Return the rational value, as a string, associated with a rational parameter. + + \pre Z3_get_decl_parameter_kind(c, d, idx) == Z3_PARAMETER_RATIONAL + */ + Z3_string Z3_API Z3_get_decl_rational_parameter(__in Z3_context c, __in Z3_func_decl d, unsigned idx); + + /** + \brief Return the sort name as a symbol. + */ + Z3_symbol Z3_API Z3_get_sort_name(__in Z3_context c, __in Z3_sort d); + + /** + \brief Return the sort of an AST node. + + The AST node must be a constant, application, numeral, bound variable, or quantifier. + + */ + Z3_sort Z3_API Z3_get_sort(__in Z3_context c, __in Z3_ast a); + + /** + \brief Return the number of parameters of the given declaration. + + \sa Z3_get_domain_size + */ + unsigned Z3_API Z3_get_domain_size(__in Z3_context c, __in Z3_func_decl d); + + /** + \brief \mlh get_domain c d i \endmlh + Return the sort of the i-th parameter of the given function declaration. + + \pre i < Z3_get_domain_size(d) + + \sa Z3_get_domain_size + */ + Z3_sort Z3_API Z3_get_domain(__in Z3_context c, __in Z3_func_decl d, __in unsigned i); + + /** + \brief \mlh get_range c d \endmlh + Return the range of the given declaration. + + If \c d is a constant (i.e., has zero arguments), then this + function returns the sort of the constant. + */ + Z3_sort Z3_API Z3_get_range(__in Z3_context c, __in Z3_func_decl d); + + /** + \brief Return the sort kind (e.g., array, tuple, int, bool, etc). + + \sa Z3_sort_kind + */ + Z3_sort_kind Z3_API Z3_get_sort_kind(__in Z3_context c, __in Z3_sort t); + + /** + \brief \mlh get_bv_sort_size c t \endmlh + Return the size of the given bit-vector sort. + + \pre Z3_get_sort_kind(c, t) == Z3_BV_SORT + + \sa Z3_mk_bv_sort + \sa Z3_get_sort_kind + */ + unsigned Z3_API Z3_get_bv_sort_size(__in Z3_context c, __in Z3_sort t); + + /** + \brief \mlh get_array_sort_domain c t \endmlh + Return the domain of the given array sort. + + \pre Z3_get_sort_kind(c, t) == Z3_ARRAY_SORT + + \sa Z3_mk_array_sort + \sa Z3_get_sort_kind + */ + Z3_sort Z3_API Z3_get_array_sort_domain(__in Z3_context c, __in Z3_sort t); + + /** + \brief \mlh get_array_sort_range c t \endmlh + Return the range of the given array sort. + + \pre Z3_get_sort_kind(c, t) == Z3_ARRAY_SORT + + \sa Z3_mk_array_sort + \sa Z3_get_sort_kind + */ + Z3_sort Z3_API Z3_get_array_sort_range(__in Z3_context c, __in Z3_sort t); + + /** + \brief \mlh get_tuple_sort_mk_decl c t \endmlh + Return the constructor declaration of the given tuple + sort. + + \pre Z3_get_sort_kind(c, t) == Z3_DATATYPE_SORT + + \sa Z3_mk_tuple_sort + \sa Z3_get_sort_kind + */ + Z3_func_decl Z3_API Z3_get_tuple_sort_mk_decl(__in Z3_context c, __in Z3_sort t); + + /** + \brief Return declaration kind corresponding to declaration. + */ + Z3_decl_kind Z3_API Z3_get_decl_kind(__in Z3_context c, __in Z3_func_decl d); + + /** + \brief \mlh get_tuple_sort_num_fields c t \endmlh + Return the number of fields of the given tuple sort. + + \pre Z3_get_sort_kind(c, t) == Z3_DATATYPE_SORT + + \mlonly \remark Consider using the function {!Z3.get_tuple_sort}, which + returns a tuple: tuple constructor, and an array of the tuple sort fields. \endmlonly + + \sa Z3_mk_tuple_sort + \sa Z3_get_sort_kind + */ + unsigned Z3_API Z3_get_tuple_sort_num_fields(__in Z3_context c, __in Z3_sort t); + + /** + \brief \mlh get_tuple_sort_field_decl c t i \endmlh + Return the i-th field declaration (i.e., projection function declaration) + of the given tuple sort. + + \mlonly \remark Consider using the function {!Z3.get_tuple_sort}, which + returns a tuple: tuple constructor, and an array of the tuple sort fields. \endmlonly + + \pre Z3_get_sort_kind(t) == Z3_DATATYPE_SORT + \pre i < Z3_get_tuple_sort_num_fields(c, t) + + \sa Z3_mk_tuple_sort + \sa Z3_get_sort_kind + */ + Z3_func_decl Z3_API Z3_get_tuple_sort_field_decl(__in Z3_context c, __in Z3_sort t, __in unsigned i); + + /** + \brief Return number of constructors for datatype. + + \pre Z3_get_sort_kind(t) == Z3_DATATYPE_SORT + + \sa Z3_get_datatype_sort_constructor + \sa Z3_get_datatype_sort_recognizer + \sa Z3_get_datatype_sort_constructor_accessor + + */ + unsigned Z3_API Z3_get_datatype_sort_num_constructors( + __in Z3_context c, __in Z3_sort t); + + /** + \brief Return idx'th constructor. + + \pre Z3_get_sort_kind(t) == Z3_DATATYPE_SORT + \pre idx < Z3_get_datatype_sort_num_constructors(c, t) + + \sa Z3_get_datatype_sort_num_constructors + \sa Z3_get_datatype_sort_recognizer + \sa Z3_get_datatype_sort_constructor_accessor + + */ + Z3_func_decl Z3_API Z3_get_datatype_sort_constructor( + __in Z3_context c, __in Z3_sort t, unsigned idx); + + /** + \brief Return idx'th recognizer. + + \pre Z3_get_sort_kind(t) == Z3_DATATYPE_SORT + \pre idx < Z3_get_datatype_sort_num_constructors(c, t) + + \sa Z3_get_datatype_sort_num_constructors + \sa Z3_get_datatype_sort_constructor + \sa Z3_get_datatype_sort_constructor_accessor + + */ + Z3_func_decl Z3_API Z3_get_datatype_sort_recognizer( + __in Z3_context c, __in Z3_sort t, unsigned idx); + + /** + \brief Return idx_a'th accessor for the idx_c'th constructor. + + \pre Z3_get_sort_kind(t) == Z3_DATATYPE_SORT + \pre idx_c < Z3_get_datatype_sort_num_constructors(c, t) + \pre idx_a < Z3_get_domain_size(c, Z3_get_datatype_sort_constructor(c, idx_c)) + + \sa Z3_get_datatype_sort_num_constructors + \sa Z3_get_datatype_sort_constructor + \sa Z3_get_datatype_sort_recognizer + */ + Z3_func_decl Z3_API Z3_get_datatype_sort_constructor_accessor( + __in Z3_context c, __in Z3_sort t, unsigned idx_c, unsigned idx_a); + + + /** + \brief Return arity of relation. + + \pre Z3_get_sort_kind(s) == Z3_RELATION_SORT + + \sa Z3_get_relation_column + */ + + unsigned Z3_API Z3_get_relation_arity(__in Z3_context c, __in Z3_sort s); + + /** + \brief Return sort at i'th column of relation sort. + + \pre Z3_get_sort_kind(c, s) == Z3_RELATION_SORT + \pre col < Z3_get_relation_arity(c, s) + + \sa Z3_get_relation_arity + */ + Z3_sort Z3_API Z3_get_relation_column(__in Z3_context c, __in Z3_sort s, unsigned col); + + +#ifndef CAMLIDL + /** + \brief Store the size of the sort in \c r. Return Z3_TRUE if the call succeeded. + That is, Z3_get_sort_kind(s) == Z3_FINITE_DOMAIN_SORT + */ + Z3_bool Z3_API Z3_get_finite_domain_sort_size(__in Z3_context c, __in Z3_sort s, __out unsigned __int64* r); +#endif + + /** + \brief Return number of terms in pattern. + */ + unsigned Z3_API Z3_get_pattern_num_terms(__in Z3_context c, __in Z3_pattern p); + + /** + \brief Return i'th ast in pattern. + */ + Z3_ast Z3_API Z3_get_pattern(__in Z3_context c, __in Z3_pattern p, __in unsigned idx); + + + + /** + \brief Interface to simplifier. + + Provides an interface to the AST simplifier used by Z3. + It allows clients to piggyback on top of the AST simplifier + for their own term manipulation. + */ + Z3_ast Z3_API Z3_simplify(__in Z3_context c, __in Z3_ast a); + + /*@}*/ + + /** + @name Modifiers + */ + /*@{*/ + + /** + \brief Update the arguments of term \c a using the arguments \c args. + The number of arguments \c num_args should coincide + with the number of arguments to \c a. + If \c a is a quantifier, then num_args has to be 1. + */ + Z3_ast Z3_API Z3_update_term(__in Z3_context c, __in Z3_ast a, __in unsigned num_args, __in_ecount(num_args) Z3_ast args[]); + + /** + \brief Substitute every occurrence of from[i] in \c a with to[i], for \c i smaller than \c num_exprs. + The result is the new AST. The arrays \c from and \c to must have size \c num_exprs. + For every \c i smaller than \c num_exprs, we must have that sort of from[i] must be equal to sort of to[i]. + */ + Z3_ast Z3_API Z3_substitute(__in Z3_context c, + __in Z3_ast a, + __in unsigned num_exprs, + __in_ecount(num_exprs) Z3_ast from[], + __in_ecount(num_exprs) Z3_ast to[]); + + /** + \brief Substitute the free variables in \c a with the expressions in \c to. + For every \c i smaller than \c num_exprs, the variable with de-Bruijn index \c i is replaced with term to[i]. + */ + Z3_ast Z3_API Z3_substitute_vars(__in Z3_context c, + __in Z3_ast a, + __in unsigned num_exprs, + __in_ecount(num_exprs) Z3_ast to[]); + + /*@}*/ + + + + /** + @name Coercions + */ + /*@{*/ + + /** + \brief Convert a Z3_sort into Z3_ast. This is just type casting. + */ + Z3_ast Z3_API Z3_sort_to_ast(__in Z3_context c, __in Z3_sort s); + + /** + \brief Convert a Z3_func_decl into Z3_ast. This is just type casting. + */ + Z3_ast Z3_API Z3_func_decl_to_ast(__in Z3_context c, __in Z3_func_decl f); + + /** + \brief Convert a Z3_pattern into Z3_ast. This is just type casting. + */ + Z3_ast Z3_API Z3_pattern_to_ast(__in Z3_context c, __in Z3_pattern p); + + /** + \brief Convert a APP_AST into an AST. This is just type casting. + */ + Z3_ast Z3_API Z3_app_to_ast(__in Z3_context c, __in Z3_app a); + + /** + \brief Convert an AST into a APP_AST. This is just type casting. + + \warning This conversion is only safe if #Z3_get_ast_kind returns \c Z3_app. + */ + Z3_app Z3_API Z3_to_app(__in Z3_context c, __in Z3_ast a); + + /*@}*/ + + /** + @name Constraints + */ + /*@{*/ + + /** + \brief Create a backtracking point. + + The logical context can be viewed as a stack of contexts. The + scope level is the number of elements on this stack. The stack + of contexts is simulated using trail (undo) stacks. + + \sa Z3_pop + */ + void Z3_API Z3_push(__in Z3_context c); + + /** + \brief Backtrack. + + Restores the context from the top of the stack, and pops it off the + stack. Any changes to the logical context (by #Z3_assert_cnstr or + other functions) between the matching #Z3_push and \c Z3_pop + operators are flushed, and the context is completely restored to + what it was right before the #Z3_push. + + \sa Z3_push + */ + void Z3_API Z3_pop(__in Z3_context c, __in unsigned num_scopes); + + + /** + \brief Retrieve the current scope level. + + It retrieves the number of scopes that have been pushed, but not yet popped. + + \sa Z3_push + \sa Z3_pop + */ + unsigned Z3_API Z3_get_num_scopes(__in Z3_context c); + + /** + \brief Persist AST through num_scopes pops. + This function is only relevant if \c c was created using #Z3_mk_context. + If \c c was created using #Z3_mk_context_rc, this function is a NOOP. + + Normally, for contexts created using #Z3_mk_context, + references to terms are no longer valid when + popping scopes beyond the level where the terms are created. + If you want to reference a term below the scope where it + was created, use this method to specify how many pops + the term should survive. + The num_scopes should be at most equal to the number of + calls to Z3_push subtracted with the calls to Z3_pop. + */ + void Z3_API Z3_persist_ast(__in Z3_context c, __in Z3_ast a, __in unsigned num_scopes); + + + /** + \brief Assert a constraing into the logical context. + + After one assertion, the logical context may become + inconsistent. + + The functions #Z3_check or #Z3_check_and_get_model should be + used to check whether the logical context is consistent or not. + + \sa Z3_check + \sa Z3_check_and_get_model + */ + void Z3_API Z3_assert_cnstr(__in Z3_context c, __in Z3_ast a); + + /** + \brief Check whether the given logical context is consistent or not. + + If the logical context is not unsatisfiable (i.e., the return value is different from \c Z3_L_FALSE) + and model construction is enabled (see #Z3_mk_config), then a model is stored in \c m. Otherwise, + the value \c 0 is stored in \c m. + The caller is responsible for deleting the model using the function #Z3_del_model. + + \remark Model construction must be enabled using configuration + parameters (See, #Z3_mk_config). + + \sa Z3_check + \sa Z3_del_model + */ + Z3_lbool Z3_API Z3_check_and_get_model(__in Z3_context c, __out Z3_model * m); + + /** + \brief Check whether the given logical context is consistent or not. + + The function #Z3_check_and_get_model should be used when models are needed. + + \sa Z3_check_and_get_model + */ + Z3_lbool Z3_API Z3_check(__in Z3_context c); + + /** + \brief Check whether the given logical context and optional assumptions is consistent or not. + + If the logical context is not unsatisfiable (i.e., the return value is different from \c Z3_L_FALSE), + a non-0 model argument is passed in, + and model construction is enabled (see #Z3_mk_config), then a model is stored in \c m. + Otherwise, \c m is left unchanged. + The caller is responsible for deleting the model using the function #Z3_del_model. + + \remark If the model argument is non-0, then model construction must be enabled using configuration + parameters (See, #Z3_mk_config). + + \param c logical context. + \param num_assumptions number of auxiliary assumptions. + \param assumptions array of auxiliary assumptions + \param m optional pointer to a model. + \param proof optional pointer to a proof term. + \param core_size size of unsatisfiable core. + \param core pointer to an array receiveing unsatisfiable core. + The unsatisfiable core is a subset of the assumptions, so the array has the same size as the assumptions. + The \c core array is not populated if \c core_size is set to 0. + + \pre assumptions comprises of propositional literals. + In other words, you cannot use compound formulas for assumptions, + but should use propositional variables or negations of propositional variables. + + \sa Z3_check + \sa Z3_del_model + */ + Z3_lbool Z3_API Z3_check_assumptions( + __in Z3_context c, + __in unsigned num_assumptions, __in_ecount(num_assumptions) Z3_ast assumptions[], + __out Z3_model * m, __out Z3_ast* proof, + __inout unsigned* core_size, __inout_ecount(num_assumptions) Z3_ast core[] + ); + + /** + \brief Retrieve congruence class representatives for terms. + + The function can be used for relying on Z3 to identify equal terms under the current + set of assumptions. The array of terms and array of class identifiers should have + the same length. The class identifiers are numerals that are assigned to the same + value for their corresponding terms if the current context forces the terms to be + equal. You cannot deduce that terms corresponding to different numerals must be all different, + (especially when using non-convex theories). + All implied equalities are returned by this call. + This means that two terms map to the same class identifier if and only if + the current context implies that they are equal. + + A side-effect of the function is a satisfiability check. + The function return Z3_L_FALSE if the current assertions are not satisfiable. + + \sa Z3_check_and_get_model + \sa Z3_check + */ + + Z3_lbool Z3_API Z3_get_implied_equalities( + __in Z3_context c, + __in unsigned num_terms, + __in_ecount(num_terms) Z3_ast terms[], + __out_ecount(num_terms) unsigned class_ids[] + ); + + + /** + \brief Delete a model object. + + \sa Z3_check_and_get_model + */ + void Z3_API Z3_del_model(__in Z3_context c, __in Z3_model m); + + /** + @name Search control. + */ + /*@{*/ + /** + \brief Cancel an ongoing check. + + Notifies the current check to abort and return. + This method should be called from a different thread + than the one performing the check. + */ + + void Z3_API Z3_soft_check_cancel(__in Z3_context c); + /*@}*/ + + /*@{*/ + + /** + \brief Retrieve reason for search failure. + + If a call to #Z3_check or #Z3_check_and_get_model returns Z3_L_UNDEF, + use this facility to determine the more detailed cause of search failure. + */ + Z3_search_failure Z3_API Z3_get_search_failure(__in Z3_context c); + + /*@}*/ + + + /** + @name Labels. + */ + /*@{*/ + /** + \brief Retrieve the set of labels that were relevant in + the context of the current satisfied context. + + \sa Z3_del_literals + \sa Z3_get_num_literals + \sa Z3_get_label_symbol + \sa Z3_get_literal + */ + Z3_literals Z3_API Z3_get_relevant_labels(__in Z3_context c); + + /** + \brief Retrieve the set of literals that satisfy the current context. + + \sa Z3_del_literals + \sa Z3_get_num_literals + \sa Z3_get_label_symbol + \sa Z3_get_literal + */ + Z3_literals Z3_API Z3_get_relevant_literals(__in Z3_context c); + + /** + \brief Retrieve the set of literals that whose assignment were + guess, but not propagated during the search. + + \sa Z3_del_literals + \sa Z3_get_num_literals + \sa Z3_get_label_symbol + \sa Z3_get_literal + */ + Z3_literals Z3_API Z3_get_guessed_literals(__in Z3_context c); + + + /** + \brief Delete a labels context. + + \sa Z3_get_relevant_labels + */ + void Z3_API Z3_del_literals(__in Z3_context c, __in Z3_literals lbls); + + /** + \brief Retrieve the number of label symbols that were returned. + + \sa Z3_get_relevant_labels + */ + unsigned Z3_API Z3_get_num_literals(__in Z3_context c, __in Z3_literals lbls); + + /** + \brief Retrieve label symbol at idx. + */ + Z3_symbol Z3_API Z3_get_label_symbol(__in Z3_context c, __in Z3_literals lbls, __in unsigned idx); + + /** + \brief Retrieve literal expression at idx. + */ + Z3_ast Z3_API Z3_get_literal(__in Z3_context c, __in Z3_literals lbls, __in unsigned idx); + + /** + \brief Disable label. + + The disabled label is not going to be used when blocking the subsequent search. + + \sa Z3_block_literals + */ + void Z3_API Z3_disable_literal(__in Z3_context c, __in Z3_literals lbls, __in unsigned idx); + + /** + \brief Block subsequent checks using the remaining enabled labels. + */ + void Z3_API Z3_block_literals(__in Z3_context c, __in Z3_literals lbls); + + /*@}*/ + + + + /** + @name Model navigation + */ + /*@{*/ + + /** + \brief Return the number of constants assigned by the given model. + + \mlonly \remark Consider using {!Z3.get_model_constants}. \endmlonly + + \sa Z3_get_model_constant + */ + unsigned Z3_API Z3_get_model_num_constants(__in Z3_context c, __in Z3_model m); + + /** + \brief \mlh get_model_constant c m i \endmlh + Return the i-th constant in the given model. + + \mlonly \remark Consider using {!Z3.get_model_constants}. \endmlonly + + \pre i < Z3_get_model_num_constants(c, m) + + \sa Z3_eval + */ + Z3_func_decl Z3_API Z3_get_model_constant(__in Z3_context c, __in Z3_model m, __in unsigned i); + + /** + \brief Return the value of the given constant or function + in the given model. + + */ + Z3_bool Z3_API Z3_eval_func_decl(__in Z3_context c, __in Z3_model m, __in Z3_func_decl decl, __out Z3_ast* v); + + + /** + \brief \mlh is_array_value c v \endmlh + Determine whether the term encodes an array value. + Return the number of entries mapping to non-default values of the array. + */ + Z3_bool Z3_API Z3_is_array_value(__in Z3_context c, __in Z3_model m, __in Z3_ast v, __out unsigned* num_entries); + + + /** + \brief \mlh get_array_value c v \endmlh + An array values is represented as a dictionary plus a + default (else) value. This function returns the array graph. + + \pre Z3_TRUE == Z3_is_array_value(c, v, &num_entries) + */ + void Z3_API Z3_get_array_value(__in Z3_context c, + __in Z3_model m, + __in Z3_ast v, + __in unsigned num_entries, + __inout_ecount(num_entries) Z3_ast indices[], + __inout_ecount(num_entries) Z3_ast values[], + __out Z3_ast* else_value + ); + + + /** + \brief Return the number of function interpretations in the given model. + + A function interpretation is represented as a finite map and an 'else' value. + Each entry in the finite map represents the value of a function given a set of arguments. + + \mlonly \remark Consider using {!Z3.get_model_funcs}. \endmlonly + + \sa Z3_get_model_func_decl + \sa Z3_get_model_func_else + \sa Z3_get_model_func_num_entries + \sa Z3_get_model_func_entry_num_args + \sa Z3_get_model_func_entry_arg + */ + unsigned Z3_API Z3_get_model_num_funcs(__in Z3_context c, __in Z3_model m); + + + /** + \brief \mlh get_model_func_decl c m i \endmlh + Return the declaration of the i-th function in the given model. + + \mlonly \remark Consider using {!Z3.get_model_funcs}. \endmlonly + + \pre i < Z3_get_model_num_funcs(c, m) + + \sa Z3_get_model_num_funcs + */ + Z3_func_decl Z3_API Z3_get_model_func_decl(__in Z3_context c, __in Z3_model m, __in unsigned i); + + /** + \brief \mlh get_model_func_else c m i \endmlh + Return the 'else' value of the i-th function interpretation in the given model. + + A function interpretation is represented as a finite map and an 'else' value. + + \mlonly \remark Consider using {!Z3.get_model_funcs}. \endmlonly + + \pre i < Z3_get_model_num_funcs(c, m) + + \sa Z3_get_model_num_funcs + \sa Z3_get_model_func_num_entries + \sa Z3_get_model_func_entry_num_args + \sa Z3_get_model_func_entry_arg + */ + Z3_ast Z3_API Z3_get_model_func_else(__in Z3_context c, __in Z3_model m, __in unsigned i); + + /** + \brief \mlh get_model_func_num_entries c m i \endmlh + Return the number of entries of the i-th function interpretation in the given model. + + A function interpretation is represented as a finite map and an 'else' value. + + \mlonly \remark Consider using {!Z3.get_model_funcs}. \endmlonly + + \pre i < Z3_get_model_num_funcs(c, m) + + \sa Z3_get_model_num_funcs + \sa Z3_get_model_func_else + \sa Z3_get_model_func_entry_num_args + \sa Z3_get_model_func_entry_arg + */ + unsigned Z3_API Z3_get_model_func_num_entries(__in Z3_context c, __in Z3_model m, __in unsigned i); + + + /** + \brief \mlh get_model_func_entry_num_args c m i j \endmlh + Return the number of arguments of the j-th entry of the i-th function interpretation in the given + model. + + A function interpretation is represented as a finite map and an 'else' value. + This function returns the j-th entry of this map. + + An entry represents the value of a function given a set of arguments. + \conly That is: it has the following format f(args[0],...,args[num_args - 1]) = val. + + \mlonly \remark Consider using {!Z3.get_model_funcs}. \endmlonly + + \pre i < Z3_get_model_num_funcs(c, m) + \pre j < Z3_get_model_func_num_entries(c, m, i) + + \sa Z3_get_model_num_funcs + \sa Z3_get_model_func_num_entries + \sa Z3_get_model_func_entry_arg + */ + unsigned Z3_API Z3_get_model_func_entry_num_args(__in Z3_context c, + __in Z3_model m, + __in unsigned i, + __in unsigned j); + + /** + \brief \mlh get_model_func_entry_arg c m i j k \endmlh + Return the k-th argument of the j-th entry of the i-th function interpretation in the given + model. + + A function interpretation is represented as a finite map and an 'else' value. + This function returns the j-th entry of this map. + + An entry represents the value of a function given a set of arguments. + \conly That is: it has the following format f(args[0],...,args[num_args - 1]) = val. + + \mlonly \remark Consider using {!Z3.get_model_funcs}. \endmlonly + + \pre i < Z3_get_model_num_funcs(c, m) + \pre j < Z3_get_model_func_num_entries(c, m, i) + \pre k < Z3_get_model_func_entry_num_args(c, m, i, j) + + \sa Z3_get_model_num_funcs + \sa Z3_get_model_func_num_entries + \sa Z3_get_model_func_entry_num_args + */ + Z3_ast Z3_API Z3_get_model_func_entry_arg(__in Z3_context c, + __in Z3_model m, + __in unsigned i, + __in unsigned j, + __in unsigned k); + + /** + \brief \mlh get_model_func_entry_value c m i j \endmlh + Return the return value of the j-th entry of the i-th function interpretation in the given + model. + + A function interpretation is represented as a finite map and an 'else' value. + This function returns the j-th entry of this map. + + An entry represents the value of a function given a set of arguments. + \conly That is: it has the following format f(args[0],...,args[num_args - 1]) = val. + + \mlonly \remark Consider using {!Z3.get_model_funcs}. \endmlonly + + \pre i < Z3_get_model_num_funcs(c, m) + \pre j < Z3_get_model_func_num_entries(c, m, i) + + \sa Z3_get_model_num_funcs + \sa Z3_get_model_func_num_entries + */ + Z3_ast Z3_API Z3_get_model_func_entry_value(__in Z3_context c, + __in Z3_model m, + __in unsigned i, + __in unsigned j); + + /** + \brief \mlh eval c m t \endmlh + Evaluate the AST node \c t in the given model. + \conly Return \c Z3_TRUE if succeeded, and store the result in \c v. + \mlonly Return a pair: Boolean and value. The Boolean is true if the term was successfully evaluated. \endmlonly + + The evaluation may fail for the following reasons: + + - \c t contains a quantifier. + + - the model \c m is partial, that is, it doesn't have a complete interpretation for uninterpreted functions. + That is, the option MODEL_PARTIAL=true was used. + + - \c t is type incorrect. + */ + Z3_bool Z3_API Z3_eval(__in Z3_context c, __in Z3_model m, __in Z3_ast t, __out Z3_ast * v); + + /** + \brief Evaluate declaration given values. + + Provides direct way to evaluate declarations + without going over terms. + */ + Z3_bool Z3_API Z3_eval_decl(__in Z3_context c, __in Z3_model m, + __in Z3_func_decl d, + __in unsigned num_args, + __in_ecount(num_args) Z3_ast args[], + __out Z3_ast* v); + + + + + /*@}*/ + + /** + @name Interaction logging. + */ + /*@{*/ + + /** + \brief Log interaction to a file. + */ + Z3_bool Z3_API Z3_open_log(__in Z3_context c, __in_z Z3_string filename); + + /** + \brief Append user-defined string to interaction log. + + The interaction log is opened using Z3_open_log. + It contains the formulas that are checked using Z3. + You can use this command to append comments, for instance. + */ + void Z3_API Z3_append_log(__in Z3_context c, __in_z Z3_string string); + + + /** + \brief Close interaction log. + */ + void Z3_API Z3_close_log(__in Z3_context c); + /*@}*/ + + + /** + @name String conversion + */ + /*@{*/ + + /** + \brief Select mode for the format used for pretty-printing AST nodes. + + The default mode for pretty printing AST nodes is to produce + SMT-LIB style output where common subexpressions are printed + at each occurrence. The mode is called Z3_PRINT_SMTLIB_FULL. + To print shared common subexpressions only once, + use the Z3_PRINT_LOW_LEVEL mode. + To print in way that conforms to SMT-LIB standards and uses let + expressions to share common sub-expressions use Z3_PRINT_SMTLIB_COMPLIANT. + + \sa Z3_ast_to_string + \sa Z3_pattern_to_string + \sa Z3_func_decl_to_string + + */ + void Z3_API Z3_set_ast_print_mode(__in Z3_context c, __in Z3_ast_print_mode mode); + + /** + \brief Convert the given AST node into a string. + + \conly \warning The result buffer is statically allocated by Z3. It will + \conly be automatically deallocated when #Z3_del_context is invoked. + \conly So, the buffer is invalidated in the next call to \c Z3_ast_to_string. + \sa Z3_pattern_to_string + \sa Z3_sort_to_string + */ + Z3_string Z3_API Z3_ast_to_string(__in Z3_context c, __in Z3_ast a); + Z3_string Z3_API Z3_pattern_to_string(__in Z3_context c, __in Z3_pattern p); + Z3_string Z3_API Z3_sort_to_string(__in Z3_context c, __in Z3_sort s); + Z3_string Z3_API Z3_func_decl_to_string(__in Z3_context c, __in Z3_func_decl d); + + /** + \brief Convert the given model into a string. + + \conly \warning The result buffer is statically allocated by Z3. It will + \conly be automatically deallocated when #Z3_del_context is invoked. + \conly So, the buffer is invalidated in the next call to \c Z3_model_to_string. + */ + Z3_string Z3_API Z3_model_to_string(__in Z3_context c, __in Z3_model m); + + /** + \brief Convert the given benchmark into SMT-LIB formatted string. + + \conly \warning The result buffer is statically allocated by Z3. It will + \conly be automatically deallocated when #Z3_del_context is invoked. + \conly So, the buffer is invalidated in the next call to \c Z3_benchmark_to_smtlib_string. + + \param c - context. + \param name - name of benchmark. The argument is optional. + \param logic - the benchmark logic. + \param status - the status string (sat, unsat, or unknown) + \param attributes - other attributes, such as source, difficulty or category. + \param num_assumptions - number of assumptions. + \param assumptions - auxiliary assumptions. + \param formula - formula to be checked for consistency in conjunction with assumptions. + */ + Z3_string Z3_API Z3_benchmark_to_smtlib_string(__in Z3_context c, + __in_z Z3_string name, + __in_z Z3_string logic, + __in_z Z3_string status, + __in_z Z3_string attributes, + __in unsigned num_assumptions, + __in_ecount(num_assumptions) Z3_ast assumptions[], + __in Z3_ast formula); + + + /** + \brief Convert the given logical context into a string. + + This function is mainly used for debugging purposes. It displays + the internal structure of a logical context. + + \conly \warning The result buffer is statically allocated by Z3. It will + \conly be automatically deallocated when #Z3_del_context is invoked. + \conly So, the buffer is invalidated in the next call to \c Z3_context_to_string. + */ + Z3_string Z3_API Z3_context_to_string(__in Z3_context c); + + + /** + \brief Return runtime statistics as a string. + + This function is mainly used for debugging purposes. It displays + statistics of the search activity. + + \conly \warning The result buffer is statically allocated by Z3. It will + \conly be automatically deallocated when #Z3_del_context is invoked. + \conly So, the buffer is invalidated in the next call to \c Z3_context_to_string. + */ + Z3_string Z3_API Z3_statistics_to_string(__in Z3_context c); + + + /** + \brief Extract satisfying assignment from context as a conjunction. + + This function can be used for debugging purposes. It returns a conjunction + of formulas that are assigned to true in the current context. + This conjunction will contain not only the assertions that are set to true + under the current assignment, but will also include additional literals + if there has been a call to #Z3_check or #Z3_check_and_get_model. + */ + Z3_ast Z3_API Z3_get_context_assignment(__in Z3_context c); + + /*@}*/ + + /** + @name Parser interface + */ + /*@{*/ + /** + \brief \mlh parse_smtlib_string c str sort_names sorts decl_names decls \endmlh + Parse the given string using the SMT-LIB parser. + + The symbol table of the parser can be initialized using the given sorts and declarations. + The symbols in the arrays \c sort_names and \c decl_names don't need to match the names + of the sorts and declarations in the arrays \c sorts and \c decls. This is an useful feature + since we can use arbitrary names to reference sorts and declarations defined using the C API. + + The formulas, assumptions and declarations defined in \c str can be extracted using the functions: + #Z3_get_smtlib_num_formulas, #Z3_get_smtlib_formula, #Z3_get_smtlib_num_assumptions, #Z3_get_smtlib_assumption, + #Z3_get_smtlib_num_decls, and #Z3_get_smtlib_decl. + */ + void Z3_API Z3_parse_smtlib_string(__in Z3_context c, + __in_z Z3_string str, + __in unsigned num_sorts, + __in_ecount(num_sorts) Z3_symbol sort_names[], + __in_ecount(num_sorts) Z3_sort sorts[], + __in unsigned num_decls, + __in_ecount(num_decls) Z3_symbol decl_names[], + __in_ecount(num_decls) Z3_func_decl decls[] + ); + + /** + \brief Similar to #Z3_parse_smtlib_string, but reads the benchmark from a file. + */ + void Z3_API Z3_parse_smtlib_file(__in Z3_context c, + __in_z Z3_string file_name, + __in unsigned num_sorts, + __in_ecount(num_sorts) Z3_symbol sort_names[], + __in_ecount(num_sorts) Z3_sort sorts[], + __in unsigned num_decls, + __in_ecount(num_decls) Z3_symbol decl_names[], + __in_ecount(num_decls) Z3_func_decl decls[] + ); + + /** + \brief Return the number of SMTLIB formulas parsed by the last call to #Z3_parse_smtlib_string or #Z3_parse_smtlib_file. + */ + unsigned Z3_API Z3_get_smtlib_num_formulas(__in Z3_context c); + + /** + \brief \mlh get_smtlib_formula c i \endmlh + Return the i-th formula parsed by the last call to #Z3_parse_smtlib_string or #Z3_parse_smtlib_file. + + \pre i < Z3_get_smtlib_num_formulas(c) + */ + Z3_ast Z3_API Z3_get_smtlib_formula(__in Z3_context c, __in unsigned i); + + /** + \brief Return the number of SMTLIB assumptions parsed by #Z3_parse_smtlib_string or #Z3_parse_smtlib_file. + */ + unsigned Z3_API Z3_get_smtlib_num_assumptions(__in Z3_context c); + + /** + \brief \mlh get_smtlib_assumption c i \endmlh + Return the i-th assumption parsed by the last call to #Z3_parse_smtlib_string or #Z3_parse_smtlib_file. + + \pre i < Z3_get_smtlib_num_assumptions(c) + */ + Z3_ast Z3_API Z3_get_smtlib_assumption(__in Z3_context c, __in unsigned i); + + /** + \brief Return the number of declarations parsed by #Z3_parse_smtlib_string or #Z3_parse_smtlib_file. + */ + unsigned Z3_API Z3_get_smtlib_num_decls(__in Z3_context c); + + /** + \brief \mlh get_smtlib_decl c i \endmlh + Return the i-th declaration parsed by the last call to #Z3_parse_smtlib_string or #Z3_parse_smtlib_file. + + \pre i < Z3_get_smtlib_num_decls(c) + */ + Z3_func_decl Z3_API Z3_get_smtlib_decl(__in Z3_context c, __in unsigned i); + + /** + \brief Return the number of sorts parsed by #Z3_parse_smtlib_string or #Z3_parse_smtlib_file. + */ + unsigned Z3_API Z3_get_smtlib_num_sorts(__in Z3_context c); + + /** + \brief \mlh get_smtlib_sort c i \endmlh + Return the i-th sort parsed by the last call to #Z3_parse_smtlib_string or #Z3_parse_smtlib_file. + + \pre i < Z3_get_smtlib_num_sorts(c) + */ + Z3_sort Z3_API Z3_get_smtlib_sort(__in Z3_context c, __in unsigned i); + + /** + \brief \mlh get_smtlib_error c \endmlh + Retrieve that last error message information generated from parsing. + */ + Z3_string Z3_API Z3_get_smtlib_error(__in Z3_context c); + + /** + \brief \mlh parse_z3_string c str \endmlh + Parse the given string using the Z3 native parser. + + Return the conjunction of asserts made in the input. + */ + Z3_ast Z3_API Z3_parse_z3_string(__in Z3_context c, __in_z Z3_string str); + + /** + \brief Similar to #Z3_parse_z3_string, but reads the benchmark from a file. + */ + Z3_ast Z3_API Z3_parse_z3_file(__in Z3_context c, __in_z Z3_string file_name); + + /** + \brief \mlh parse_smtlib2_string c str \endmlh + Parse the given string using the SMT-LIB2 parser. + + It returns a formula comprising of the conjunction of assertions in the scope + (up to push/pop) at the end of the string. + */ + Z3_ast Z3_API Z3_parse_smtlib2_string(__in Z3_context c, + __in_z Z3_string str, + __in unsigned num_sorts, + __in_ecount(num_sorts) Z3_symbol sort_names[], + __in_ecount(num_sorts) Z3_sort sorts[], + __in unsigned num_decls, + __in_ecount(num_decls) Z3_symbol decl_names[], + __in_ecount(num_decls) Z3_func_decl decls[] + ); + + /** + \brief Similar to #Z3_parse_smtlib2_string, but reads the benchmark from a file. + */ + Z3_ast Z3_API Z3_parse_smtlib2_file(__in Z3_context c, + __in_z Z3_string file_name, + __in unsigned num_sorts, + __in_ecount(num_sorts) Z3_symbol sort_names[], + __in_ecount(num_sorts) Z3_sort sorts[], + __in unsigned num_decls, + __in_ecount(num_decls) Z3_symbol decl_names[], + __in_ecount(num_decls) Z3_func_decl decls[] + ); + + +#ifndef CAMLIDL + /** + \brief \mlh parse_simplify_string c str \endmlh + Parse the given string using the Simplify parser. + + Return the conjunction of asserts made in the input. + */ + Z3_ast Z3_API Z3_parse_simplify_string(__in Z3_context c, __in_z Z3_string str, __out Z3_string* parser_output); + + /** + \brief Similar to #Z3_parse_simplify_string, but reads the benchmark from a file. + */ + Z3_ast Z3_API Z3_parse_simplify_file(__in Z3_context c, __in_z Z3_string file_name, __out Z3_string* parser_output); +#endif // CAMLIDL + + /*@}*/ + +#ifndef CAMLIDL + /** + @name Error Handling + */ + /*@{*/ + + /** + \brief Return the error code for the last API call. + + A call to a Z3 function may return a non Z3_OK error code, + when it is not used correctly. + + \sa Z3_set_error_handler + */ + Z3_error_code Z3_API Z3_get_error_code(__in Z3_context c); + + /** + \brief Register a Z3 error handler. + + A call to a Z3 function may return a non Z3_OK error code, when + it is not used correctly. An error handler can be registered + and will be called in this case. To disable the use of the + error handler, simply register with h=NULL. + + \sa Z3_get_error_code + */ + void Z3_API Z3_set_error_handler(__in Z3_context c, __in Z3_error_handler h); + + /** + \brief Set an error. + */ + void Z3_API Z3_set_error(__in Z3_context c, __in Z3_error_code e); + + /** + \brief Return a string describing the given error code. + */ + Z3_string Z3_API Z3_get_error_msg(__in Z3_error_code err); + /*@}*/ + +#endif // CAMLIDL + + /** + @name Miscellaneous + */ + /*@{*/ + + /** + \brief Return Z3 version number information. + */ + void Z3_API Z3_get_version(__out unsigned * major, + __out unsigned * minor, + __out unsigned * build_number, + __out unsigned * revision_number); + + + /** + \brief Reset all allocated resources. + + Use this facility on out-of memory errors. + It allows discharging the previous state and resuming afresh. + Any pointers previously returned by the API + become invalid. + */ + void Z3_API Z3_reset_memory(void); + + /*@}*/ + + /** + @name External Theory Plugins + */ + /*@{*/ + +#ifndef CAMLIDL + + // + // callbacks and void* don't work with CAMLIDL. + // + typedef Z3_bool Z3_reduce_eq_callback_fptr(__in Z3_theory t, __in Z3_ast a, __in Z3_ast b, __out Z3_ast * r); + + typedef Z3_bool Z3_reduce_app_callback_fptr(__in Z3_theory, __in Z3_func_decl, __in unsigned, __in Z3_ast const [], __out Z3_ast *); + + + typedef Z3_bool Z3_reduce_distinct_callback_fptr(__in Z3_theory, __in unsigned, __in Z3_ast const [], __out Z3_ast *); + + typedef void Z3_theory_callback_fptr(__in Z3_theory t); + + typedef Z3_bool Z3_theory_final_check_callback_fptr(__in Z3_theory); + + typedef void Z3_theory_ast_callback_fptr(__in Z3_theory, __in Z3_ast); + + typedef void Z3_theory_ast_bool_callback_fptr(__in Z3_theory, __in Z3_ast, __in Z3_bool); + + typedef void Z3_theory_ast_ast_callback_fptr(__in Z3_theory, __in Z3_ast, __in Z3_ast); + + + /** + \brief Create a new user defined theory. The new theory will be identified by the name \c th_name. + A theory must be created before asserting any assertion to the given context. + Return NULL in case of failure. + + \c data is a pointer to an external data-structure that may be used to store + theory specific additional data. + */ + Z3_theory Z3_API Z3_mk_theory(__in Z3_context c, __in_z Z3_string th_name, __in Z3_theory_data data); + + /** + \brief Return a pointer to the external data-structure supplied to the function #Z3_mk_theory. + + \see Z3_mk_theory + */ + Z3_theory_data Z3_API Z3_theory_get_ext_data(__in Z3_theory t); + +#endif + + /** + \brief Create an interpreted theory sort. + */ + Z3_sort Z3_API Z3_theory_mk_sort(__in Z3_context c, __in Z3_theory t, __in Z3_symbol s); + + /** + \brief Create an interpreted theory constant value. Values are assumed to be different from each other. + */ + Z3_ast Z3_API Z3_theory_mk_value(__in Z3_context c, __in Z3_theory t, __in Z3_symbol n, __in Z3_sort s); + + /** + \brief Create an interpreted constant for the given theory. + */ + Z3_ast Z3_API Z3_theory_mk_constant(__in Z3_context c, __in Z3_theory t, __in Z3_symbol n, __in Z3_sort s); + + /** + \brief Create an interpreted function declaration for the given theory. + */ + Z3_func_decl Z3_API Z3_theory_mk_func_decl(__in Z3_context c, __in Z3_theory t, __in Z3_symbol n, + __in unsigned domain_size, __in_ecount(domain_size) Z3_sort const domain[], + __in Z3_sort range); + + /** + \brief Return the context where the given theory is installed. + */ + Z3_context Z3_API Z3_theory_get_context(__in Z3_theory t); + + + +#ifndef CAMLIDL + /** + \brief Set a callback that is invoked when theory \c t is deleted. + This callback should be used to delete external data-structures associated with the given theory. + + The callback has the form f(t), where + - \c t is the given theory + + \see Z3_mk_theory + \see Z3_theory_get_ext_data + */ + void Z3_API Z3_set_delete_callback(__in Z3_theory t, __in Z3_theory_callback_fptr f); + + /** + \brief Set a callback for simplifying operators of the given theory. + The callback \c f is invoked by Z3's simplifier. + + It is of the form f(t, d, n, args, r), where: + - \c t is the given theory + - \c d is the declaration of the theory operator + - \c n is the number of arguments in the array \c args + - \c args are arguments for the theory operator + - \c r should contain the result: an expression equivalent to d(args[0], ..., args[n-1]). + + If f(t, d, n, args, r) returns false, then \c r is ignored, and Z3 assumes that no simplification was performed. + */ + void Z3_API Z3_set_reduce_app_callback(__in Z3_theory t, __in Z3_reduce_app_callback_fptr f); + + /** + \brief Set a callback for simplifying the atom s_1 = s_2, when the + sort of \c s_1 and \c s_2 is an interpreted sort of the given theory. + The callback \c f is invoked by Z3's simplifier. + + It has the form f(t, s_1, s_2, r), where: + - \c t is the given theory + - \c s_1 is the left-hand-side + - \c s_2 is the right-hand-side + - \c r should contain the result: an expression equivalent to s_1 = s_2. + + If f(t, s_1, s_2, r) returns false, then \c r is ignored, and Z3 assumes that no simplification was performed. + */ + void Z3_API Z3_set_reduce_eq_callback(__in Z3_theory t, __in Z3_reduce_eq_callback_fptr f); + + /** + \brief Set a callback for simplifying the atom distinct(s_1, ..., s_n), when the + sort of \c s_1, ..., \c s_n is an interpreted sort of the given theory. + The callback \c f is invoked by Z3's simplifier. + + It has the form f(t, n, args, r), where: + - \c t is the given theory + - \c n is the number of arguments in the array \c args + - \c args are arguments for distinct. + - \c r should contain the result: an expression equivalent to distinct(s_1, ..., s_n). + + If f(t, n, args, r) returns false, then \c r is ignored, and Z3 assumes that no simplification was performed. + */ + void Z3_API Z3_set_reduce_distinct_callback(__in Z3_theory t, __in Z3_reduce_distinct_callback_fptr f); + + /** + \brief Set a callback that is invoked when a theory application + is finally added into the logical context. Note that, not every + application contained in an asserted expression is actually + added into the logical context because it may be simplified + during a preprocessing step. + + The callback has the form f(t, n), where + - \c t is the given theory + + - \c n is a theory application, that is, an expression of the form g(...) where \c g is a theory operator. + + \remark An expression \c n added to the logical context at search level \c n, + will remain in the logical context until this level is backtracked. + */ + void Z3_API Z3_set_new_app_callback(__in Z3_theory t, __in Z3_theory_ast_callback_fptr f); + + /** + \brief Set a callback that is invoked when an expression of + sort \c s, where \c s is an interpreted sort of the theory \c + t, is finally added into the logical context. Note that, not + every expression contained in an asserted expression is + actually added into the logical context because it may be + simplified during a preprocessing step. + + The callback has the form f(t, n), where + - \c t is the given theory + + - \c n is an expression of sort \c s, where \c s is an interpreted sort of \c t. + + \remark An expression \c n added to the logical context at search level \c n, + will remain in the logical context until this level is backtracked. + */ + void Z3_API Z3_set_new_elem_callback(__in Z3_theory t, __in Z3_theory_ast_callback_fptr f); + + /** + \brief Set a callback that is invoked when Z3 starts searching for a + satisfying assignment. + + The callback has the form f(t), where + - \c t is the given theory + */ + void Z3_API Z3_set_init_search_callback(__in Z3_theory t, __in Z3_theory_callback_fptr f); + + /** + \brief Set a callback that is invoked when Z3 creates a + case-split (aka backtracking point). + + When a case-split is created we say the search level is increased. + + The callback has the form f(t), where + - \c t is the given theory + */ + void Z3_API Z3_set_push_callback(__in Z3_theory t, __in Z3_theory_callback_fptr f); + + /** + \brief Set a callback that is invoked when Z3 backtracks a + case-split. + + When a case-split is backtracked we say the search level is decreased. + + The callback has the form f(t), where + - \c t is the given theory + */ + void Z3_API Z3_set_pop_callback(__in Z3_theory t, __in Z3_theory_callback_fptr f); + + /** + \brief Set a callback that is invoked when Z3 restarts the + search for a satisfying assignment. + + The callback has the form f(t), where + - \c t is the given theory + */ + void Z3_API Z3_set_restart_callback(__in Z3_theory t, __in Z3_theory_callback_fptr f); + + /** + \brief Set a callback that is invoked when the logical context + is reset by the user. This callback is useful for reseting any + data-structure maintained by the user theory solver. + + The callback has the form f(t), where + - \c t is the given theory + */ + void Z3_API Z3_set_reset_callback(__in Z3_theory t, __in Z3_theory_callback_fptr f); + + /** + \brief Set a callback that is invoked before Z3 starts building a model. + A theory may use this callback to perform expensive operations. + + The callback has the form f(t), where + - \c t is the given theory + + If the theory return \c Z3_false, Z3 will assume that theory is giving up, + and it will assume that it was not possible to decide if the asserted constraints + are satisfiable or not. + */ + void Z3_API Z3_set_final_check_callback(__in Z3_theory t, __in Z3_theory_final_check_callback_fptr f); + + /** + \brief Set a callback that is invoked when an equality s_1 = s_2 + is found by the logical context. + + The callback has the form f(t, s_1, s_2), where: + - \c t is the given theory + - \c s_1 is the left-hand-side + - \c s_2 is the right-hand-side + */ + void Z3_API Z3_set_new_eq_callback(__in Z3_theory t, __in Z3_theory_ast_ast_callback_fptr f); + + /** + \brief Set a callback that is invoked when a disequality s_1 != s_2 + is found by the logical context. + + The callback has the form f(t, s_1, s_2), where: + - \c t is the given theory + - \c s_1 is the left-hand-side + - \c s_2 is the right-hand-side + */ + void Z3_API Z3_set_new_diseq_callback(__in Z3_theory t, __in Z3_theory_ast_ast_callback_fptr f); + + /** + \brief Set a callback that is invoked when a theory predicate is assigned to true/false by Z3. + + The callback has the form f(t, p, v), where: + - \c t is the given theory + - \c p is the assigned predicate. + - \c v is the value (true/false) assigned to \c p. + */ + void Z3_API Z3_set_new_assignment_callback(__in Z3_theory t, __in Z3_theory_ast_bool_callback_fptr f); + + /** + \brief Set a callback that is invoked when an expression is + marked as relevant during the search. This callback is only + invoked when relevancy propagation is enabled. + + The callback has the form f(t, n), where: + - \c t is the given theory + - \c n is the relevant expression + */ + void Z3_API Z3_set_new_relevant_callback(__in Z3_theory t, __in Z3_theory_ast_callback_fptr f); + +#endif // CAMLIDL + /** + \brief Assert a theory axiom/lemmas during the search. + + An axiom added at search level \c n will remain in the logical context until + level \c n is backtracked. + + The callbacks for push (#Z3_set_push_callback) and pop + (#Z3_set_pop_callback) can be used to track when the search + level is increased (i.e., new case-split) and decreased (i.e., + case-split is backtracked). + + Z3 tracks the theory axioms asserted. So, multiple assertions of the same axiom are + ignored. + */ + void Z3_API Z3_theory_assert_axiom(__in Z3_theory t, __in Z3_ast ax); + + /** + \brief Inform to the logical context that \c lhs and \c rhs have the same interpretation + in the model being built by theory \c t. If lhs = rhs is inconsistent with other theories, + then the logical context will backtrack. + + For more information, see the paper "Model-Based Theory Combination" in the Z3 website. + */ + void Z3_API Z3_theory_assume_eq(__in Z3_theory t, __in Z3_ast lhs, __in Z3_ast rhs); + + /** + \brief Enable/disable the simplification of theory axioms asserted using #Z3_theory_assert_axiom. + By default, the simplification of theory specific operators is disabled. + That is, the reduce theory callbacks are not invoked for theory axioms. + The default behavior is useful when asserting axioms stating properties of theory operators. + */ + void Z3_API Z3_theory_enable_axiom_simplification(__in Z3_theory t, __in Z3_bool flag); + + /** + \brief Return the root of the equivalence class containing \c n. + */ + Z3_ast Z3_API Z3_theory_get_eqc_root(__in Z3_theory t, __in Z3_ast n); + + /** + \brief Return the next element in the equivalence class containing \c n. + + The elements in an equivalence class are organized in a circular list. + You can traverse the list by calling this function multiple times + using the result from the previous call. This is illustrated in the + code snippet below. + \code + Z3_ast curr = n; + do + curr = Z3_theory_get_eqc_next(theory, curr); + while (curr != n); + \endcode + */ + Z3_ast Z3_API Z3_theory_get_eqc_next(__in Z3_theory t, __in Z3_ast n); + + /** + \brief Return the number of parents of \c n that are operators of the given theory. + */ + unsigned Z3_API Z3_theory_get_num_parents(__in Z3_theory t, __in Z3_ast n); + + /** + \brief Return the i-th parent of \c n. + See #Z3_theory_get_num_parents. + */ + Z3_ast Z3_API Z3_theory_get_parent(__in Z3_theory t, __in Z3_ast n, __in unsigned i); + + /** + \brief Return \c Z3_TRUE if \c n is an interpreted theory value. + */ + Z3_bool Z3_API Z3_theory_is_value(__in Z3_theory t, __in Z3_ast n); + + /** + \brief Return \c Z3_TRUE if \c d is an interpreted theory declaration. + */ + Z3_bool Z3_API Z3_theory_is_decl(__in Z3_theory t, __in Z3_func_decl d); + + /** + \brief Return the number of expressions of the given theory in + the logical context. These are the expressions notified using the + callback #Z3_set_new_elem_callback. + */ + unsigned Z3_API Z3_theory_get_num_elems(__in Z3_theory t); + + /** + \brief Return the i-th elem of the given theory in the logical context. + + \see Z3_theory_get_num_elems + */ + Z3_ast Z3_API Z3_theory_get_elem(__in Z3_theory t, __in unsigned i); + + /** + \brief Return the number of theory applications in the logical + context. These are the expressions notified using the callback + #Z3_set_new_app_callback. + */ + unsigned Z3_API Z3_theory_get_num_apps(__in Z3_theory t); + + /** + \brief Return the i-th application of the given theory in the logical context. + + \see Z3_theory_get_num_apps + */ + Z3_ast Z3_API Z3_theory_get_app(__in Z3_theory t, __in unsigned i); + + /*@}*/ + + + /** + @name Fixedpoint and Datalog facilities + */ + /*@{*/ + /** + \brief Add a universal Horn clause as a named rule. + The \c horn_rule should be of the form: + + \code + horn_rule ::= (forall (bound-vars) horn_rule) + | (=> atoms horn_rule) + | atom + \endcode + */ + void Z3_API Z3_datalog_add_rule(__in Z3_context c, __in Z3_ast horn_rule, __in Z3_symbol name); + + /** + \brief Pose a query against the asserted rules. + + The query returns a formula that encodes the set of + satisfying instances for the query. + + \code + query ::= (exists (bound-vars) query) + | literals + \endcode + + */ + Z3_ast Z3_API Z3_datalog_query(__in Z3_context c, __in Z3_ast q); + + /** + \brief Configure the predicate representation. + + It sets the predicate to use a set of domains given by the list of symbols. + The domains given by the list of symbols must belong to a set + of built-in domains. + */ + + void Z3_API Z3_datalog_set_predicate_representation( + __in Z3_context c, __in Z3_func_decl f, + __in unsigned num_relations, + __in_ecount(num_relations) Z3_symbol const relation_kinds[]); + + /** + \brief Parse a file in Datalog format and process the queries in it. + */ + void Z3_API Z3_datalog_parse_file(__in Z3_context c, Z3_string filename); + + /** + \brief The following utilities allows adding user-defined domains. + */ + +#ifndef CAMLIDL + typedef void Z3_datalog_reduce_assign_callback_fptr( + __in Z3_context, __in Z3_func_decl, + __in unsigned, __in Z3_ast const [], + __in unsigned, __in Z3_ast const []); + + typedef void Z3_datalog_reduce_app_callback_fptr( + __in Z3_context, __in Z3_func_decl, + __in unsigned, __in Z3_ast const [], + __out Z3_ast*); + + + /** + \brief Initialize the context with a user-defined state. + + */ + void Z3_API Z3_datalog_init(__in Z3_context c, __in void* state); + + /** + \brief Retrieve the user-define state. + */ + void* Z3_API Z3_datalog_get_context(__in Z3_context c); + + + /** + \brief Register a callback to destructive updates. + + Registers are identified with terms encoded as fresh constants, + */ + void Z3_API Z3_datalog_set_reduce_assign_callback( + __in Z3_context c, __in Z3_datalog_reduce_assign_callback_fptr cb); + + /** + \brief Register a callback for buildling terms based on + the relational operators. + */ + void Z3_API Z3_datalog_set_reduce_app_callback( + __in Z3_context c, __in Z3_datalog_reduce_app_callback_fptr cb); + +#endif + + /*@}*/ + +#ifndef CAMLIDL +#ifdef __cplusplus +}; +#endif // __cplusplus +#else +} +#endif // CAMLIDL + +/*@}*/ diff --git a/external/z3/lib/libz3-a-32b b/external/z3/lib/libz3-a-32b new file mode 100644 # file too large to diff: external/z3/lib/libz3-a-32b diff --git a/external/z3/lib/libz3-a-64b b/external/z3/lib/libz3-a-64b new file mode 100644 # file too large to diff: external/z3/lib/libz3-a-64b diff --git a/external/z3/lib/libz3-so-32b b/external/z3/lib/libz3-so-32b new file mode 100644 # file too large to diff: external/z3/lib/libz3-so-32b diff --git a/external/z3/lib/libz3-so-64b b/external/z3/lib/libz3-so-64b new file mode 100644 # file too large to diff: external/z3/lib/libz3-so-64b diff --git a/external/z3/ocaml/build-lib.sh b/external/z3/ocaml/build-lib.sh new file mode 100644 --- /dev/null +++ b/external/z3/ocaml/build-lib.sh @@ -0,0 +1,8 @@ +#!/bin/bash + +gcc -I../include -I`ocamlc -where` -c z3_stubs.c -c z3_theory_stubs.c +ocamlopt -c z3.mli +ocamlopt -c z3.ml +ar rcs libz3stubs.a z3_stubs.o z3_theory_stubs.o +ranlib libz3stubs.a +ocamlopt -a -o z3.cmxa -cclib -lz3stubs z3.cmx diff --git a/external/z3/ocaml/z3.ml b/external/z3/ocaml/z3.ml new file mode 100644 --- /dev/null +++ b/external/z3/ocaml/z3.ml @@ -0,0 +1,1499 @@ +(* File generated from z3.idl *) + +type config +and context +and sort +and func_decl +and ast +and app +and pattern +and symbol +and parameter +and model +and literals +and constructor +and constructor_list +and theory +and theory_data +and enum_1 = + | L_FALSE + | L_UNDEF + | L_TRUE +and lbool = enum_1 +and enum_2 = + | INT_SYMBOL + | STRING_SYMBOL +and symbol_kind = enum_2 +and enum_3 = + | PARAMETER_INT + | PARAMETER_DOUBLE + | PARAMETER_RATIONAL + | PARAMETER_SYMBOL + | PARAMETER_SORT + | PARAMETER_AST + | PARAMETER_FUNC_DECL +and parameter_kind = enum_3 +and enum_4 = + | UNINTERPRETED_SORT + | BOOL_SORT + | INT_SORT + | REAL_SORT + | BV_SORT + | ARRAY_SORT + | DATATYPE_SORT + | RELATION_SORT + | FINITE_DOMAIN_SORT + | UNKNOWN_SORT +and sort_kind = enum_4 +and enum_5 = + | NUMERAL_AST + | APP_AST + | VAR_AST + | QUANTIFIER_AST + | UNKNOWN_AST +and ast_kind = enum_5 +and enum_6 = + | OP_TRUE + | OP_FALSE + | OP_EQ + | OP_DISTINCT + | OP_ITE + | OP_AND + | OP_OR + | OP_IFF + | OP_XOR + | OP_NOT + | OP_IMPLIES + | OP_OEQ + | OP_ANUM + | OP_LE + | OP_GE + | OP_LT + | OP_GT + | OP_ADD + | OP_SUB + | OP_UMINUS + | OP_MUL + | OP_DIV + | OP_IDIV + | OP_REM + | OP_MOD + | OP_TO_REAL + | OP_TO_INT + | OP_IS_INT + | OP_STORE + | OP_SELECT + | OP_CONST_ARRAY + | OP_ARRAY_MAP + | OP_ARRAY_DEFAULT + | OP_SET_UNION + | OP_SET_INTERSECT + | OP_SET_DIFFERENCE + | OP_SET_COMPLEMENT + | OP_SET_SUBSET + | OP_AS_ARRAY + | OP_BNUM + | OP_BIT1 + | OP_BIT0 + | OP_BNEG + | OP_BADD + | OP_BSUB + | OP_BMUL + | OP_BSDIV + | OP_BUDIV + | OP_BSREM + | OP_BUREM + | OP_BSMOD + | OP_BSDIV0 + | OP_BUDIV0 + | OP_BSREM0 + | OP_BUREM0 + | OP_BSMOD0 + | OP_ULEQ + | OP_SLEQ + | OP_UGEQ + | OP_SGEQ + | OP_ULT + | OP_SLT + | OP_UGT + | OP_SGT + | OP_BAND + | OP_BOR + | OP_BNOT + | OP_BXOR + | OP_BNAND + | OP_BNOR + | OP_BXNOR + | OP_CONCAT + | OP_SIGN_EXT + | OP_ZERO_EXT + | OP_EXTRACT + | OP_REPEAT + | OP_BREDOR + | OP_BREDAND + | OP_BCOMP + | OP_BSHL + | OP_BLSHR + | OP_BASHR + | OP_ROTATE_LEFT + | OP_ROTATE_RIGHT + | OP_EXT_ROTATE_LEFT + | OP_EXT_ROTATE_RIGHT + | OP_INT2BV + | OP_BV2INT + | OP_CARRY + | OP_XOR3 + | OP_PR_UNDEF + | OP_PR_TRUE + | OP_PR_ASSERTED + | OP_PR_GOAL + | OP_PR_MODUS_PONENS + | OP_PR_REFLEXIVITY + | OP_PR_SYMMETRY + | OP_PR_TRANSITIVITY + | OP_PR_TRANSITIVITY_STAR + | OP_PR_MONOTONICITY + | OP_PR_QUANT_INTRO + | OP_PR_DISTRIBUTIVITY + | OP_PR_AND_ELIM + | OP_PR_NOT_OR_ELIM + | OP_PR_REWRITE + | OP_PR_REWRITE_STAR + | OP_PR_PULL_QUANT + | OP_PR_PULL_QUANT_STAR + | OP_PR_PUSH_QUANT + | OP_PR_ELIM_UNUSED_VARS + | OP_PR_DER + | OP_PR_QUANT_INST + | OP_PR_HYPOTHESIS + | OP_PR_LEMMA + | OP_PR_UNIT_RESOLUTION + | OP_PR_IFF_TRUE + | OP_PR_IFF_FALSE + | OP_PR_COMMUTATIVITY + | OP_PR_DEF_AXIOM + | OP_PR_DEF_INTRO + | OP_PR_APPLY_DEF + | OP_PR_IFF_OEQ + | OP_PR_NNF_POS + | OP_PR_NNF_NEG + | OP_PR_NNF_STAR + | OP_PR_CNF_STAR + | OP_PR_SKOLEMIZE + | OP_PR_MODUS_PONENS_OEQ + | OP_PR_TH_LEMMA + | OP_RA_STORE + | OP_RA_EMPTY + | OP_RA_IS_EMPTY + | OP_RA_JOIN + | OP_RA_UNION + | OP_RA_WIDEN + | OP_RA_PROJECT + | OP_RA_FILTER + | OP_RA_NEGATION_FILTER + | OP_RA_RENAME + | OP_RA_COMPLEMENT + | OP_RA_SELECT + | OP_RA_CLONE + | OP_FD_LT + | OP_UNINTERPRETED +and decl_kind = enum_6 +and enum_7 = + | NO_FAILURE + | UNKNOWN + | TIMEOUT + | MEMOUT_WATERMARK + | CANCELED + | NUM_CONFLICTS + | THEORY + | QUANTIFIERS +and search_failure = enum_7 +and enum_8 = + | PRINT_SMTLIB_FULL + | PRINT_LOW_LEVEL + | PRINT_SMTLIB_COMPLIANT + | PRINT_SMTLIB2_COMPLIANT +and ast_print_mode = enum_8 + +external mk_config : unit -> config + = "camlidl_z3_Z3_mk_config" + +external del_config : config -> unit + = "camlidl_z3_Z3_del_config" + +external set_param_value : config -> string -> string -> unit + = "camlidl_z3_Z3_set_param_value" + +external mk_context : config -> context + = "camlidl_z3_Z3_mk_context" + +external mk_context_rc : config -> context + = "camlidl_z3_Z3_mk_context_rc" + +external set_logic : context -> string -> bool + = "camlidl_z3_Z3_set_logic" + +external del_context : context -> unit + = "camlidl_z3_Z3_del_context" + +external inc_ref : context -> ast -> unit + = "camlidl_z3_Z3_inc_ref" + +external dec_ref : context -> ast -> unit + = "camlidl_z3_Z3_dec_ref" + +external trace_to_file : context -> string -> bool + = "camlidl_z3_Z3_trace_to_file" + +external trace_to_stderr : context -> unit + = "camlidl_z3_Z3_trace_to_stderr" + +external trace_to_stdout : context -> unit + = "camlidl_z3_Z3_trace_to_stdout" + +external trace_off : context -> unit + = "camlidl_z3_Z3_trace_off" + +external toggle_warning_messages : bool -> unit + = "camlidl_z3_Z3_toggle_warning_messages" + +external update_param_value : context -> string -> string -> unit + = "camlidl_z3_Z3_update_param_value" + +external mk_int_symbol : context -> int -> symbol + = "camlidl_z3_Z3_mk_int_symbol" + +external mk_string_symbol : context -> string -> symbol + = "camlidl_z3_Z3_mk_string_symbol" + +external is_eq_sort : context -> sort -> sort -> bool + = "camlidl_z3_Z3_is_eq_sort" + +external mk_uninterpreted_sort : context -> symbol -> sort + = "camlidl_z3_Z3_mk_uninterpreted_sort" + +external mk_bool_sort : context -> sort + = "camlidl_z3_Z3_mk_bool_sort" + +external mk_int_sort : context -> sort + = "camlidl_z3_Z3_mk_int_sort" + +external mk_real_sort : context -> sort + = "camlidl_z3_Z3_mk_real_sort" + +external mk_bv_sort : context -> int -> sort + = "camlidl_z3_Z3_mk_bv_sort" + +external mk_array_sort : context -> sort -> sort -> sort + = "camlidl_z3_Z3_mk_array_sort" + +external mk_tuple_sort : context -> symbol -> symbol array -> sort array -> sort * func_decl * func_decl array + = "camlidl_z3_Z3_mk_tuple_sort" + +external mk_enumeration_sort : context -> symbol -> symbol array -> sort * func_decl array * func_decl array + = "camlidl_z3_Z3_mk_enumeration_sort" + +external mk_list_sort : context -> symbol -> sort -> sort * func_decl * func_decl * func_decl * func_decl * func_decl * func_decl + = "camlidl_z3_Z3_mk_list_sort" + +external mk_constructor : context -> symbol -> symbol -> symbol array -> sort array -> int array -> constructor + = "camlidl_z3_Z3_mk_constructor_bytecode" "camlidl_z3_Z3_mk_constructor" + +external query_constructor : context -> constructor -> int -> func_decl * func_decl * func_decl array + = "camlidl_z3_Z3_query_constructor" + +external del_constructor : context -> constructor -> unit + = "camlidl_z3_Z3_del_constructor" + +external mk_datatype : context -> symbol -> constructor array -> sort * constructor array + = "camlidl_z3_Z3_mk_datatype" + +external mk_constructor_list : context -> constructor array -> constructor_list + = "camlidl_z3_Z3_mk_constructor_list" + +external del_constructor_list : context -> constructor_list -> unit + = "camlidl_z3_Z3_del_constructor_list" + +external mk_datatypes : context -> symbol array -> constructor_list array -> sort array * constructor_list array + = "camlidl_z3_Z3_mk_datatypes" + +external mk_injective_function : context -> symbol -> sort array -> sort -> func_decl + = "camlidl_z3_Z3_mk_injective_function" + +external is_eq_ast : context -> ast -> ast -> bool + = "camlidl_z3_Z3_is_eq_ast" + +external is_eq_func_decl : context -> func_decl -> func_decl -> bool + = "camlidl_z3_Z3_is_eq_func_decl" + +external mk_func_decl : context -> symbol -> sort array -> sort -> func_decl + = "camlidl_z3_Z3_mk_func_decl" + +external mk_app : context -> func_decl -> ast array -> ast + = "camlidl_z3_Z3_mk_app" + +external mk_const : context -> symbol -> sort -> ast + = "camlidl_z3_Z3_mk_const" + +external mk_label : context -> symbol -> bool -> ast -> ast + = "camlidl_z3_Z3_mk_label" + +external mk_fresh_func_decl : context -> string -> sort array -> sort -> func_decl + = "camlidl_z3_Z3_mk_fresh_func_decl" + +external mk_fresh_const : context -> string -> sort -> ast + = "camlidl_z3_Z3_mk_fresh_const" + +external mk_true : context -> ast + = "camlidl_z3_Z3_mk_true" + +external mk_false : context -> ast + = "camlidl_z3_Z3_mk_false" + +external mk_eq : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_eq" + +external mk_distinct : context -> ast array -> ast + = "camlidl_z3_Z3_mk_distinct" + +external mk_not : context -> ast -> ast + = "camlidl_z3_Z3_mk_not" + +external mk_ite : context -> ast -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_ite" + +external mk_iff : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_iff" + +external mk_implies : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_implies" + +external mk_xor : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_xor" + +external mk_and : context -> ast array -> ast + = "camlidl_z3_Z3_mk_and" + +external mk_or : context -> ast array -> ast + = "camlidl_z3_Z3_mk_or" + +external mk_add : context -> ast array -> ast + = "camlidl_z3_Z3_mk_add" + +external mk_mul : context -> ast array -> ast + = "camlidl_z3_Z3_mk_mul" + +external mk_sub : context -> ast array -> ast + = "camlidl_z3_Z3_mk_sub" + +external mk_unary_minus : context -> ast -> ast + = "camlidl_z3_Z3_mk_unary_minus" + +external mk_div : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_div" + +external mk_mod : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_mod" + +external mk_rem : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_rem" + +external mk_lt : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_lt" + +external mk_le : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_le" + +external mk_gt : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_gt" + +external mk_ge : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_ge" + +external mk_int2real : context -> ast -> ast + = "camlidl_z3_Z3_mk_int2real" + +external mk_real2int : context -> ast -> ast + = "camlidl_z3_Z3_mk_real2int" + +external mk_is_int : context -> ast -> ast + = "camlidl_z3_Z3_mk_is_int" + +external mk_bvnot : context -> ast -> ast + = "camlidl_z3_Z3_mk_bvnot" + +external mk_bvredand : context -> ast -> ast + = "camlidl_z3_Z3_mk_bvredand" + +external mk_bvredor : context -> ast -> ast + = "camlidl_z3_Z3_mk_bvredor" + +external mk_bvand : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvand" + +external mk_bvor : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvor" + +external mk_bvxor : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvxor" + +external mk_bvnand : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvnand" + +external mk_bvnor : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvnor" + +external mk_bvxnor : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvxnor" + +external mk_bvneg : context -> ast -> ast + = "camlidl_z3_Z3_mk_bvneg" + +external mk_bvadd : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvadd" + +external mk_bvsub : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvsub" + +external mk_bvmul : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvmul" + +external mk_bvudiv : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvudiv" + +external mk_bvsdiv : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvsdiv" + +external mk_bvurem : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvurem" + +external mk_bvsrem : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvsrem" + +external mk_bvsmod : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvsmod" + +external mk_bvult : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvult" + +external mk_bvslt : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvslt" + +external mk_bvule : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvule" + +external mk_bvsle : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvsle" + +external mk_bvuge : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvuge" + +external mk_bvsge : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvsge" + +external mk_bvugt : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvugt" + +external mk_bvsgt : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvsgt" + +external mk_concat : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_concat" + +external mk_extract : context -> int -> int -> ast -> ast + = "camlidl_z3_Z3_mk_extract" + +external mk_sign_ext : context -> int -> ast -> ast + = "camlidl_z3_Z3_mk_sign_ext" + +external mk_zero_ext : context -> int -> ast -> ast + = "camlidl_z3_Z3_mk_zero_ext" + +external mk_repeat : context -> int -> ast -> ast + = "camlidl_z3_Z3_mk_repeat" + +external mk_bvshl : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvshl" + +external mk_bvlshr : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvlshr" + +external mk_bvashr : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvashr" + +external mk_rotate_left : context -> int -> ast -> ast + = "camlidl_z3_Z3_mk_rotate_left" + +external mk_rotate_right : context -> int -> ast -> ast + = "camlidl_z3_Z3_mk_rotate_right" + +external mk_ext_rotate_left : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_ext_rotate_left" + +external mk_ext_rotate_right : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_ext_rotate_right" + +external mk_int2bv : context -> int -> ast -> ast + = "camlidl_z3_Z3_mk_int2bv" + +external mk_bv2int : context -> ast -> bool -> ast + = "camlidl_z3_Z3_mk_bv2int" + +external mk_bvadd_no_overflow : context -> ast -> ast -> bool -> ast + = "camlidl_z3_Z3_mk_bvadd_no_overflow" + +external mk_bvadd_no_underflow : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvadd_no_underflow" + +external mk_bvsub_no_overflow : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvsub_no_overflow" + +external mk_bvsub_no_underflow : context -> ast -> ast -> bool -> ast + = "camlidl_z3_Z3_mk_bvsub_no_underflow" + +external mk_bvsdiv_no_overflow : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvsdiv_no_overflow" + +external mk_bvneg_no_overflow : context -> ast -> ast + = "camlidl_z3_Z3_mk_bvneg_no_overflow" + +external mk_bvmul_no_overflow : context -> ast -> ast -> bool -> ast + = "camlidl_z3_Z3_mk_bvmul_no_overflow" + +external mk_bvmul_no_underflow : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_bvmul_no_underflow" + +external mk_select : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_select" + +external mk_store : context -> ast -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_store" + +external mk_const_array : context -> sort -> ast -> ast + = "camlidl_z3_Z3_mk_const_array" + +external mk_map : context -> func_decl -> int -> ast -> ast + = "camlidl_z3_Z3_mk_map" + +external mk_array_default : context -> ast -> ast + = "camlidl_z3_Z3_mk_array_default" + +external mk_set_sort : context -> sort -> sort + = "camlidl_z3_Z3_mk_set_sort" + +external mk_empty_set : context -> sort -> ast + = "camlidl_z3_Z3_mk_empty_set" + +external mk_full_set : context -> sort -> ast + = "camlidl_z3_Z3_mk_full_set" + +external mk_set_add : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_set_add" + +external mk_set_del : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_set_del" + +external mk_set_union : context -> ast array -> ast + = "camlidl_z3_Z3_mk_set_union" + +external mk_set_intersect : context -> ast array -> ast + = "camlidl_z3_Z3_mk_set_intersect" + +external mk_set_difference : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_set_difference" + +external mk_set_complement : context -> ast -> ast + = "camlidl_z3_Z3_mk_set_complement" + +external mk_set_member : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_set_member" + +external mk_set_subset : context -> ast -> ast -> ast + = "camlidl_z3_Z3_mk_set_subset" + +external mk_numeral : context -> string -> sort -> ast + = "camlidl_z3_Z3_mk_numeral" + +external mk_real : context -> int -> int -> ast + = "camlidl_z3_Z3_mk_real" + +external mk_int : context -> int -> sort -> ast + = "camlidl_z3_Z3_mk_int" + +external mk_unsigned_int : context -> int -> sort -> ast + = "camlidl_z3_Z3_mk_unsigned_int" + +external mk_pattern : context -> ast array -> pattern + = "camlidl_z3_Z3_mk_pattern" + +external mk_bound : context -> int -> sort -> ast + = "camlidl_z3_Z3_mk_bound" + +external mk_forall : context -> int -> pattern array -> sort array -> symbol array -> ast -> ast + = "camlidl_z3_Z3_mk_forall_bytecode" "camlidl_z3_Z3_mk_forall" + +external mk_exists : context -> int -> pattern array -> sort array -> symbol array -> ast -> ast + = "camlidl_z3_Z3_mk_exists_bytecode" "camlidl_z3_Z3_mk_exists" + +external mk_quantifier : context -> bool -> int -> pattern array -> sort array -> symbol array -> ast -> ast + = "camlidl_z3_Z3_mk_quantifier_bytecode" "camlidl_z3_Z3_mk_quantifier" + +external mk_quantifier_ex : context -> bool -> int -> symbol -> symbol -> pattern array -> ast array -> sort array -> symbol array -> ast -> ast + = "camlidl_z3_Z3_mk_quantifier_ex_bytecode" "camlidl_z3_Z3_mk_quantifier_ex" + +external mk_forall_const : context -> int -> app array -> pattern array -> ast -> ast + = "camlidl_z3_Z3_mk_forall_const" + +external mk_exists_const : context -> int -> app array -> pattern array -> ast -> ast + = "camlidl_z3_Z3_mk_exists_const" + +external mk_quantifier_const : context -> bool -> int -> app array -> pattern array -> ast -> ast + = "camlidl_z3_Z3_mk_quantifier_const_bytecode" "camlidl_z3_Z3_mk_quantifier_const" + +external mk_quantifier_const_ex : context -> bool -> int -> symbol -> symbol -> app array -> pattern array -> ast array -> ast -> ast + = "camlidl_z3_Z3_mk_quantifier_const_ex_bytecode" "camlidl_z3_Z3_mk_quantifier_const_ex" + +external get_ast_id : context -> ast -> int + = "camlidl_z3_Z3_get_ast_id" + +external get_func_decl_id : context -> func_decl -> int + = "camlidl_z3_Z3_get_func_decl_id" + +external get_sort_id : context -> sort -> int + = "camlidl_z3_Z3_get_sort_id" + +external is_well_sorted : context -> ast -> bool + = "camlidl_z3_Z3_is_well_sorted" + +external get_symbol_kind : context -> symbol -> symbol_kind + = "camlidl_z3_Z3_get_symbol_kind" + +external get_symbol_int : context -> symbol -> int + = "camlidl_z3_Z3_get_symbol_int" + +external get_symbol_string : context -> symbol -> string + = "camlidl_z3_Z3_get_symbol_string" + +external get_ast_kind : context -> ast -> ast_kind + = "camlidl_z3_Z3_get_ast_kind" + +external get_numeral_string : context -> ast -> string + = "camlidl_z3_Z3_get_numeral_string" + +external get_numeral_small : context -> ast -> bool * int64 * int64 + = "camlidl_z3_Z3_get_numeral_small" + +external get_numeral_int : context -> ast -> bool * int + = "camlidl_z3_Z3_get_numeral_int" + +external get_numeral_uint : context -> ast -> bool * int + = "camlidl_z3_Z3_get_numeral_uint" + +external get_bool_value : context -> ast -> lbool + = "camlidl_z3_Z3_get_bool_value" + +external get_app_decl : context -> app -> func_decl + = "camlidl_z3_Z3_get_app_decl" + +external get_app_num_args : context -> app -> int + = "camlidl_z3_Z3_get_app_num_args" + +external get_app_arg : context -> app -> int -> ast + = "camlidl_z3_Z3_get_app_arg" + +external get_index_value : context -> ast -> int + = "camlidl_z3_Z3_get_index_value" + +external is_quantifier_forall : context -> ast -> bool + = "camlidl_z3_Z3_is_quantifier_forall" + +external get_quantifier_weight : context -> ast -> int + = "camlidl_z3_Z3_get_quantifier_weight" + +external get_quantifier_num_patterns : context -> ast -> int + = "camlidl_z3_Z3_get_quantifier_num_patterns" + +external get_quantifier_pattern_ast : context -> ast -> int -> pattern + = "camlidl_z3_Z3_get_quantifier_pattern_ast" + +external get_quantifier_num_no_patterns : context -> ast -> int + = "camlidl_z3_Z3_get_quantifier_num_no_patterns" + +external get_quantifier_no_pattern_ast : context -> ast -> int -> ast + = "camlidl_z3_Z3_get_quantifier_no_pattern_ast" + +external get_quantifier_bound_name : context -> ast -> int -> symbol + = "camlidl_z3_Z3_get_quantifier_bound_name" + +external get_quantifier_bound_sort : context -> ast -> int -> sort + = "camlidl_z3_Z3_get_quantifier_bound_sort" + +external get_quantifier_body : context -> ast -> ast + = "camlidl_z3_Z3_get_quantifier_body" + +external get_quantifier_num_bound : context -> ast -> int + = "camlidl_z3_Z3_get_quantifier_num_bound" + +external get_decl_name : context -> func_decl -> symbol + = "camlidl_z3_Z3_get_decl_name" + +external get_decl_num_parameters : context -> func_decl -> int + = "camlidl_z3_Z3_get_decl_num_parameters" + +external get_decl_parameter_kind : context -> func_decl -> int -> parameter_kind + = "camlidl_z3_Z3_get_decl_parameter_kind" + +external get_decl_int_parameter : context -> func_decl -> int -> int + = "camlidl_z3_Z3_get_decl_int_parameter" + +external get_decl_double_parameter : context -> func_decl -> int -> float + = "camlidl_z3_Z3_get_decl_double_parameter" + +external get_decl_symbol_parameter : context -> func_decl -> int -> symbol + = "camlidl_z3_Z3_get_decl_symbol_parameter" + +external get_decl_sort_parameter : context -> func_decl -> int -> sort + = "camlidl_z3_Z3_get_decl_sort_parameter" + +external get_decl_ast_parameter : context -> func_decl -> int -> ast + = "camlidl_z3_Z3_get_decl_ast_parameter" + +external get_decl_func_decl_parameter : context -> func_decl -> int -> func_decl + = "camlidl_z3_Z3_get_decl_func_decl_parameter" + +external get_decl_rational_parameter : context -> func_decl -> int -> string + = "camlidl_z3_Z3_get_decl_rational_parameter" + +external get_sort_name : context -> sort -> symbol + = "camlidl_z3_Z3_get_sort_name" + +external get_sort : context -> ast -> sort + = "camlidl_z3_Z3_get_sort" + +external get_domain_size : context -> func_decl -> int + = "camlidl_z3_Z3_get_domain_size" + +external get_domain : context -> func_decl -> int -> sort + = "camlidl_z3_Z3_get_domain" + +external get_range : context -> func_decl -> sort + = "camlidl_z3_Z3_get_range" + +external get_sort_kind : context -> sort -> sort_kind + = "camlidl_z3_Z3_get_sort_kind" + +external get_bv_sort_size : context -> sort -> int + = "camlidl_z3_Z3_get_bv_sort_size" + +external get_array_sort_domain : context -> sort -> sort + = "camlidl_z3_Z3_get_array_sort_domain" + +external get_array_sort_range : context -> sort -> sort + = "camlidl_z3_Z3_get_array_sort_range" + +external get_tuple_sort_mk_decl : context -> sort -> func_decl + = "camlidl_z3_Z3_get_tuple_sort_mk_decl" + +external get_decl_kind : context -> func_decl -> decl_kind + = "camlidl_z3_Z3_get_decl_kind" + +external get_tuple_sort_num_fields : context -> sort -> int + = "camlidl_z3_Z3_get_tuple_sort_num_fields" + +external get_tuple_sort_field_decl : context -> sort -> int -> func_decl + = "camlidl_z3_Z3_get_tuple_sort_field_decl" + +external get_datatype_sort_num_constructors : context -> sort -> int + = "camlidl_z3_Z3_get_datatype_sort_num_constructors" + +external get_datatype_sort_constructor : context -> sort -> int -> func_decl + = "camlidl_z3_Z3_get_datatype_sort_constructor" + +external get_datatype_sort_recognizer : context -> sort -> int -> func_decl + = "camlidl_z3_Z3_get_datatype_sort_recognizer" + +external get_datatype_sort_constructor_accessor : context -> sort -> int -> int -> func_decl + = "camlidl_z3_Z3_get_datatype_sort_constructor_accessor" + +external get_relation_arity : context -> sort -> int + = "camlidl_z3_Z3_get_relation_arity" + +external get_relation_column : context -> sort -> int -> sort + = "camlidl_z3_Z3_get_relation_column" + +external get_pattern_num_terms : context -> pattern -> int + = "camlidl_z3_Z3_get_pattern_num_terms" + +external get_pattern : context -> pattern -> int -> ast + = "camlidl_z3_Z3_get_pattern" + +external simplify : context -> ast -> ast + = "camlidl_z3_Z3_simplify" + +external update_term : context -> ast -> ast array -> ast + = "camlidl_z3_Z3_update_term" + +external substitute : context -> ast -> ast array -> ast array -> ast + = "camlidl_z3_Z3_substitute" + +external substitute_vars : context -> ast -> ast array -> ast + = "camlidl_z3_Z3_substitute_vars" + +external sort_to_ast : context -> sort -> ast + = "camlidl_z3_Z3_sort_to_ast" + +external func_decl_to_ast : context -> func_decl -> ast + = "camlidl_z3_Z3_func_decl_to_ast" + +external pattern_to_ast : context -> pattern -> ast + = "camlidl_z3_Z3_pattern_to_ast" + +external app_to_ast : context -> app -> ast + = "camlidl_z3_Z3_app_to_ast" + +external to_app : context -> ast -> app + = "camlidl_z3_Z3_to_app" + +external push : context -> unit + = "camlidl_z3_Z3_push" + +external pop : context -> int -> unit + = "camlidl_z3_Z3_pop" + +external get_num_scopes : context -> int + = "camlidl_z3_Z3_get_num_scopes" + +external persist_ast : context -> ast -> int -> unit + = "camlidl_z3_Z3_persist_ast" + +external assert_cnstr : context -> ast -> unit + = "camlidl_z3_Z3_assert_cnstr" + +external check_and_get_model : context -> lbool * model + = "camlidl_z3_Z3_check_and_get_model" + +external check : context -> lbool + = "camlidl_z3_Z3_check" + +external check_assumptions : context -> ast array -> int -> ast array -> lbool * model * ast * int * ast array + = "camlidl_z3_Z3_check_assumptions" + +external get_implied_equalities : context -> ast array -> lbool * int array + = "camlidl_z3_Z3_get_implied_equalities" + +external del_model : context -> model -> unit + = "camlidl_z3_Z3_del_model" + +external soft_check_cancel : context -> unit + = "camlidl_z3_Z3_soft_check_cancel" + +external get_search_failure : context -> search_failure + = "camlidl_z3_Z3_get_search_failure" + +external get_relevant_labels : context -> literals + = "camlidl_z3_Z3_get_relevant_labels" + +external get_relevant_literals : context -> literals + = "camlidl_z3_Z3_get_relevant_literals" + +external get_guessed_literals : context -> literals + = "camlidl_z3_Z3_get_guessed_literals" + +external del_literals : context -> literals -> unit + = "camlidl_z3_Z3_del_literals" + +external get_num_literals : context -> literals -> int + = "camlidl_z3_Z3_get_num_literals" + +external get_label_symbol : context -> literals -> int -> symbol + = "camlidl_z3_Z3_get_label_symbol" + +external get_literal : context -> literals -> int -> ast + = "camlidl_z3_Z3_get_literal" + +external disable_literal : context -> literals -> int -> unit + = "camlidl_z3_Z3_disable_literal" + +external block_literals : context -> literals -> unit + = "camlidl_z3_Z3_block_literals" + +external get_model_num_constants : context -> model -> int + = "camlidl_z3_Z3_get_model_num_constants" + +external get_model_constant : context -> model -> int -> func_decl + = "camlidl_z3_Z3_get_model_constant" + +external eval_func_decl : context -> model -> func_decl -> bool * ast + = "camlidl_z3_Z3_eval_func_decl" + +external is_array_value : context -> model -> ast -> bool * int + = "camlidl_z3_Z3_is_array_value" + +external get_array_value : context -> model -> ast -> ast array -> ast array -> ast array * ast array * ast + = "camlidl_z3_Z3_get_array_value" + +external get_model_num_funcs : context -> model -> int + = "camlidl_z3_Z3_get_model_num_funcs" + +external get_model_func_decl : context -> model -> int -> func_decl + = "camlidl_z3_Z3_get_model_func_decl" + +external get_model_func_else : context -> model -> int -> ast + = "camlidl_z3_Z3_get_model_func_else" + +external get_model_func_num_entries : context -> model -> int -> int + = "camlidl_z3_Z3_get_model_func_num_entries" + +external get_model_func_entry_num_args : context -> model -> int -> int -> int + = "camlidl_z3_Z3_get_model_func_entry_num_args" + +external get_model_func_entry_arg : context -> model -> int -> int -> int -> ast + = "camlidl_z3_Z3_get_model_func_entry_arg" + +external get_model_func_entry_value : context -> model -> int -> int -> ast + = "camlidl_z3_Z3_get_model_func_entry_value" + +external eval : context -> model -> ast -> bool * ast + = "camlidl_z3_Z3_eval" + +external eval_decl : context -> model -> func_decl -> ast array -> bool * ast + = "camlidl_z3_Z3_eval_decl" + +external open_log : context -> string -> bool + = "camlidl_z3_Z3_open_log" + +external append_log : context -> string -> unit + = "camlidl_z3_Z3_append_log" + +external close_log : context -> unit + = "camlidl_z3_Z3_close_log" + +external set_ast_print_mode : context -> ast_print_mode -> unit + = "camlidl_z3_Z3_set_ast_print_mode" + +external ast_to_string : context -> ast -> string + = "camlidl_z3_Z3_ast_to_string" + +external pattern_to_string : context -> pattern -> string + = "camlidl_z3_Z3_pattern_to_string" + +external sort_to_string : context -> sort -> string + = "camlidl_z3_Z3_sort_to_string" + +external func_decl_to_string : context -> func_decl -> string + = "camlidl_z3_Z3_func_decl_to_string" + +external model_to_string : context -> model -> string + = "camlidl_z3_Z3_model_to_string" + +external benchmark_to_smtlib_string : context -> string -> string -> string -> string -> ast array -> ast -> string + = "camlidl_z3_Z3_benchmark_to_smtlib_string_bytecode" "camlidl_z3_Z3_benchmark_to_smtlib_string" + +external context_to_string : context -> string + = "camlidl_z3_Z3_context_to_string" + +external statistics_to_string : context -> string + = "camlidl_z3_Z3_statistics_to_string" + +external get_context_assignment : context -> ast + = "camlidl_z3_Z3_get_context_assignment" + +external parse_smtlib_string : context -> string -> symbol array -> sort array -> symbol array -> func_decl array -> unit + = "camlidl_z3_Z3_parse_smtlib_string_bytecode" "camlidl_z3_Z3_parse_smtlib_string" + +external parse_smtlib_file : context -> string -> symbol array -> sort array -> symbol array -> func_decl array -> unit + = "camlidl_z3_Z3_parse_smtlib_file_bytecode" "camlidl_z3_Z3_parse_smtlib_file" + +external get_smtlib_num_formulas : context -> int + = "camlidl_z3_Z3_get_smtlib_num_formulas" + +external get_smtlib_formula : context -> int -> ast + = "camlidl_z3_Z3_get_smtlib_formula" + +external get_smtlib_num_assumptions : context -> int + = "camlidl_z3_Z3_get_smtlib_num_assumptions" + +external get_smtlib_assumption : context -> int -> ast + = "camlidl_z3_Z3_get_smtlib_assumption" + +external get_smtlib_num_decls : context -> int + = "camlidl_z3_Z3_get_smtlib_num_decls" + +external get_smtlib_decl : context -> int -> func_decl + = "camlidl_z3_Z3_get_smtlib_decl" + +external get_smtlib_num_sorts : context -> int + = "camlidl_z3_Z3_get_smtlib_num_sorts" + +external get_smtlib_sort : context -> int -> sort + = "camlidl_z3_Z3_get_smtlib_sort" + +external get_smtlib_error : context -> string + = "camlidl_z3_Z3_get_smtlib_error" + +external parse_z3_string : context -> string -> ast + = "camlidl_z3_Z3_parse_z3_string" + +external parse_z3_file : context -> string -> ast + = "camlidl_z3_Z3_parse_z3_file" + +external parse_smtlib2_string : context -> string -> symbol array -> sort array -> symbol array -> func_decl array -> ast + = "camlidl_z3_Z3_parse_smtlib2_string_bytecode" "camlidl_z3_Z3_parse_smtlib2_string" + +external parse_smtlib2_file : context -> string -> symbol array -> sort array -> symbol array -> func_decl array -> ast + = "camlidl_z3_Z3_parse_smtlib2_file_bytecode" "camlidl_z3_Z3_parse_smtlib2_file" + +external get_version : unit -> int * int * int * int + = "camlidl_z3_Z3_get_version" + +external reset_memory : unit -> unit + = "camlidl_z3_Z3_reset_memory" + +external theory_mk_sort : context -> theory -> symbol -> sort + = "camlidl_z3_Z3_theory_mk_sort" + +external theory_mk_value : context -> theory -> symbol -> sort -> ast + = "camlidl_z3_Z3_theory_mk_value" + +external theory_mk_constant : context -> theory -> symbol -> sort -> ast + = "camlidl_z3_Z3_theory_mk_constant" + +external theory_mk_func_decl : context -> theory -> symbol -> sort array -> sort -> func_decl + = "camlidl_z3_Z3_theory_mk_func_decl" + +external theory_get_context : theory -> context + = "camlidl_z3_Z3_theory_get_context" + +external theory_assert_axiom : theory -> ast -> unit + = "camlidl_z3_Z3_theory_assert_axiom" + +external theory_assume_eq : theory -> ast -> ast -> unit + = "camlidl_z3_Z3_theory_assume_eq" + +external theory_enable_axiom_simplification : theory -> bool -> unit + = "camlidl_z3_Z3_theory_enable_axiom_simplification" + +external theory_get_eqc_root : theory -> ast -> ast + = "camlidl_z3_Z3_theory_get_eqc_root" + +external theory_get_eqc_next : theory -> ast -> ast + = "camlidl_z3_Z3_theory_get_eqc_next" + +external theory_get_num_parents : theory -> ast -> int + = "camlidl_z3_Z3_theory_get_num_parents" + +external theory_get_parent : theory -> ast -> int -> ast + = "camlidl_z3_Z3_theory_get_parent" + +external theory_is_value : theory -> ast -> bool + = "camlidl_z3_Z3_theory_is_value" + +external theory_is_decl : theory -> func_decl -> bool + = "camlidl_z3_Z3_theory_is_decl" + +external theory_get_num_elems : theory -> int + = "camlidl_z3_Z3_theory_get_num_elems" + +external theory_get_elem : theory -> int -> ast + = "camlidl_z3_Z3_theory_get_elem" + +external theory_get_num_apps : theory -> int + = "camlidl_z3_Z3_theory_get_num_apps" + +external theory_get_app : theory -> int -> ast + = "camlidl_z3_Z3_theory_get_app" + +external datalog_add_rule : context -> ast -> symbol -> unit + = "camlidl_z3_Z3_datalog_add_rule" + +external datalog_query : context -> ast -> ast + = "camlidl_z3_Z3_datalog_query" + +external datalog_set_predicate_representation : context -> func_decl -> symbol array -> unit + = "camlidl_z3_Z3_datalog_set_predicate_representation" + +external datalog_parse_file : context -> string -> unit + = "camlidl_z3_Z3_datalog_parse_file" + + + + +(* Internal auxillary functions: *) + +(* Transform a pair of arrays into an array of pairs *) +let array_combine a b = + if Array.length a <> Array.length b then raise (Invalid_argument "array_combine"); + Array.init (Array.length a) (fun i->(a.(i),b.(i)));; + +(* [a |> b] is the pipeline operator for [b(a)] *) +let ( |> ) x f = f x;; + + +(* Extensions, except for refinement: *) +let mk_context_x configs = + let config = mk_config() in + let f(param_id,param_value) = set_param_value config param_id param_value in + Array.iter f configs; + let context = mk_context config in + del_config config; + context;; + +let get_app_args c a = + Array.init (get_app_num_args c a) (get_app_arg c a);; + +let get_domains c d = + Array.init (get_domain_size c d) (get_domain c d);; + +let get_array_sort c t = (get_array_sort_domain c t, get_array_sort_range c t);; + +let get_tuple_sort c ty = + (get_tuple_sort_mk_decl c ty, + Array.init (get_tuple_sort_num_fields c ty) (get_tuple_sort_field_decl c ty));; + +type datatype_constructor_refined = { + constructor : func_decl; + recognizer : func_decl; + accessors : func_decl array +} + +let get_datatype_sort c ty = + Array.init (get_datatype_sort_num_constructors c ty) + (fun idx_c -> + let constr = get_datatype_sort_constructor c ty idx_c in + let recog = get_datatype_sort_recognizer c ty idx_c in + let num_acc = get_domain_size c constr in + { constructor = constr; + recognizer = recog; + accessors = Array.init num_acc (get_datatype_sort_constructor_accessor c ty idx_c); + }) + +let get_model_constants c m = + Array.init (get_model_num_constants c m) (get_model_constant c m);; + + +let get_model_func_entry c m i j = + (Array.init + (get_model_func_entry_num_args c m i j) + (get_model_func_entry_arg c m i j), + get_model_func_entry_value c m i j);; + +let get_model_func_entries c m i = + Array.init (get_model_func_num_entries c m i) (get_model_func_entry c m i);; + +let get_model_funcs c m = + Array.init (get_model_num_funcs c m) + (fun i->(get_model_func_decl c m i |> get_decl_name c, + get_model_func_entries c m i, + get_model_func_else c m i));; + +let get_smtlib_formulas c = + Array.init (get_smtlib_num_formulas c) (get_smtlib_formula c);; + +let get_smtlib_assumptions c = + Array.init (get_smtlib_num_assumptions c) (get_smtlib_assumption c);; + +let get_smtlib_decls c = + Array.init (get_smtlib_num_decls c) (get_smtlib_decl c);; + +let get_smtlib_parse_results c = + (get_smtlib_formulas c, get_smtlib_assumptions c, get_smtlib_decls c);; + +let parse_smtlib_string_formula c a1 a2 a3 a4 a5 = + (parse_smtlib_string c a1 a2 a3 a4 a5; + match get_smtlib_formulas c with [|f|] -> f | _ -> failwith "Z3: parse_smtlib_string_formula");; + +let parse_smtlib_file_formula c a1 a2 a3 a4 a5 = + (parse_smtlib_file c a1 a2 a3 a4 a5; + match get_smtlib_formulas c with [|f|] -> f | _ -> failwith "Z3: parse_smtlib_file_formula");; + +let parse_smtlib_string_x c a1 a2 a3 a4 a5 = + (parse_smtlib_string c a1 a2 a3 a4 a5; get_smtlib_parse_results c);; + +let parse_smtlib_file_x c a1 a2 a3 a4 a5 = + (parse_smtlib_file c a1 a2 a3 a4 a5; get_smtlib_parse_results c);; + +(* Refinement: *) + +type symbol_refined = + | Symbol_int of int + | Symbol_string of string + | Symbol_unknown;; + +let symbol_refine c s = + match get_symbol_kind c s with + | INT_SYMBOL -> Symbol_int (get_symbol_int c s) + | STRING_SYMBOL -> Symbol_string (get_symbol_string c s);; + +type sort_refined = + | Sort_uninterpreted of symbol + | Sort_bool + | Sort_int + | Sort_real + | Sort_bv of int + | Sort_array of (sort * sort) + | Sort_datatype of datatype_constructor_refined array + | Sort_relation + | Sort_finite_domain + | Sort_unknown of symbol;; + +let sort_refine c ty = + match get_sort_kind c ty with + | UNINTERPRETED_SORT -> Sort_uninterpreted (get_sort_name c ty) + | BOOL_SORT -> Sort_bool + | INT_SORT -> Sort_int + | REAL_SORT -> Sort_real + | BV_SORT -> Sort_bv (get_bv_sort_size c ty) + | ARRAY_SORT -> Sort_array (get_array_sort_domain c ty, get_array_sort_range c ty) + | DATATYPE_SORT -> Sort_datatype (get_datatype_sort c ty) + | RELATION_SORT -> Sort_relation + | FINITE_DOMAIN_SORT -> Sort_finite_domain + | UNKNOWN_SORT -> Sort_unknown (get_sort_name c ty);; + +let get_pattern_terms c p = + Array.init (get_pattern_num_terms c p) (get_pattern c p) + +type binder_type = | Forall | Exists + +type numeral_refined = + | Numeral_small of int64 * int64 + | Numeral_large of string + +type term_refined = + | Term_app of decl_kind * func_decl * ast array + | Term_quantifier of binder_type * int * ast array array * (symbol *sort) array * ast + | Term_numeral of numeral_refined * sort + | Term_var of int * sort + +let term_refine c t = + match get_ast_kind c t with + | NUMERAL_AST -> + let (is_small, n, d) = get_numeral_small c t in + if is_small then + Term_numeral(Numeral_small(n,d), get_sort c t) + else + Term_numeral(Numeral_large(get_numeral_string c t), get_sort c t) + | APP_AST -> + let t' = to_app c t in + let f = get_app_decl c t' in + let num_args = get_app_num_args c t' in + let args = Array.init num_args (get_app_arg c t') in + let k = get_decl_kind c f in + Term_app (k, f, args) + | QUANTIFIER_AST -> + let bt = if is_quantifier_forall c t then Forall else Exists in + let w = get_quantifier_weight c t in + let np = get_quantifier_num_patterns c t in + let pats = Array.init np (get_quantifier_pattern_ast c t) in + let pats = Array.map (get_pattern_terms c) pats in + let nb = get_quantifier_num_bound c t in + let bound = Array.init nb + (fun i -> (get_quantifier_bound_name c t i, get_quantifier_bound_sort c t i)) in + let body = get_quantifier_body c t in + Term_quantifier(bt, w, pats, bound, body) + | VAR_AST -> + Term_var(get_index_value c t, get_sort c t) + | _ -> assert false + + +type theory_callbacks = + { + mutable delete_theory : unit -> unit; + mutable reduce_eq : ast -> ast -> ast option; + mutable reduce_app : func_decl -> ast array -> ast option; + mutable reduce_distinct : ast array -> ast option; + mutable final_check : unit -> bool; + mutable new_app : ast -> unit; + mutable new_elem : ast -> unit; + mutable init_search: unit -> unit; + mutable push: unit -> unit; + mutable pop: unit -> unit; + mutable restart : unit -> unit; + mutable reset: unit -> unit; + mutable new_eq : ast -> ast -> unit; + mutable new_diseq : ast -> ast -> unit; + mutable new_assignment: ast -> bool -> unit; + mutable new_relevant : ast -> unit; + } + +let mk_theory_callbacks() = + { + delete_theory = (fun () -> ()); + reduce_eq = (fun _ _ -> None); + reduce_app = (fun _ _ -> None); + reduce_distinct = (fun _ -> None); + final_check = (fun _ -> true); + new_app = (fun _ -> ()); + new_elem = (fun _ -> ()); + init_search= (fun () -> ()); + push= (fun () -> ()); + pop= (fun () -> ()); + restart = (fun () -> ()); + reset= (fun () -> ()); + new_eq = (fun _ _ -> ()); + new_diseq = (fun _ _ -> ()); + new_assignment = (fun _ _ -> ()); + new_relevant = (fun _ -> ()); + } + + +external get_theory_callbacks : theory -> theory_callbacks = "get_theory_callbacks" +external mk_theory_register : context -> string -> theory_callbacks -> theory = "mk_theory_register" +external set_delete_callback_register : theory -> unit = "set_delete_callback_register" +external set_reduce_app_callback_register : theory -> unit = "set_reduce_app_callback_register" +external set_reduce_eq_callback_register : theory -> unit = "set_reduce_eq_callback_register" +external set_reduce_distinct_callback_register : theory -> unit = "set_reduce_distinct_callback_register" +external set_new_app_callback_register : theory -> unit = "set_new_app_callback_register" +external set_new_elem_callback_register : theory -> unit = "set_new_elem_callback_register" +external set_init_search_callback_register : theory -> unit = "set_init_search_callback_register" +external set_push_callback_register : theory -> unit = "set_push_callback_register" +external set_pop_callback_register : theory -> unit = "set_pop_callback_register" +external set_restart_callback_register : theory -> unit = "set_restart_callback_register" +external set_reset_callback_register : theory -> unit = "set_reset_callback_register" +external set_final_check_callback_register : theory -> unit = "set_final_check_callback_register" +external set_new_eq_callback_register : theory -> unit = "set_new_eq_callback_register" +external set_new_diseq_callback_register : theory -> unit = "set_new_diseq_callback_register" +external set_new_assignment_callback_register : theory -> unit = "set_new_assignment_callback_register" +external set_new_relevant_callback_register : theory -> unit = "set_new_relevant_callback_register" + +let is_some opt = + match opt with + | Some v -> true + | None -> false + +let get_some opt = + match opt with + | Some v -> v + | None -> failwith "None unexpected" + + + + +let apply_delete (th:theory_callbacks) = th.delete_theory () +let set_delete_callback th cb = + let cbs = get_theory_callbacks th in + cbs.delete_theory <- cb; + set_delete_callback_register th + +let mk_theory context name = + Callback.register "is_some" is_some; + Callback.register "get_some" get_some; + Callback.register "apply_delete" apply_delete; + let cbs = mk_theory_callbacks() in + mk_theory_register context name cbs + + +let apply_reduce_app (th:theory_callbacks) f args = th.reduce_app f args +let set_reduce_app_callback th cb = + Callback.register "apply_reduce_app" apply_reduce_app; + let cbs = get_theory_callbacks th in + cbs.reduce_app <- cb; + set_reduce_app_callback_register th + +let apply_reduce_eq (th:theory_callbacks) a b = th.reduce_eq a b +let set_reduce_eq_callback th cb = + Callback.register "apply_reduce_eq" apply_reduce_eq; + let cbs = get_theory_callbacks th in + cbs.reduce_eq <- cb; + set_reduce_eq_callback_register th + +let apply_reduce_distinct (th:theory_callbacks) args = th.reduce_distinct args +let set_reduce_distinct_callback th cb = + Callback.register "apply_reduce_distinct" apply_reduce_distinct; + let cbs = get_theory_callbacks th in + cbs.reduce_distinct <- cb; + set_reduce_distinct_callback_register th + + +let apply_new_app (th:theory_callbacks) a = th.new_app a +let set_new_app_callback th cb = + Callback.register "apply_new_app" apply_new_app; + let cbs = get_theory_callbacks th in + cbs.new_app <- cb; + set_new_app_callback_register th + +let apply_new_elem (th:theory_callbacks) a = th.new_elem a +let set_new_elem_callback th cb = + Callback.register "apply_new_elem" apply_new_elem; + let cbs = get_theory_callbacks th in + cbs.new_elem <- cb; + set_new_elem_callback_register th + + +let apply_init_search (th:theory_callbacks) = th.init_search() +let set_init_search_callback th cb = + Callback.register "apply_init_search" apply_init_search; + let cbs = get_theory_callbacks th in + cbs.init_search <- cb; + set_init_search_callback_register th + + +let apply_push (th:theory_callbacks) = th.push() +let set_push_callback th cb = + Callback.register "apply_push" apply_push; + let cbs = get_theory_callbacks th in + cbs.push <- cb; + set_push_callback_register th + +let apply_pop (th:theory_callbacks) = th.pop() +let set_pop_callback th cb = + Callback.register "apply_pop" apply_pop; + let cbs = get_theory_callbacks th in + cbs.pop <- cb; + set_pop_callback_register th + + +let apply_restart (th:theory_callbacks) = th.restart() +let set_restart_callback th cb = + Callback.register "apply_restart" apply_restart; + let cbs = get_theory_callbacks th in + cbs.restart <- cb; + set_restart_callback_register th + + +let apply_reset (th:theory_callbacks) = th.reset() +let set_reset_callback th cb = + Callback.register "apply_reset" apply_reset; + let cbs = get_theory_callbacks th in + cbs.reset <- cb; + set_reset_callback_register th + +let apply_final_check (th:theory_callbacks) = th.final_check() +let set_final_check_callback th cb = + Callback.register "apply_final_check" apply_final_check; + let cbs = get_theory_callbacks th in + cbs.final_check <- cb; + set_final_check_callback_register th + +let apply_new_eq (th:theory_callbacks) a b = th.new_eq a b +let set_new_eq_callback th cb = + Callback.register "apply_new_eq" apply_new_eq; + let cbs = get_theory_callbacks th in + cbs.new_eq <- cb; + set_new_eq_callback_register th + + +let apply_new_diseq (th:theory_callbacks) a b = th.new_diseq a b +let set_new_diseq_callback th cb = + Callback.register "apply_new_diseq" apply_new_diseq; + let cbs = get_theory_callbacks th in + cbs.new_diseq <- cb; + set_new_diseq_callback_register th + +let apply_new_assignment (th:theory_callbacks) a b = th.new_assignment a b +let set_new_assignment_callback th cb = + Callback.register "apply_new_assignment" apply_new_assignment; + let cbs = get_theory_callbacks th in + cbs.new_assignment <- cb; + set_new_assignment_callback_register th + +let apply_new_relevant (th:theory_callbacks) a = th.new_relevant a +let set_new_relevant_callback th cb = + Callback.register "apply_new_relevant" apply_new_relevant; + let cbs = get_theory_callbacks th in + cbs.new_relevant <- cb; + set_new_relevant_callback_register th + + + + + diff --git a/external/z3/ocaml/z3_stubs.c b/external/z3/ocaml/z3_stubs.c new file mode 100644 --- /dev/null +++ b/external/z3/ocaml/z3_stubs.c @@ -0,0 +1,7761 @@ +/* File generated from z3.idl */ + +#include +#include +#include +#include +#include +#include +#include +#ifdef Custom_tag +#include +#include +#endif +#include + + +#include "z3.h" + +#pragma warning(disable:4090) +#ifndef __int64 +#define __int64 long long +#endif +Z3_error_handler caml_z3_error_handler; +void caml_z3_error_handler(Z3_error_code e) { static char buffer[128]; char * msg = Z3_get_error_msg(e); if (strlen(msg) > 100) { failwith("Z3: error message is too big"); } else { sprintf(buffer, "Z3: %s", msg); failwith(buffer); } } +void camlidl_ml2c_z3_Z3_config(value _v1, Z3_config * _c2, camlidl_ctx _ctx) +{ + *_c2 = *((Z3_config *) Bp_val(_v1)); +} + +value camlidl_c2ml_z3_Z3_config(Z3_config * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_alloc((sizeof(Z3_config) + sizeof(value) - 1) / sizeof(value), Abstract_tag); + *((Z3_config *) Bp_val(_v1)) = *_c2; + return _v1; +} + +void camlidl_ml2c_z3_Z3_context(value _v1, Z3_context * _c2, camlidl_ctx _ctx) +{ + *_c2 = *((Z3_context *) Bp_val(_v1)); +} + +value camlidl_c2ml_z3_Z3_context(Z3_context * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_alloc((sizeof(Z3_context) + sizeof(value) - 1) / sizeof(value), Abstract_tag); + *((Z3_context *) Bp_val(_v1)) = *_c2; + return _v1; +} + +void camlidl_ml2c_z3_Z3_sort(value _v1, Z3_sort * _c2, camlidl_ctx _ctx) +{ + *_c2 = *((Z3_sort *) Bp_val(_v1)); +} + +value camlidl_c2ml_z3_Z3_sort(Z3_sort * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_alloc((sizeof(Z3_sort) + sizeof(value) - 1) / sizeof(value), Abstract_tag); + *((Z3_sort *) Bp_val(_v1)) = *_c2; + return _v1; +} + +void camlidl_ml2c_z3_Z3_func_decl(value _v1, Z3_func_decl * _c2, camlidl_ctx _ctx) +{ + *_c2 = *((Z3_func_decl *) Bp_val(_v1)); +} + +value camlidl_c2ml_z3_Z3_func_decl(Z3_func_decl * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_alloc((sizeof(Z3_func_decl) + sizeof(value) - 1) / sizeof(value), Abstract_tag); + *((Z3_func_decl *) Bp_val(_v1)) = *_c2; + return _v1; +} + +void camlidl_ml2c_z3_Z3_ast(value _v1, Z3_ast * _c2, camlidl_ctx _ctx) +{ + *_c2 = *((Z3_ast *) Bp_val(_v1)); +} + +value camlidl_c2ml_z3_Z3_ast(Z3_ast * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_alloc((sizeof(Z3_ast) + sizeof(value) - 1) / sizeof(value), Abstract_tag); + *((Z3_ast *) Bp_val(_v1)) = *_c2; + return _v1; +} + +void camlidl_ml2c_z3_Z3_app(value _v1, Z3_app * _c2, camlidl_ctx _ctx) +{ + *_c2 = *((Z3_app *) Bp_val(_v1)); +} + +value camlidl_c2ml_z3_Z3_app(Z3_app * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_alloc((sizeof(Z3_app) + sizeof(value) - 1) / sizeof(value), Abstract_tag); + *((Z3_app *) Bp_val(_v1)) = *_c2; + return _v1; +} + +void camlidl_ml2c_z3_Z3_pattern(value _v1, Z3_pattern * _c2, camlidl_ctx _ctx) +{ + *_c2 = *((Z3_pattern *) Bp_val(_v1)); +} + +value camlidl_c2ml_z3_Z3_pattern(Z3_pattern * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_alloc((sizeof(Z3_pattern) + sizeof(value) - 1) / sizeof(value), Abstract_tag); + *((Z3_pattern *) Bp_val(_v1)) = *_c2; + return _v1; +} + +void camlidl_ml2c_z3_Z3_symbol(value _v1, Z3_symbol * _c2, camlidl_ctx _ctx) +{ + *_c2 = *((Z3_symbol *) Bp_val(_v1)); +} + +value camlidl_c2ml_z3_Z3_symbol(Z3_symbol * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_alloc((sizeof(Z3_symbol) + sizeof(value) - 1) / sizeof(value), Abstract_tag); + *((Z3_symbol *) Bp_val(_v1)) = *_c2; + return _v1; +} + +void camlidl_ml2c_z3_Z3_parameter(value _v1, Z3_parameter * _c2, camlidl_ctx _ctx) +{ + *_c2 = *((Z3_parameter *) Bp_val(_v1)); +} + +value camlidl_c2ml_z3_Z3_parameter(Z3_parameter * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_alloc((sizeof(Z3_parameter) + sizeof(value) - 1) / sizeof(value), Abstract_tag); + *((Z3_parameter *) Bp_val(_v1)) = *_c2; + return _v1; +} + +void camlidl_ml2c_z3_Z3_model(value _v1, Z3_model * _c2, camlidl_ctx _ctx) +{ + *_c2 = *((Z3_model *) Bp_val(_v1)); +} + +value camlidl_c2ml_z3_Z3_model(Z3_model * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_alloc((sizeof(Z3_model) + sizeof(value) - 1) / sizeof(value), Abstract_tag); + *((Z3_model *) Bp_val(_v1)) = *_c2; + return _v1; +} + +void camlidl_ml2c_z3_Z3_literals(value _v1, Z3_literals * _c2, camlidl_ctx _ctx) +{ + *_c2 = *((Z3_literals *) Bp_val(_v1)); +} + +value camlidl_c2ml_z3_Z3_literals(Z3_literals * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_alloc((sizeof(Z3_literals) + sizeof(value) - 1) / sizeof(value), Abstract_tag); + *((Z3_literals *) Bp_val(_v1)) = *_c2; + return _v1; +} + +void camlidl_ml2c_z3_Z3_constructor(value _v1, Z3_constructor * _c2, camlidl_ctx _ctx) +{ + *_c2 = *((Z3_constructor *) Bp_val(_v1)); +} + +value camlidl_c2ml_z3_Z3_constructor(Z3_constructor * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_alloc((sizeof(Z3_constructor) + sizeof(value) - 1) / sizeof(value), Abstract_tag); + *((Z3_constructor *) Bp_val(_v1)) = *_c2; + return _v1; +} + +void camlidl_ml2c_z3_Z3_constructor_list(value _v1, Z3_constructor_list * _c2, camlidl_ctx _ctx) +{ + *_c2 = *((Z3_constructor_list *) Bp_val(_v1)); +} + +value camlidl_c2ml_z3_Z3_constructor_list(Z3_constructor_list * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_alloc((sizeof(Z3_constructor_list) + sizeof(value) - 1) / sizeof(value), Abstract_tag); + *((Z3_constructor_list *) Bp_val(_v1)) = *_c2; + return _v1; +} + +void camlidl_ml2c_z3_Z3_theory(value _v1, Z3_theory * _c2, camlidl_ctx _ctx) +{ + *_c2 = *((Z3_theory *) Bp_val(_v1)); +} + +value camlidl_c2ml_z3_Z3_theory(Z3_theory * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_alloc((sizeof(Z3_theory) + sizeof(value) - 1) / sizeof(value), Abstract_tag); + *((Z3_theory *) Bp_val(_v1)) = *_c2; + return _v1; +} + +void camlidl_ml2c_z3_Z3_theory_data(value _v1, Z3_theory_data * _c2, camlidl_ctx _ctx) +{ + *_c2 = *((Z3_theory_data *) Bp_val(_v1)); +} + +value camlidl_c2ml_z3_Z3_theory_data(Z3_theory_data * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_alloc((sizeof(Z3_theory_data) + sizeof(value) - 1) / sizeof(value), Abstract_tag); + *((Z3_theory_data *) Bp_val(_v1)) = *_c2; + return _v1; +} + +int camlidl_transl_table_z3_enum_1[3] = { + Z3_L_FALSE, + Z3_L_UNDEF, + Z3_L_TRUE, +}; + +void camlidl_ml2c_z3_Z3_lbool(value _v1, Z3_lbool * _c2, camlidl_ctx _ctx) +{ + (*_c2) = camlidl_transl_table_z3_enum_1[Int_val(_v1)]; +} + +value camlidl_c2ml_z3_Z3_lbool(Z3_lbool * _c2, camlidl_ctx _ctx) +{ +value _v1; + switch((*_c2)) { + case Z3_L_FALSE: _v1 = Val_int(0); break; + case Z3_L_UNDEF: _v1 = Val_int(1); break; + case Z3_L_TRUE: _v1 = Val_int(2); break; + default: invalid_argument("typedef Z3_lbool: bad enum value"); + } + return _v1; +} + +int camlidl_transl_table_z3_enum_2[2] = { + Z3_INT_SYMBOL, + Z3_STRING_SYMBOL, +}; + +void camlidl_ml2c_z3_Z3_symbol_kind(value _v1, Z3_symbol_kind * _c2, camlidl_ctx _ctx) +{ + (*_c2) = camlidl_transl_table_z3_enum_2[Int_val(_v1)]; +} + +value camlidl_c2ml_z3_Z3_symbol_kind(Z3_symbol_kind * _c2, camlidl_ctx _ctx) +{ +value _v1; + switch((*_c2)) { + case Z3_INT_SYMBOL: _v1 = Val_int(0); break; + case Z3_STRING_SYMBOL: _v1 = Val_int(1); break; + default: invalid_argument("typedef Z3_symbol_kind: bad enum value"); + } + return _v1; +} + +int camlidl_transl_table_z3_enum_3[7] = { + Z3_PARAMETER_INT, + Z3_PARAMETER_DOUBLE, + Z3_PARAMETER_RATIONAL, + Z3_PARAMETER_SYMBOL, + Z3_PARAMETER_SORT, + Z3_PARAMETER_AST, + Z3_PARAMETER_FUNC_DECL, +}; + +void camlidl_ml2c_z3_Z3_parameter_kind(value _v1, Z3_parameter_kind * _c2, camlidl_ctx _ctx) +{ + (*_c2) = camlidl_transl_table_z3_enum_3[Int_val(_v1)]; +} + +value camlidl_c2ml_z3_Z3_parameter_kind(Z3_parameter_kind * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_find_enum((*_c2), camlidl_transl_table_z3_enum_3, 7, "typedef Z3_parameter_kind: bad enum value"); + return _v1; +} + +int camlidl_transl_table_z3_enum_4[10] = { + Z3_UNINTERPRETED_SORT, + Z3_BOOL_SORT, + Z3_INT_SORT, + Z3_REAL_SORT, + Z3_BV_SORT, + Z3_ARRAY_SORT, + Z3_DATATYPE_SORT, + Z3_RELATION_SORT, + Z3_FINITE_DOMAIN_SORT, + Z3_UNKNOWN_SORT, +}; + +void camlidl_ml2c_z3_Z3_sort_kind(value _v1, Z3_sort_kind * _c2, camlidl_ctx _ctx) +{ + (*_c2) = camlidl_transl_table_z3_enum_4[Int_val(_v1)]; +} + +value camlidl_c2ml_z3_Z3_sort_kind(Z3_sort_kind * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_find_enum((*_c2), camlidl_transl_table_z3_enum_4, 10, "typedef Z3_sort_kind: bad enum value"); + return _v1; +} + +int camlidl_transl_table_z3_enum_5[5] = { + Z3_NUMERAL_AST, + Z3_APP_AST, + Z3_VAR_AST, + Z3_QUANTIFIER_AST, + Z3_UNKNOWN_AST, +}; + +void camlidl_ml2c_z3_Z3_ast_kind(value _v1, Z3_ast_kind * _c2, camlidl_ctx _ctx) +{ + (*_c2) = camlidl_transl_table_z3_enum_5[Int_val(_v1)]; +} + +value camlidl_c2ml_z3_Z3_ast_kind(Z3_ast_kind * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_find_enum((*_c2), camlidl_transl_table_z3_enum_5, 5, "typedef Z3_ast_kind: bad enum value"); + return _v1; +} + +int camlidl_transl_table_z3_enum_6[144] = { + Z3_OP_TRUE, + Z3_OP_FALSE, + Z3_OP_EQ, + Z3_OP_DISTINCT, + Z3_OP_ITE, + Z3_OP_AND, + Z3_OP_OR, + Z3_OP_IFF, + Z3_OP_XOR, + Z3_OP_NOT, + Z3_OP_IMPLIES, + Z3_OP_OEQ, + Z3_OP_ANUM, + Z3_OP_LE, + Z3_OP_GE, + Z3_OP_LT, + Z3_OP_GT, + Z3_OP_ADD, + Z3_OP_SUB, + Z3_OP_UMINUS, + Z3_OP_MUL, + Z3_OP_DIV, + Z3_OP_IDIV, + Z3_OP_REM, + Z3_OP_MOD, + Z3_OP_TO_REAL, + Z3_OP_TO_INT, + Z3_OP_IS_INT, + Z3_OP_STORE, + Z3_OP_SELECT, + Z3_OP_CONST_ARRAY, + Z3_OP_ARRAY_MAP, + Z3_OP_ARRAY_DEFAULT, + Z3_OP_SET_UNION, + Z3_OP_SET_INTERSECT, + Z3_OP_SET_DIFFERENCE, + Z3_OP_SET_COMPLEMENT, + Z3_OP_SET_SUBSET, + Z3_OP_AS_ARRAY, + Z3_OP_BNUM, + Z3_OP_BIT1, + Z3_OP_BIT0, + Z3_OP_BNEG, + Z3_OP_BADD, + Z3_OP_BSUB, + Z3_OP_BMUL, + Z3_OP_BSDIV, + Z3_OP_BUDIV, + Z3_OP_BSREM, + Z3_OP_BUREM, + Z3_OP_BSMOD, + Z3_OP_BSDIV0, + Z3_OP_BUDIV0, + Z3_OP_BSREM0, + Z3_OP_BUREM0, + Z3_OP_BSMOD0, + Z3_OP_ULEQ, + Z3_OP_SLEQ, + Z3_OP_UGEQ, + Z3_OP_SGEQ, + Z3_OP_ULT, + Z3_OP_SLT, + Z3_OP_UGT, + Z3_OP_SGT, + Z3_OP_BAND, + Z3_OP_BOR, + Z3_OP_BNOT, + Z3_OP_BXOR, + Z3_OP_BNAND, + Z3_OP_BNOR, + Z3_OP_BXNOR, + Z3_OP_CONCAT, + Z3_OP_SIGN_EXT, + Z3_OP_ZERO_EXT, + Z3_OP_EXTRACT, + Z3_OP_REPEAT, + Z3_OP_BREDOR, + Z3_OP_BREDAND, + Z3_OP_BCOMP, + Z3_OP_BSHL, + Z3_OP_BLSHR, + Z3_OP_BASHR, + Z3_OP_ROTATE_LEFT, + Z3_OP_ROTATE_RIGHT, + Z3_OP_EXT_ROTATE_LEFT, + Z3_OP_EXT_ROTATE_RIGHT, + Z3_OP_INT2BV, + Z3_OP_BV2INT, + Z3_OP_CARRY, + Z3_OP_XOR3, + Z3_OP_PR_UNDEF, + Z3_OP_PR_TRUE, + Z3_OP_PR_ASSERTED, + Z3_OP_PR_GOAL, + Z3_OP_PR_MODUS_PONENS, + Z3_OP_PR_REFLEXIVITY, + Z3_OP_PR_SYMMETRY, + Z3_OP_PR_TRANSITIVITY, + Z3_OP_PR_TRANSITIVITY_STAR, + Z3_OP_PR_MONOTONICITY, + Z3_OP_PR_QUANT_INTRO, + Z3_OP_PR_DISTRIBUTIVITY, + Z3_OP_PR_AND_ELIM, + Z3_OP_PR_NOT_OR_ELIM, + Z3_OP_PR_REWRITE, + Z3_OP_PR_REWRITE_STAR, + Z3_OP_PR_PULL_QUANT, + Z3_OP_PR_PULL_QUANT_STAR, + Z3_OP_PR_PUSH_QUANT, + Z3_OP_PR_ELIM_UNUSED_VARS, + Z3_OP_PR_DER, + Z3_OP_PR_QUANT_INST, + Z3_OP_PR_HYPOTHESIS, + Z3_OP_PR_LEMMA, + Z3_OP_PR_UNIT_RESOLUTION, + Z3_OP_PR_IFF_TRUE, + Z3_OP_PR_IFF_FALSE, + Z3_OP_PR_COMMUTATIVITY, + Z3_OP_PR_DEF_AXIOM, + Z3_OP_PR_DEF_INTRO, + Z3_OP_PR_APPLY_DEF, + Z3_OP_PR_IFF_OEQ, + Z3_OP_PR_NNF_POS, + Z3_OP_PR_NNF_NEG, + Z3_OP_PR_NNF_STAR, + Z3_OP_PR_CNF_STAR, + Z3_OP_PR_SKOLEMIZE, + Z3_OP_PR_MODUS_PONENS_OEQ, + Z3_OP_PR_TH_LEMMA, + Z3_OP_RA_STORE, + Z3_OP_RA_EMPTY, + Z3_OP_RA_IS_EMPTY, + Z3_OP_RA_JOIN, + Z3_OP_RA_UNION, + Z3_OP_RA_WIDEN, + Z3_OP_RA_PROJECT, + Z3_OP_RA_FILTER, + Z3_OP_RA_NEGATION_FILTER, + Z3_OP_RA_RENAME, + Z3_OP_RA_COMPLEMENT, + Z3_OP_RA_SELECT, + Z3_OP_RA_CLONE, + Z3_OP_FD_LT, + Z3_OP_UNINTERPRETED, +}; + +void camlidl_ml2c_z3_Z3_decl_kind(value _v1, Z3_decl_kind * _c2, camlidl_ctx _ctx) +{ + (*_c2) = camlidl_transl_table_z3_enum_6[Int_val(_v1)]; +} + +value camlidl_c2ml_z3_Z3_decl_kind(Z3_decl_kind * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_find_enum((*_c2), camlidl_transl_table_z3_enum_6, 144, "typedef Z3_decl_kind: bad enum value"); + return _v1; +} + +int camlidl_transl_table_z3_enum_7[8] = { + Z3_NO_FAILURE, + Z3_UNKNOWN, + Z3_TIMEOUT, + Z3_MEMOUT_WATERMARK, + Z3_CANCELED, + Z3_NUM_CONFLICTS, + Z3_THEORY, + Z3_QUANTIFIERS, +}; + +void camlidl_ml2c_z3_Z3_search_failure(value _v1, Z3_search_failure * _c2, camlidl_ctx _ctx) +{ + (*_c2) = camlidl_transl_table_z3_enum_7[Int_val(_v1)]; +} + +value camlidl_c2ml_z3_Z3_search_failure(Z3_search_failure * _c2, camlidl_ctx _ctx) +{ +value _v1; + _v1 = camlidl_find_enum((*_c2), camlidl_transl_table_z3_enum_7, 8, "typedef Z3_search_failure: bad enum value"); + return _v1; +} + +int camlidl_transl_table_z3_enum_8[4] = { + Z3_PRINT_SMTLIB_FULL, + Z3_PRINT_LOW_LEVEL, + Z3_PRINT_SMTLIB_COMPLIANT, + Z3_PRINT_SMTLIB2_COMPLIANT, +}; + +void camlidl_ml2c_z3_Z3_ast_print_mode(value _v1, Z3_ast_print_mode * _c2, camlidl_ctx _ctx) +{ + (*_c2) = camlidl_transl_table_z3_enum_8[Int_val(_v1)]; +} + +value camlidl_c2ml_z3_Z3_ast_print_mode(Z3_ast_print_mode * _c2, camlidl_ctx _ctx) +{ +value _v1; + switch((*_c2)) { + case Z3_PRINT_SMTLIB_FULL: _v1 = Val_int(0); break; + case Z3_PRINT_LOW_LEVEL: _v1 = Val_int(1); break; + case Z3_PRINT_SMTLIB_COMPLIANT: _v1 = Val_int(2); break; + case Z3_PRINT_SMTLIB2_COMPLIANT: _v1 = Val_int(3); break; + default: invalid_argument("typedef Z3_ast_print_mode: bad enum value"); + } + return _v1; +} + +value camlidl_z3_Z3_mk_config(value _unit) +{ + Z3_config _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + _res = Z3_mk_config(); + _vres = camlidl_c2ml_z3_Z3_config(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_del_config( + value _v_c) +{ + Z3_config c; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_config(_v_c, &c, _ctx); + Z3_del_config(c); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_set_param_value( + value _v_c, + value _v_param_id, + value _v_param_value) +{ + Z3_config c; /*in*/ + char const *param_id; /*in*/ + char const *param_value; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_config(_v_c, &c, _ctx); + param_id = String_val(_v_param_id); + param_value = String_val(_v_param_value); + Z3_set_param_value(c, param_id, param_value); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_mk_context( + value _v_c) +{ + Z3_config c; /*in*/ + Z3_context _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_config(_v_c, &c, _ctx); + _res = Z3_mk_context(c); + _vres = camlidl_c2ml_z3_Z3_context(&_res, _ctx); + camlidl_free(_ctx); + /* begin user-supplied deallocation sequence */ +Z3_set_error_handler(_res, caml_z3_error_handler); + /* end user-supplied deallocation sequence */ + return _vres; +} + +value camlidl_z3_Z3_mk_context_rc( + value _v_c) +{ + Z3_config c; /*in*/ + Z3_context _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_config(_v_c, &c, _ctx); + _res = Z3_mk_context_rc(c); + _vres = camlidl_c2ml_z3_Z3_context(&_res, _ctx); + camlidl_free(_ctx); + /* begin user-supplied deallocation sequence */ +Z3_set_error_handler(_res, caml_z3_error_handler); + /* end user-supplied deallocation sequence */ + return _vres; +} + +value camlidl_z3_Z3_set_logic( + value _v_c, + value _v_logic) +{ + Z3_context c; /*in*/ + char const *logic; /*in*/ + int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + logic = String_val(_v_logic); + _res = Z3_set_logic(c, logic); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_del_context( + value _v_c) +{ + Z3_context c; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + Z3_del_context(c); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_inc_ref( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + Z3_inc_ref(c, a); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_dec_ref( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + Z3_dec_ref(c, a); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_trace_to_file( + value _v_c, + value _v_trace_file) +{ + Z3_context c; /*in*/ + char const *trace_file; /*in*/ + int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + trace_file = String_val(_v_trace_file); + _res = Z3_trace_to_file(c, trace_file); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_trace_to_stderr( + value _v_c) +{ + Z3_context c; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + Z3_trace_to_stderr(c); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_trace_to_stdout( + value _v_c) +{ + Z3_context c; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + Z3_trace_to_stdout(c); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_trace_off( + value _v_c) +{ + Z3_context c; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + Z3_trace_off(c); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_toggle_warning_messages( + value _v_enabled) +{ + int enabled; /*in*/ + enabled = Int_val(_v_enabled); + Z3_toggle_warning_messages(enabled); + return Val_unit; +} + +value camlidl_z3_Z3_update_param_value( + value _v_c, + value _v_param_id, + value _v_param_value) +{ + Z3_context c; /*in*/ + char const *param_id; /*in*/ + char const *param_value; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + param_id = String_val(_v_param_id); + param_value = String_val(_v_param_value); + Z3_update_param_value(c, param_id, param_value); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_mk_int_symbol( + value _v_c, + value _v_i) +{ + Z3_context c; /*in*/ + int i; /*in*/ + Z3_symbol _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + i = Int_val(_v_i); + _res = Z3_mk_int_symbol(c, i); + _vres = camlidl_c2ml_z3_Z3_symbol(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_string_symbol( + value _v_c, + value _v_s) +{ + Z3_context c; /*in*/ + char const *s; /*in*/ + Z3_symbol _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + s = String_val(_v_s); + _res = Z3_mk_string_symbol(c, s); + _vres = camlidl_c2ml_z3_Z3_symbol(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_is_eq_sort( + value _v_c, + value _v_s1, + value _v_s2) +{ + Z3_context c; /*in*/ + Z3_sort s1; /*in*/ + Z3_sort s2; /*in*/ + int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_s1, &s1, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_s2, &s2, _ctx); + _res = Z3_is_eq_sort(c, s1, s2); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_uninterpreted_sort( + value _v_c, + value _v_s) +{ + Z3_context c; /*in*/ + Z3_symbol s; /*in*/ + Z3_sort _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_s, &s, _ctx); + _res = Z3_mk_uninterpreted_sort(c, s); + _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bool_sort( + value _v_c) +{ + Z3_context c; /*in*/ + Z3_sort _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_mk_bool_sort(c); + _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_int_sort( + value _v_c) +{ + Z3_context c; /*in*/ + Z3_sort _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_mk_int_sort(c); + _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_real_sort( + value _v_c) +{ + Z3_context c; /*in*/ + Z3_sort _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_mk_real_sort(c); + _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bv_sort( + value _v_c, + value _v_sz) +{ + Z3_context c; /*in*/ + unsigned int sz; /*in*/ + Z3_sort _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + sz = Int_val(_v_sz); + _res = Z3_mk_bv_sort(c, sz); + _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_array_sort( + value _v_c, + value _v_domain, + value _v_range) +{ + Z3_context c; /*in*/ + Z3_sort domain; /*in*/ + Z3_sort range; /*in*/ + Z3_sort _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_domain, &domain, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_range, &range, _ctx); + _res = Z3_mk_array_sort(c, domain, range); + _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_tuple_sort( + value _v_c, + value _v_mk_tuple_name, + value _v_field_names, + value _v_field_sorts) +{ + Z3_context c; /*in*/ + Z3_symbol mk_tuple_name; /*in*/ + unsigned int num_fields; /*in*/ + Z3_symbol const *field_names; /*in*/ + Z3_sort const *field_sorts; /*in*/ + Z3_func_decl *mk_tuple_decl; /*out*/ + Z3_func_decl *proj_decl; /*out*/ + Z3_sort _res; + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + mlsize_t _c5; + value _v6; + Z3_func_decl _c7; + mlsize_t _c8; + value _v9; + value _vresult; + value _vres[3] = { 0, 0, 0, }; + + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_mk_tuple_name, &mk_tuple_name, _ctx); + _c1 = Wosize_val(_v_field_names); + field_names = camlidl_malloc(_c1 * sizeof(Z3_symbol const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_field_names, _c2); + camlidl_ml2c_z3_Z3_symbol(_v3, &field_names[_c2], _ctx); + } + num_fields = _c1; + _c4 = Wosize_val(_v_field_sorts); + field_sorts = camlidl_malloc(_c4 * sizeof(Z3_sort const ), _ctx); + for (_c5 = 0; _c5 < _c4; _c5++) { + _v6 = Field(_v_field_sorts, _c5); + camlidl_ml2c_z3_Z3_sort(_v6, &field_sorts[_c5], _ctx); + } + num_fields = _c4; + mk_tuple_decl = &_c7; + proj_decl = camlidl_malloc(num_fields * sizeof(Z3_func_decl ), _ctx); + _res = Z3_mk_tuple_sort(c, mk_tuple_name, num_fields, field_names, field_sorts, mk_tuple_decl, proj_decl); + Begin_roots_block(_vres, 3) + _vres[0] = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + _vres[1] = camlidl_c2ml_z3_Z3_func_decl(&*mk_tuple_decl, _ctx); + _vres[2] = camlidl_alloc(num_fields, 0); + Begin_root(_vres[2]) + for (_c8 = 0; _c8 < num_fields; _c8++) { + _v9 = camlidl_c2ml_z3_Z3_func_decl(&proj_decl[_c8], _ctx); + modify(&Field(_vres[2], _c8), _v9); + } + End_roots() + _vresult = camlidl_alloc_small(3, 0); + Field(_vresult, 0) = _vres[0]; + Field(_vresult, 1) = _vres[1]; + Field(_vresult, 2) = _vres[2]; + End_roots() + camlidl_free(_ctx); + return _vresult; +} + +value camlidl_z3_Z3_mk_enumeration_sort( + value _v_c, + value _v_name, + value _v_enum_names) +{ + Z3_context c; /*in*/ + Z3_symbol name; /*in*/ + unsigned int n; /*in*/ + Z3_symbol const *enum_names; /*in*/ + Z3_func_decl *enum_consts; /*out*/ + Z3_func_decl *enum_testers; /*out*/ + Z3_sort _res; + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + value _v5; + mlsize_t _c6; + value _v7; + value _vresult; + value _vres[3] = { 0, 0, 0, }; + + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_name, &name, _ctx); + _c1 = Wosize_val(_v_enum_names); + enum_names = camlidl_malloc(_c1 * sizeof(Z3_symbol const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_enum_names, _c2); + camlidl_ml2c_z3_Z3_symbol(_v3, &enum_names[_c2], _ctx); + } + n = _c1; + enum_consts = camlidl_malloc(n * sizeof(Z3_func_decl ), _ctx); + enum_testers = camlidl_malloc(n * sizeof(Z3_func_decl ), _ctx); + _res = Z3_mk_enumeration_sort(c, name, n, enum_names, enum_consts, enum_testers); + Begin_roots_block(_vres, 3) + _vres[0] = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + _vres[1] = camlidl_alloc(n, 0); + Begin_root(_vres[1]) + for (_c4 = 0; _c4 < n; _c4++) { + _v5 = camlidl_c2ml_z3_Z3_func_decl(&enum_consts[_c4], _ctx); + modify(&Field(_vres[1], _c4), _v5); + } + End_roots() + _vres[2] = camlidl_alloc(n, 0); + Begin_root(_vres[2]) + for (_c6 = 0; _c6 < n; _c6++) { + _v7 = camlidl_c2ml_z3_Z3_func_decl(&enum_testers[_c6], _ctx); + modify(&Field(_vres[2], _c6), _v7); + } + End_roots() + _vresult = camlidl_alloc_small(3, 0); + Field(_vresult, 0) = _vres[0]; + Field(_vresult, 1) = _vres[1]; + Field(_vresult, 2) = _vres[2]; + End_roots() + camlidl_free(_ctx); + return _vresult; +} + +value camlidl_z3_Z3_mk_list_sort( + value _v_c, + value _v_name, + value _v_elem_sort) +{ + Z3_context c; /*in*/ + Z3_symbol name; /*in*/ + Z3_sort elem_sort; /*in*/ + Z3_func_decl *nil_decl; /*out*/ + Z3_func_decl *is_nil_decl; /*out*/ + Z3_func_decl *cons_decl; /*out*/ + Z3_func_decl *is_cons_decl; /*out*/ + Z3_func_decl *head_decl; /*out*/ + Z3_func_decl *tail_decl; /*out*/ + Z3_sort _res; + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + Z3_func_decl _c1; + Z3_func_decl _c2; + Z3_func_decl _c3; + Z3_func_decl _c4; + Z3_func_decl _c5; + Z3_func_decl _c6; + value _vresult; + value _vres[7] = { 0, 0, 0, 0, 0, 0, 0, }; + + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_name, &name, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_elem_sort, &elem_sort, _ctx); + nil_decl = &_c1; + is_nil_decl = &_c2; + cons_decl = &_c3; + is_cons_decl = &_c4; + head_decl = &_c5; + tail_decl = &_c6; + _res = Z3_mk_list_sort(c, name, elem_sort, nil_decl, is_nil_decl, cons_decl, is_cons_decl, head_decl, tail_decl); + Begin_roots_block(_vres, 7) + _vres[0] = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + _vres[1] = camlidl_c2ml_z3_Z3_func_decl(&*nil_decl, _ctx); + _vres[2] = camlidl_c2ml_z3_Z3_func_decl(&*is_nil_decl, _ctx); + _vres[3] = camlidl_c2ml_z3_Z3_func_decl(&*cons_decl, _ctx); + _vres[4] = camlidl_c2ml_z3_Z3_func_decl(&*is_cons_decl, _ctx); + _vres[5] = camlidl_c2ml_z3_Z3_func_decl(&*head_decl, _ctx); + _vres[6] = camlidl_c2ml_z3_Z3_func_decl(&*tail_decl, _ctx); + _vresult = camlidl_alloc_small(7, 0); + { mlsize_t _c7; + for (_c7 = 0; _c7 < 7; _c7++) Field(_vresult, _c7) = _vres[_c7]; + } + End_roots() + camlidl_free(_ctx); + return _vresult; +} + +value camlidl_z3_Z3_mk_constructor( + value _v_c, + value _v_name, + value _v_recognizer, + value _v_field_names, + value _v_sorts, + value _v_sort_refs) +{ + Z3_context c; /*in*/ + Z3_symbol name; /*in*/ + Z3_symbol recognizer; /*in*/ + unsigned int num_fields; /*in*/ + Z3_symbol const *field_names; /*in*/ + Z3_sort const *sorts; /*in*/ + unsigned int *sort_refs; /*in*/ + Z3_constructor _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + mlsize_t _c5; + value _v6; + mlsize_t _c7; + mlsize_t _c8; + value _v9; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_name, &name, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_recognizer, &recognizer, _ctx); + _c1 = Wosize_val(_v_field_names); + field_names = camlidl_malloc(_c1 * sizeof(Z3_symbol const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_field_names, _c2); + camlidl_ml2c_z3_Z3_symbol(_v3, &field_names[_c2], _ctx); + } + num_fields = _c1; + _c4 = Wosize_val(_v_sorts); + sorts = camlidl_malloc(_c4 * sizeof(Z3_sort const ), _ctx); + for (_c5 = 0; _c5 < _c4; _c5++) { + _v6 = Field(_v_sorts, _c5); + camlidl_ml2c_z3_Z3_sort(_v6, &sorts[_c5], _ctx); + } + num_fields = _c4; + _c7 = Wosize_val(_v_sort_refs); + sort_refs = camlidl_malloc(_c7 * sizeof(unsigned int ), _ctx); + for (_c8 = 0; _c8 < _c7; _c8++) { + _v9 = Field(_v_sort_refs, _c8); + sort_refs[_c8] = Int_val(_v9); + } + num_fields = _c7; + _res = Z3_mk_constructor(c, name, recognizer, num_fields, field_names, sorts, sort_refs); + _vres = camlidl_c2ml_z3_Z3_constructor(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_constructor_bytecode(value * argv, int argn) +{ + return camlidl_z3_Z3_mk_constructor(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); +} + +value camlidl_z3_Z3_query_constructor( + value _v_c, + value _v_constr, + value _v_num_fields) +{ + Z3_context c; /*in*/ + Z3_constructor constr; /*in*/ + unsigned int num_fields; /*in*/ + Z3_func_decl *constructor; /*out*/ + Z3_func_decl *tester; /*out*/ + Z3_func_decl *accessors; /*out*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + Z3_func_decl _c1; + Z3_func_decl _c2; + mlsize_t _c3; + value _v4; + value _vresult; + value _vres[3] = { 0, 0, 0, }; + + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_constructor(_v_constr, &constr, _ctx); + num_fields = Int_val(_v_num_fields); + constructor = &_c1; + tester = &_c2; + accessors = camlidl_malloc(num_fields * sizeof(Z3_func_decl ), _ctx); + Z3_query_constructor(c, constr, num_fields, constructor, tester, accessors); + Begin_roots_block(_vres, 3) + _vres[0] = camlidl_c2ml_z3_Z3_func_decl(&*constructor, _ctx); + _vres[1] = camlidl_c2ml_z3_Z3_func_decl(&*tester, _ctx); + _vres[2] = camlidl_alloc(num_fields, 0); + Begin_root(_vres[2]) + for (_c3 = 0; _c3 < num_fields; _c3++) { + _v4 = camlidl_c2ml_z3_Z3_func_decl(&accessors[_c3], _ctx); + modify(&Field(_vres[2], _c3), _v4); + } + End_roots() + _vresult = camlidl_alloc_small(3, 0); + Field(_vresult, 0) = _vres[0]; + Field(_vresult, 1) = _vres[1]; + Field(_vresult, 2) = _vres[2]; + End_roots() + camlidl_free(_ctx); + return _vresult; +} + +value camlidl_z3_Z3_del_constructor( + value _v_c, + value _v_constr) +{ + Z3_context c; /*in*/ + Z3_constructor constr; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_constructor(_v_constr, &constr, _ctx); + Z3_del_constructor(c, constr); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_mk_datatype( + value _v_c, + value _v_name, + value _v_constructors) +{ + Z3_context c; /*in*/ + Z3_symbol name; /*in*/ + unsigned int num_constructors; /*in*/ + Z3_constructor *constructors; /*in,out*/ + Z3_sort _res; + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + value _v5; + value _vresult; + value _vres[2] = { 0, 0, }; + + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_name, &name, _ctx); + _c1 = Wosize_val(_v_constructors); + constructors = camlidl_malloc(_c1 * sizeof(Z3_constructor ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_constructors, _c2); + camlidl_ml2c_z3_Z3_constructor(_v3, &constructors[_c2], _ctx); + } + num_constructors = _c1; + _res = Z3_mk_datatype(c, name, num_constructors, constructors); + Begin_roots_block(_vres, 2) + _vres[0] = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + _vres[1] = camlidl_alloc(num_constructors, 0); + Begin_root(_vres[1]) + for (_c4 = 0; _c4 < num_constructors; _c4++) { + _v5 = camlidl_c2ml_z3_Z3_constructor(&constructors[_c4], _ctx); + modify(&Field(_vres[1], _c4), _v5); + } + End_roots() + _vresult = camlidl_alloc_small(2, 0); + Field(_vresult, 0) = _vres[0]; + Field(_vresult, 1) = _vres[1]; + End_roots() + camlidl_free(_ctx); + return _vresult; +} + +value camlidl_z3_Z3_mk_constructor_list( + value _v_c, + value _v_constructors) +{ + Z3_context c; /*in*/ + unsigned int num_constructors; /*in*/ + Z3_constructor *constructors; /*in*/ + Z3_constructor_list _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _c1 = Wosize_val(_v_constructors); + constructors = camlidl_malloc(_c1 * sizeof(Z3_constructor ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_constructors, _c2); + camlidl_ml2c_z3_Z3_constructor(_v3, &constructors[_c2], _ctx); + } + num_constructors = _c1; + _res = Z3_mk_constructor_list(c, num_constructors, constructors); + _vres = camlidl_c2ml_z3_Z3_constructor_list(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_del_constructor_list( + value _v_c, + value _v_clist) +{ + Z3_context c; /*in*/ + Z3_constructor_list clist; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_constructor_list(_v_clist, &clist, _ctx); + Z3_del_constructor_list(c, clist); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_mk_datatypes( + value _v_c, + value _v_sort_names, + value _v_constructor_lists) +{ + Z3_context c; /*in*/ + unsigned int num_sorts; /*in*/ + Z3_symbol *sort_names; /*in*/ + Z3_sort *sorts; /*out*/ + Z3_constructor_list *constructor_lists; /*in,out*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + mlsize_t _c5; + value _v6; + mlsize_t _c7; + value _v8; + mlsize_t _c9; + value _v10; + value _vresult; + value _vres[2] = { 0, 0, }; + + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _c1 = Wosize_val(_v_sort_names); + sort_names = camlidl_malloc(_c1 * sizeof(Z3_symbol ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_sort_names, _c2); + camlidl_ml2c_z3_Z3_symbol(_v3, &sort_names[_c2], _ctx); + } + num_sorts = _c1; + _c4 = Wosize_val(_v_constructor_lists); + constructor_lists = camlidl_malloc(_c4 * sizeof(Z3_constructor_list ), _ctx); + for (_c5 = 0; _c5 < _c4; _c5++) { + _v6 = Field(_v_constructor_lists, _c5); + camlidl_ml2c_z3_Z3_constructor_list(_v6, &constructor_lists[_c5], _ctx); + } + num_sorts = _c4; + sorts = camlidl_malloc(num_sorts * sizeof(Z3_sort ), _ctx); + Z3_mk_datatypes(c, num_sorts, sort_names, sorts, constructor_lists); + Begin_roots_block(_vres, 2) + _vres[0] = camlidl_alloc(num_sorts, 0); + Begin_root(_vres[0]) + for (_c7 = 0; _c7 < num_sorts; _c7++) { + _v8 = camlidl_c2ml_z3_Z3_sort(&sorts[_c7], _ctx); + modify(&Field(_vres[0], _c7), _v8); + } + End_roots() + _vres[1] = camlidl_alloc(num_sorts, 0); + Begin_root(_vres[1]) + for (_c9 = 0; _c9 < num_sorts; _c9++) { + _v10 = camlidl_c2ml_z3_Z3_constructor_list(&constructor_lists[_c9], _ctx); + modify(&Field(_vres[1], _c9), _v10); + } + End_roots() + _vresult = camlidl_alloc_small(2, 0); + Field(_vresult, 0) = _vres[0]; + Field(_vresult, 1) = _vres[1]; + End_roots() + camlidl_free(_ctx); + return _vresult; +} + +value camlidl_z3_Z3_mk_injective_function( + value _v_c, + value _v_s, + value _v_domain, + value _v_range) +{ + Z3_context c; /*in*/ + Z3_symbol s; /*in*/ + unsigned int domain_size; /*in*/ + Z3_sort const *domain; /*in*/ + Z3_sort range; /*in*/ + Z3_func_decl _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_s, &s, _ctx); + _c1 = Wosize_val(_v_domain); + domain = camlidl_malloc(_c1 * sizeof(Z3_sort const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_domain, _c2); + camlidl_ml2c_z3_Z3_sort(_v3, &domain[_c2], _ctx); + } + domain_size = _c1; + camlidl_ml2c_z3_Z3_sort(_v_range, &range, _ctx); + _res = Z3_mk_injective_function(c, s, domain_size, domain, range); + _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_is_eq_ast( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_is_eq_ast(c, t1, t2); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_is_eq_func_decl( + value _v_c, + value _v_f1, + value _v_f2) +{ + Z3_context c; /*in*/ + Z3_func_decl f1; /*in*/ + Z3_func_decl f2; /*in*/ + int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_f1, &f1, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_f2, &f2, _ctx); + _res = Z3_is_eq_func_decl(c, f1, f2); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_func_decl( + value _v_c, + value _v_s, + value _v_domain, + value _v_range) +{ + Z3_context c; /*in*/ + Z3_symbol s; /*in*/ + unsigned int domain_size; /*in*/ + Z3_sort const *domain; /*in*/ + Z3_sort range; /*in*/ + Z3_func_decl _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_s, &s, _ctx); + _c1 = Wosize_val(_v_domain); + domain = camlidl_malloc(_c1 * sizeof(Z3_sort const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_domain, _c2); + camlidl_ml2c_z3_Z3_sort(_v3, &domain[_c2], _ctx); + } + domain_size = _c1; + camlidl_ml2c_z3_Z3_sort(_v_range, &range, _ctx); + _res = Z3_mk_func_decl(c, s, domain_size, domain, range); + _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_app( + value _v_c, + value _v_d, + value _v_args) +{ + Z3_context c; /*in*/ + Z3_func_decl d; /*in*/ + unsigned int num_args; /*in*/ + Z3_ast const *args; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); + _c1 = Wosize_val(_v_args); + args = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_args, _c2); + camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); + } + num_args = _c1; + _res = Z3_mk_app(c, d, num_args, args); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_const( + value _v_c, + value _v_s, + value _v_ty) +{ + Z3_context c; /*in*/ + Z3_symbol s; /*in*/ + Z3_sort ty; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_s, &s, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_ty, &ty, _ctx); + _res = Z3_mk_const(c, s, ty); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_label( + value _v_c, + value _v_s, + value _v_is_pos, + value _v_f) +{ + Z3_context c; /*in*/ + Z3_symbol s; /*in*/ + int is_pos; /*in*/ + Z3_ast f; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_s, &s, _ctx); + is_pos = Int_val(_v_is_pos); + camlidl_ml2c_z3_Z3_ast(_v_f, &f, _ctx); + _res = Z3_mk_label(c, s, is_pos, f); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_fresh_func_decl( + value _v_c, + value _v_prefix, + value _v_domain, + value _v_range) +{ + Z3_context c; /*in*/ + char const *prefix; /*in*/ + unsigned int domain_size; /*in*/ + Z3_sort const *domain; /*in*/ + Z3_sort range; /*in*/ + Z3_func_decl _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + prefix = String_val(_v_prefix); + _c1 = Wosize_val(_v_domain); + domain = camlidl_malloc(_c1 * sizeof(Z3_sort const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_domain, _c2); + camlidl_ml2c_z3_Z3_sort(_v3, &domain[_c2], _ctx); + } + domain_size = _c1; + camlidl_ml2c_z3_Z3_sort(_v_range, &range, _ctx); + _res = Z3_mk_fresh_func_decl(c, prefix, domain_size, domain, range); + _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_fresh_const( + value _v_c, + value _v_prefix, + value _v_ty) +{ + Z3_context c; /*in*/ + char const *prefix; /*in*/ + Z3_sort ty; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + prefix = String_val(_v_prefix); + camlidl_ml2c_z3_Z3_sort(_v_ty, &ty, _ctx); + _res = Z3_mk_fresh_const(c, prefix, ty); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_true( + value _v_c) +{ + Z3_context c; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_mk_true(c); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_false( + value _v_c) +{ + Z3_context c; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_mk_false(c); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_eq( + value _v_c, + value _v_l, + value _v_r) +{ + Z3_context c; /*in*/ + Z3_ast l; /*in*/ + Z3_ast r; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_l, &l, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_r, &r, _ctx); + _res = Z3_mk_eq(c, l, r); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_distinct( + value _v_c, + value _v_args) +{ + Z3_context c; /*in*/ + unsigned int num_args; /*in*/ + Z3_ast const *args; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _c1 = Wosize_val(_v_args); + args = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_args, _c2); + camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); + } + num_args = _c1; + _res = Z3_mk_distinct(c, num_args, args); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_not( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + _res = Z3_mk_not(c, a); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_ite( + value _v_c, + value _v_t1, + value _v_t2, + value _v_t3) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast t3; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t3, &t3, _ctx); + _res = Z3_mk_ite(c, t1, t2, t3); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_iff( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_iff(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_implies( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_implies(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_xor( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_xor(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_and( + value _v_c, + value _v_args) +{ + Z3_context c; /*in*/ + unsigned int num_args; /*in*/ + Z3_ast const *args; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _c1 = Wosize_val(_v_args); + args = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_args, _c2); + camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); + } + num_args = _c1; + _res = Z3_mk_and(c, num_args, args); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_or( + value _v_c, + value _v_args) +{ + Z3_context c; /*in*/ + unsigned int num_args; /*in*/ + Z3_ast const *args; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _c1 = Wosize_val(_v_args); + args = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_args, _c2); + camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); + } + num_args = _c1; + _res = Z3_mk_or(c, num_args, args); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_add( + value _v_c, + value _v_args) +{ + Z3_context c; /*in*/ + unsigned int num_args; /*in*/ + Z3_ast const *args; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _c1 = Wosize_val(_v_args); + args = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_args, _c2); + camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); + } + num_args = _c1; + _res = Z3_mk_add(c, num_args, args); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_mul( + value _v_c, + value _v_args) +{ + Z3_context c; /*in*/ + unsigned int num_args; /*in*/ + Z3_ast const *args; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _c1 = Wosize_val(_v_args); + args = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_args, _c2); + camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); + } + num_args = _c1; + _res = Z3_mk_mul(c, num_args, args); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_sub( + value _v_c, + value _v_args) +{ + Z3_context c; /*in*/ + unsigned int num_args; /*in*/ + Z3_ast const *args; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _c1 = Wosize_val(_v_args); + args = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_args, _c2); + camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); + } + num_args = _c1; + _res = Z3_mk_sub(c, num_args, args); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_unary_minus( + value _v_c, + value _v_arg) +{ + Z3_context c; /*in*/ + Z3_ast arg; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_arg, &arg, _ctx); + _res = Z3_mk_unary_minus(c, arg); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_div( + value _v_c, + value _v_arg1, + value _v_arg2) +{ + Z3_context c; /*in*/ + Z3_ast arg1; /*in*/ + Z3_ast arg2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_arg1, &arg1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_arg2, &arg2, _ctx); + _res = Z3_mk_div(c, arg1, arg2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_mod( + value _v_c, + value _v_arg1, + value _v_arg2) +{ + Z3_context c; /*in*/ + Z3_ast arg1; /*in*/ + Z3_ast arg2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_arg1, &arg1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_arg2, &arg2, _ctx); + _res = Z3_mk_mod(c, arg1, arg2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_rem( + value _v_c, + value _v_arg1, + value _v_arg2) +{ + Z3_context c; /*in*/ + Z3_ast arg1; /*in*/ + Z3_ast arg2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_arg1, &arg1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_arg2, &arg2, _ctx); + _res = Z3_mk_rem(c, arg1, arg2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_lt( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_lt(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_le( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_le(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_gt( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_gt(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_ge( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_ge(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_int2real( + value _v_c, + value _v_t1) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + _res = Z3_mk_int2real(c, t1); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_real2int( + value _v_c, + value _v_t1) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + _res = Z3_mk_real2int(c, t1); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_is_int( + value _v_c, + value _v_t1) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + _res = Z3_mk_is_int(c, t1); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvnot( + value _v_c, + value _v_t1) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + _res = Z3_mk_bvnot(c, t1); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvredand( + value _v_c, + value _v_t1) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + _res = Z3_mk_bvredand(c, t1); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvredor( + value _v_c, + value _v_t1) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + _res = Z3_mk_bvredor(c, t1); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvand( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvand(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvor( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvor(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvxor( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvxor(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvnand( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvnand(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvnor( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvnor(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvxnor( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvxnor(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvneg( + value _v_c, + value _v_t1) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + _res = Z3_mk_bvneg(c, t1); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvadd( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvadd(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvsub( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvsub(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvmul( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvmul(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvudiv( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvudiv(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvsdiv( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvsdiv(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvurem( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvurem(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvsrem( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvsrem(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvsmod( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvsmod(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvult( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvult(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvslt( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvslt(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvule( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvule(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvsle( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvsle(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvuge( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvuge(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvsge( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvsge(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvugt( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvugt(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvsgt( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvsgt(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_concat( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_concat(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_extract( + value _v_c, + value _v_high, + value _v_low, + value _v_t1) +{ + Z3_context c; /*in*/ + unsigned int high; /*in*/ + unsigned int low; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + high = Int_val(_v_high); + low = Int_val(_v_low); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + _res = Z3_mk_extract(c, high, low, t1); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_sign_ext( + value _v_c, + value _v_i, + value _v_t1) +{ + Z3_context c; /*in*/ + unsigned int i; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + i = Int_val(_v_i); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + _res = Z3_mk_sign_ext(c, i, t1); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_zero_ext( + value _v_c, + value _v_i, + value _v_t1) +{ + Z3_context c; /*in*/ + unsigned int i; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + i = Int_val(_v_i); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + _res = Z3_mk_zero_ext(c, i, t1); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_repeat( + value _v_c, + value _v_i, + value _v_t1) +{ + Z3_context c; /*in*/ + unsigned int i; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + i = Int_val(_v_i); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + _res = Z3_mk_repeat(c, i, t1); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvshl( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvshl(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvlshr( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvlshr(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvashr( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvashr(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_rotate_left( + value _v_c, + value _v_i, + value _v_t1) +{ + Z3_context c; /*in*/ + unsigned int i; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + i = Int_val(_v_i); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + _res = Z3_mk_rotate_left(c, i, t1); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_rotate_right( + value _v_c, + value _v_i, + value _v_t1) +{ + Z3_context c; /*in*/ + unsigned int i; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + i = Int_val(_v_i); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + _res = Z3_mk_rotate_right(c, i, t1); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_ext_rotate_left( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_ext_rotate_left(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_ext_rotate_right( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_ext_rotate_right(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_int2bv( + value _v_c, + value _v_n, + value _v_t1) +{ + Z3_context c; /*in*/ + unsigned int n; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + n = Int_val(_v_n); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + _res = Z3_mk_int2bv(c, n, t1); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bv2int( + value _v_c, + value _v_t1, + value _v_is_signed) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + int is_signed; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + is_signed = Int_val(_v_is_signed); + _res = Z3_mk_bv2int(c, t1, is_signed); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvadd_no_overflow( + value _v_c, + value _v_t1, + value _v_t2, + value _v_is_signed) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + int is_signed; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + is_signed = Int_val(_v_is_signed); + _res = Z3_mk_bvadd_no_overflow(c, t1, t2, is_signed); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvadd_no_underflow( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvadd_no_underflow(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvsub_no_overflow( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvsub_no_overflow(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvsub_no_underflow( + value _v_c, + value _v_t1, + value _v_t2, + value _v_is_signed) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + int is_signed; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + is_signed = Int_val(_v_is_signed); + _res = Z3_mk_bvsub_no_underflow(c, t1, t2, is_signed); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvsdiv_no_overflow( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvsdiv_no_overflow(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvneg_no_overflow( + value _v_c, + value _v_t1) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + _res = Z3_mk_bvneg_no_overflow(c, t1); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvmul_no_overflow( + value _v_c, + value _v_t1, + value _v_t2, + value _v_is_signed) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + int is_signed; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + is_signed = Int_val(_v_is_signed); + _res = Z3_mk_bvmul_no_overflow(c, t1, t2, is_signed); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bvmul_no_underflow( + value _v_c, + value _v_t1, + value _v_t2) +{ + Z3_context c; /*in*/ + Z3_ast t1; /*in*/ + Z3_ast t2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); + _res = Z3_mk_bvmul_no_underflow(c, t1, t2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_select( + value _v_c, + value _v_a, + value _v_i) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + Z3_ast i; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_i, &i, _ctx); + _res = Z3_mk_select(c, a, i); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_store( + value _v_c, + value _v_a, + value _v_i, + value _v_v) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + Z3_ast i; /*in*/ + Z3_ast v; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_i, &i, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_v, &v, _ctx); + _res = Z3_mk_store(c, a, i, v); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_const_array( + value _v_c, + value _v_domain, + value _v_v) +{ + Z3_context c; /*in*/ + Z3_sort domain; /*in*/ + Z3_ast v; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_domain, &domain, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_v, &v, _ctx); + _res = Z3_mk_const_array(c, domain, v); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_map( + value _v_c, + value _v_f, + value _v_n, + value _v_args) +{ + Z3_context c; /*in*/ + Z3_func_decl f; /*in*/ + unsigned int n; /*in*/ + Z3_ast const *args; /*in*/ + Z3_ast _res; + Z3_ast _c1; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_f, &f, _ctx); + n = Int_val(_v_n); + args = &_c1; + camlidl_ml2c_z3_Z3_ast(_v_args, &_c1, _ctx); + _res = Z3_mk_map(c, f, n, args); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_array_default( + value _v_c, + value _v_array) +{ + Z3_context c; /*in*/ + Z3_ast array; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_array, &array, _ctx); + _res = Z3_mk_array_default(c, array); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_set_sort( + value _v_c, + value _v_ty) +{ + Z3_context c; /*in*/ + Z3_sort ty; /*in*/ + Z3_sort _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_ty, &ty, _ctx); + _res = Z3_mk_set_sort(c, ty); + _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_empty_set( + value _v_c, + value _v_domain) +{ + Z3_context c; /*in*/ + Z3_sort domain; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_domain, &domain, _ctx); + _res = Z3_mk_empty_set(c, domain); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_full_set( + value _v_c, + value _v_domain) +{ + Z3_context c; /*in*/ + Z3_sort domain; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_domain, &domain, _ctx); + _res = Z3_mk_full_set(c, domain); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_set_add( + value _v_c, + value _v_set, + value _v_elem) +{ + Z3_context c; /*in*/ + Z3_ast set; /*in*/ + Z3_ast elem; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_set, &set, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_elem, &elem, _ctx); + _res = Z3_mk_set_add(c, set, elem); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_set_del( + value _v_c, + value _v_set, + value _v_elem) +{ + Z3_context c; /*in*/ + Z3_ast set; /*in*/ + Z3_ast elem; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_set, &set, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_elem, &elem, _ctx); + _res = Z3_mk_set_del(c, set, elem); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_set_union( + value _v_c, + value _v_args) +{ + Z3_context c; /*in*/ + unsigned int num_args; /*in*/ + Z3_ast const *args; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _c1 = Wosize_val(_v_args); + args = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_args, _c2); + camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); + } + num_args = _c1; + _res = Z3_mk_set_union(c, num_args, args); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_set_intersect( + value _v_c, + value _v_args) +{ + Z3_context c; /*in*/ + unsigned int num_args; /*in*/ + Z3_ast const *args; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _c1 = Wosize_val(_v_args); + args = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_args, _c2); + camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); + } + num_args = _c1; + _res = Z3_mk_set_intersect(c, num_args, args); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_set_difference( + value _v_c, + value _v_arg1, + value _v_arg2) +{ + Z3_context c; /*in*/ + Z3_ast arg1; /*in*/ + Z3_ast arg2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_arg1, &arg1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_arg2, &arg2, _ctx); + _res = Z3_mk_set_difference(c, arg1, arg2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_set_complement( + value _v_c, + value _v_arg) +{ + Z3_context c; /*in*/ + Z3_ast arg; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_arg, &arg, _ctx); + _res = Z3_mk_set_complement(c, arg); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_set_member( + value _v_c, + value _v_elem, + value _v_set) +{ + Z3_context c; /*in*/ + Z3_ast elem; /*in*/ + Z3_ast set; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_elem, &elem, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_set, &set, _ctx); + _res = Z3_mk_set_member(c, elem, set); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_set_subset( + value _v_c, + value _v_arg1, + value _v_arg2) +{ + Z3_context c; /*in*/ + Z3_ast arg1; /*in*/ + Z3_ast arg2; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_arg1, &arg1, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_arg2, &arg2, _ctx); + _res = Z3_mk_set_subset(c, arg1, arg2); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_numeral( + value _v_c, + value _v_numeral, + value _v_ty) +{ + Z3_context c; /*in*/ + char const *numeral; /*in*/ + Z3_sort ty; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + numeral = String_val(_v_numeral); + camlidl_ml2c_z3_Z3_sort(_v_ty, &ty, _ctx); + _res = Z3_mk_numeral(c, numeral, ty); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_real( + value _v_c, + value _v_num, + value _v_den) +{ + Z3_context c; /*in*/ + int num; /*in*/ + int den; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + num = Int_val(_v_num); + den = Int_val(_v_den); + _res = Z3_mk_real(c, num, den); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_int( + value _v_c, + value _v_v, + value _v_ty) +{ + Z3_context c; /*in*/ + int v; /*in*/ + Z3_sort ty; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + v = Int_val(_v_v); + camlidl_ml2c_z3_Z3_sort(_v_ty, &ty, _ctx); + _res = Z3_mk_int(c, v, ty); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_unsigned_int( + value _v_c, + value _v_v, + value _v_ty) +{ + Z3_context c; /*in*/ + unsigned int v; /*in*/ + Z3_sort ty; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + v = Int_val(_v_v); + camlidl_ml2c_z3_Z3_sort(_v_ty, &ty, _ctx); + _res = Z3_mk_unsigned_int(c, v, ty); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_pattern( + value _v_c, + value _v_terms) +{ + Z3_context c; /*in*/ + unsigned int num_patterns; /*in*/ + Z3_ast const *terms; /*in*/ + Z3_pattern _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _c1 = Wosize_val(_v_terms); + terms = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_terms, _c2); + camlidl_ml2c_z3_Z3_ast(_v3, &terms[_c2], _ctx); + } + num_patterns = _c1; + _res = Z3_mk_pattern(c, num_patterns, terms); + _vres = camlidl_c2ml_z3_Z3_pattern(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_bound( + value _v_c, + value _v_index, + value _v_ty) +{ + Z3_context c; /*in*/ + unsigned int index; /*in*/ + Z3_sort ty; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + index = Int_val(_v_index); + camlidl_ml2c_z3_Z3_sort(_v_ty, &ty, _ctx); + _res = Z3_mk_bound(c, index, ty); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_forall( + value _v_c, + value _v_weight, + value _v_patterns, + value _v_sorts, + value _v_decl_names, + value _v_body) +{ + Z3_context c; /*in*/ + unsigned int weight; /*in*/ + unsigned int num_patterns; /*in*/ + Z3_pattern const *patterns; /*in*/ + unsigned int num_decls; /*in*/ + Z3_sort const *sorts; /*in*/ + Z3_symbol const *decl_names; /*in*/ + Z3_ast body; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + mlsize_t _c5; + value _v6; + mlsize_t _c7; + mlsize_t _c8; + value _v9; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + weight = Int_val(_v_weight); + _c1 = Wosize_val(_v_patterns); + patterns = camlidl_malloc(_c1 * sizeof(Z3_pattern const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_patterns, _c2); + camlidl_ml2c_z3_Z3_pattern(_v3, &patterns[_c2], _ctx); + } + num_patterns = _c1; + _c4 = Wosize_val(_v_sorts); + sorts = camlidl_malloc(_c4 * sizeof(Z3_sort const ), _ctx); + for (_c5 = 0; _c5 < _c4; _c5++) { + _v6 = Field(_v_sorts, _c5); + camlidl_ml2c_z3_Z3_sort(_v6, &sorts[_c5], _ctx); + } + num_decls = _c4; + _c7 = Wosize_val(_v_decl_names); + decl_names = camlidl_malloc(_c7 * sizeof(Z3_symbol const ), _ctx); + for (_c8 = 0; _c8 < _c7; _c8++) { + _v9 = Field(_v_decl_names, _c8); + camlidl_ml2c_z3_Z3_symbol(_v9, &decl_names[_c8], _ctx); + } + num_decls = _c7; + camlidl_ml2c_z3_Z3_ast(_v_body, &body, _ctx); + _res = Z3_mk_forall(c, weight, num_patterns, patterns, num_decls, sorts, decl_names, body); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_forall_bytecode(value * argv, int argn) +{ + return camlidl_z3_Z3_mk_forall(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); +} + +value camlidl_z3_Z3_mk_exists( + value _v_c, + value _v_weight, + value _v_patterns, + value _v_sorts, + value _v_decl_names, + value _v_body) +{ + Z3_context c; /*in*/ + unsigned int weight; /*in*/ + unsigned int num_patterns; /*in*/ + Z3_pattern const *patterns; /*in*/ + unsigned int num_decls; /*in*/ + Z3_sort const *sorts; /*in*/ + Z3_symbol const *decl_names; /*in*/ + Z3_ast body; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + mlsize_t _c5; + value _v6; + mlsize_t _c7; + mlsize_t _c8; + value _v9; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + weight = Int_val(_v_weight); + _c1 = Wosize_val(_v_patterns); + patterns = camlidl_malloc(_c1 * sizeof(Z3_pattern const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_patterns, _c2); + camlidl_ml2c_z3_Z3_pattern(_v3, &patterns[_c2], _ctx); + } + num_patterns = _c1; + _c4 = Wosize_val(_v_sorts); + sorts = camlidl_malloc(_c4 * sizeof(Z3_sort const ), _ctx); + for (_c5 = 0; _c5 < _c4; _c5++) { + _v6 = Field(_v_sorts, _c5); + camlidl_ml2c_z3_Z3_sort(_v6, &sorts[_c5], _ctx); + } + num_decls = _c4; + _c7 = Wosize_val(_v_decl_names); + decl_names = camlidl_malloc(_c7 * sizeof(Z3_symbol const ), _ctx); + for (_c8 = 0; _c8 < _c7; _c8++) { + _v9 = Field(_v_decl_names, _c8); + camlidl_ml2c_z3_Z3_symbol(_v9, &decl_names[_c8], _ctx); + } + num_decls = _c7; + camlidl_ml2c_z3_Z3_ast(_v_body, &body, _ctx); + _res = Z3_mk_exists(c, weight, num_patterns, patterns, num_decls, sorts, decl_names, body); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_exists_bytecode(value * argv, int argn) +{ + return camlidl_z3_Z3_mk_exists(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); +} + +value camlidl_z3_Z3_mk_quantifier( + value _v_c, + value _v_is_forall, + value _v_weight, + value _v_patterns, + value _v_sorts, + value _v_decl_names, + value _v_body) +{ + Z3_context c; /*in*/ + int is_forall; /*in*/ + unsigned int weight; /*in*/ + unsigned int num_patterns; /*in*/ + Z3_pattern const *patterns; /*in*/ + unsigned int num_decls; /*in*/ + Z3_sort const *sorts; /*in*/ + Z3_symbol const *decl_names; /*in*/ + Z3_ast body; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + mlsize_t _c5; + value _v6; + mlsize_t _c7; + mlsize_t _c8; + value _v9; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + is_forall = Int_val(_v_is_forall); + weight = Int_val(_v_weight); + _c1 = Wosize_val(_v_patterns); + patterns = camlidl_malloc(_c1 * sizeof(Z3_pattern const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_patterns, _c2); + camlidl_ml2c_z3_Z3_pattern(_v3, &patterns[_c2], _ctx); + } + num_patterns = _c1; + _c4 = Wosize_val(_v_sorts); + sorts = camlidl_malloc(_c4 * sizeof(Z3_sort const ), _ctx); + for (_c5 = 0; _c5 < _c4; _c5++) { + _v6 = Field(_v_sorts, _c5); + camlidl_ml2c_z3_Z3_sort(_v6, &sorts[_c5], _ctx); + } + num_decls = _c4; + _c7 = Wosize_val(_v_decl_names); + decl_names = camlidl_malloc(_c7 * sizeof(Z3_symbol const ), _ctx); + for (_c8 = 0; _c8 < _c7; _c8++) { + _v9 = Field(_v_decl_names, _c8); + camlidl_ml2c_z3_Z3_symbol(_v9, &decl_names[_c8], _ctx); + } + num_decls = _c7; + camlidl_ml2c_z3_Z3_ast(_v_body, &body, _ctx); + _res = Z3_mk_quantifier(c, is_forall, weight, num_patterns, patterns, num_decls, sorts, decl_names, body); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_quantifier_bytecode(value * argv, int argn) +{ + return camlidl_z3_Z3_mk_quantifier(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]); +} + +value camlidl_z3_Z3_mk_quantifier_ex( + value _v_c, + value _v_is_forall, + value _v_weight, + value _v_quantifier_id, + value _v_skolem_id, + value _v_patterns, + value _v_no_patterns, + value _v_sorts, + value _v_decl_names, + value _v_body) +{ + Z3_context c; /*in*/ + int is_forall; /*in*/ + unsigned int weight; /*in*/ + Z3_symbol quantifier_id; /*in*/ + Z3_symbol skolem_id; /*in*/ + unsigned int num_patterns; /*in*/ + Z3_pattern const *patterns; /*in*/ + unsigned int num_no_patterns; /*in*/ + Z3_ast const *no_patterns; /*in*/ + unsigned int num_decls; /*in*/ + Z3_sort const *sorts; /*in*/ + Z3_symbol const *decl_names; /*in*/ + Z3_ast body; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + mlsize_t _c5; + value _v6; + mlsize_t _c7; + mlsize_t _c8; + value _v9; + mlsize_t _c10; + mlsize_t _c11; + value _v12; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + is_forall = Int_val(_v_is_forall); + weight = Int_val(_v_weight); + camlidl_ml2c_z3_Z3_symbol(_v_quantifier_id, &quantifier_id, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_skolem_id, &skolem_id, _ctx); + _c1 = Wosize_val(_v_patterns); + patterns = camlidl_malloc(_c1 * sizeof(Z3_pattern const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_patterns, _c2); + camlidl_ml2c_z3_Z3_pattern(_v3, &patterns[_c2], _ctx); + } + num_patterns = _c1; + _c4 = Wosize_val(_v_no_patterns); + no_patterns = camlidl_malloc(_c4 * sizeof(Z3_ast const ), _ctx); + for (_c5 = 0; _c5 < _c4; _c5++) { + _v6 = Field(_v_no_patterns, _c5); + camlidl_ml2c_z3_Z3_ast(_v6, &no_patterns[_c5], _ctx); + } + num_no_patterns = _c4; + _c7 = Wosize_val(_v_sorts); + sorts = camlidl_malloc(_c7 * sizeof(Z3_sort const ), _ctx); + for (_c8 = 0; _c8 < _c7; _c8++) { + _v9 = Field(_v_sorts, _c8); + camlidl_ml2c_z3_Z3_sort(_v9, &sorts[_c8], _ctx); + } + num_decls = _c7; + _c10 = Wosize_val(_v_decl_names); + decl_names = camlidl_malloc(_c10 * sizeof(Z3_symbol const ), _ctx); + for (_c11 = 0; _c11 < _c10; _c11++) { + _v12 = Field(_v_decl_names, _c11); + camlidl_ml2c_z3_Z3_symbol(_v12, &decl_names[_c11], _ctx); + } + num_decls = _c10; + camlidl_ml2c_z3_Z3_ast(_v_body, &body, _ctx); + _res = Z3_mk_quantifier_ex(c, is_forall, weight, quantifier_id, skolem_id, num_patterns, patterns, num_no_patterns, no_patterns, num_decls, sorts, decl_names, body); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_quantifier_ex_bytecode(value * argv, int argn) +{ + return camlidl_z3_Z3_mk_quantifier_ex(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8], argv[9]); +} + +value camlidl_z3_Z3_mk_forall_const( + value _v_c, + value _v_weight, + value _v_bound, + value _v_patterns, + value _v_body) +{ + Z3_context c; /*in*/ + unsigned int weight; /*in*/ + unsigned int num_bound; /*in*/ + Z3_app const *bound; /*in*/ + unsigned int num_patterns; /*in*/ + Z3_pattern const *patterns; /*in*/ + Z3_ast body; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + mlsize_t _c5; + value _v6; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + weight = Int_val(_v_weight); + _c1 = Wosize_val(_v_bound); + bound = camlidl_malloc(_c1 * sizeof(Z3_app const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_bound, _c2); + camlidl_ml2c_z3_Z3_app(_v3, &bound[_c2], _ctx); + } + num_bound = _c1; + _c4 = Wosize_val(_v_patterns); + patterns = camlidl_malloc(_c4 * sizeof(Z3_pattern const ), _ctx); + for (_c5 = 0; _c5 < _c4; _c5++) { + _v6 = Field(_v_patterns, _c5); + camlidl_ml2c_z3_Z3_pattern(_v6, &patterns[_c5], _ctx); + } + num_patterns = _c4; + camlidl_ml2c_z3_Z3_ast(_v_body, &body, _ctx); + _res = Z3_mk_forall_const(c, weight, num_bound, bound, num_patterns, patterns, body); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_exists_const( + value _v_c, + value _v_weight, + value _v_bound, + value _v_patterns, + value _v_body) +{ + Z3_context c; /*in*/ + unsigned int weight; /*in*/ + unsigned int num_bound; /*in*/ + Z3_app const *bound; /*in*/ + unsigned int num_patterns; /*in*/ + Z3_pattern const *patterns; /*in*/ + Z3_ast body; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + mlsize_t _c5; + value _v6; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + weight = Int_val(_v_weight); + _c1 = Wosize_val(_v_bound); + bound = camlidl_malloc(_c1 * sizeof(Z3_app const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_bound, _c2); + camlidl_ml2c_z3_Z3_app(_v3, &bound[_c2], _ctx); + } + num_bound = _c1; + _c4 = Wosize_val(_v_patterns); + patterns = camlidl_malloc(_c4 * sizeof(Z3_pattern const ), _ctx); + for (_c5 = 0; _c5 < _c4; _c5++) { + _v6 = Field(_v_patterns, _c5); + camlidl_ml2c_z3_Z3_pattern(_v6, &patterns[_c5], _ctx); + } + num_patterns = _c4; + camlidl_ml2c_z3_Z3_ast(_v_body, &body, _ctx); + _res = Z3_mk_exists_const(c, weight, num_bound, bound, num_patterns, patterns, body); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_quantifier_const( + value _v_c, + value _v_is_forall, + value _v_weight, + value _v_bound, + value _v_patterns, + value _v_body) +{ + Z3_context c; /*in*/ + int is_forall; /*in*/ + unsigned int weight; /*in*/ + unsigned int num_bound; /*in*/ + Z3_app const *bound; /*in*/ + unsigned int num_patterns; /*in*/ + Z3_pattern const *patterns; /*in*/ + Z3_ast body; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + mlsize_t _c5; + value _v6; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + is_forall = Int_val(_v_is_forall); + weight = Int_val(_v_weight); + _c1 = Wosize_val(_v_bound); + bound = camlidl_malloc(_c1 * sizeof(Z3_app const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_bound, _c2); + camlidl_ml2c_z3_Z3_app(_v3, &bound[_c2], _ctx); + } + num_bound = _c1; + _c4 = Wosize_val(_v_patterns); + patterns = camlidl_malloc(_c4 * sizeof(Z3_pattern const ), _ctx); + for (_c5 = 0; _c5 < _c4; _c5++) { + _v6 = Field(_v_patterns, _c5); + camlidl_ml2c_z3_Z3_pattern(_v6, &patterns[_c5], _ctx); + } + num_patterns = _c4; + camlidl_ml2c_z3_Z3_ast(_v_body, &body, _ctx); + _res = Z3_mk_quantifier_const(c, is_forall, weight, num_bound, bound, num_patterns, patterns, body); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_quantifier_const_bytecode(value * argv, int argn) +{ + return camlidl_z3_Z3_mk_quantifier_const(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); +} + +value camlidl_z3_Z3_mk_quantifier_const_ex( + value _v_c, + value _v_is_forall, + value _v_weight, + value _v_quantifier_id, + value _v_skolem_id, + value _v_bound, + value _v_patterns, + value _v_no_patterns, + value _v_body) +{ + Z3_context c; /*in*/ + int is_forall; /*in*/ + unsigned int weight; /*in*/ + Z3_symbol quantifier_id; /*in*/ + Z3_symbol skolem_id; /*in*/ + unsigned int num_bound; /*in*/ + Z3_app const *bound; /*in*/ + unsigned int num_patterns; /*in*/ + Z3_pattern const *patterns; /*in*/ + unsigned int num_no_patterns; /*in*/ + Z3_ast const *no_patterns; /*in*/ + Z3_ast body; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + mlsize_t _c5; + value _v6; + mlsize_t _c7; + mlsize_t _c8; + value _v9; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + is_forall = Int_val(_v_is_forall); + weight = Int_val(_v_weight); + camlidl_ml2c_z3_Z3_symbol(_v_quantifier_id, &quantifier_id, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_skolem_id, &skolem_id, _ctx); + _c1 = Wosize_val(_v_bound); + bound = camlidl_malloc(_c1 * sizeof(Z3_app const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_bound, _c2); + camlidl_ml2c_z3_Z3_app(_v3, &bound[_c2], _ctx); + } + num_bound = _c1; + _c4 = Wosize_val(_v_patterns); + patterns = camlidl_malloc(_c4 * sizeof(Z3_pattern const ), _ctx); + for (_c5 = 0; _c5 < _c4; _c5++) { + _v6 = Field(_v_patterns, _c5); + camlidl_ml2c_z3_Z3_pattern(_v6, &patterns[_c5], _ctx); + } + num_patterns = _c4; + _c7 = Wosize_val(_v_no_patterns); + no_patterns = camlidl_malloc(_c7 * sizeof(Z3_ast const ), _ctx); + for (_c8 = 0; _c8 < _c7; _c8++) { + _v9 = Field(_v_no_patterns, _c8); + camlidl_ml2c_z3_Z3_ast(_v9, &no_patterns[_c8], _ctx); + } + num_no_patterns = _c7; + camlidl_ml2c_z3_Z3_ast(_v_body, &body, _ctx); + _res = Z3_mk_quantifier_const_ex(c, is_forall, weight, quantifier_id, skolem_id, num_bound, bound, num_patterns, patterns, num_no_patterns, no_patterns, body); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_mk_quantifier_const_ex_bytecode(value * argv, int argn) +{ + return camlidl_z3_Z3_mk_quantifier_const_ex(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8]); +} + +value camlidl_z3_Z3_get_ast_id( + value _v_c, + value _v_t) +{ + Z3_context c; /*in*/ + Z3_ast t; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t, &t, _ctx); + _res = Z3_get_ast_id(c, t); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_func_decl_id( + value _v_c, + value _v_f) +{ + Z3_context c; /*in*/ + Z3_func_decl f; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_f, &f, _ctx); + _res = Z3_get_func_decl_id(c, f); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_sort_id( + value _v_c, + value _v_s) +{ + Z3_context c; /*in*/ + Z3_sort s; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_s, &s, _ctx); + _res = Z3_get_sort_id(c, s); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_is_well_sorted( + value _v_c, + value _v_t) +{ + Z3_context c; /*in*/ + Z3_ast t; /*in*/ + int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t, &t, _ctx); + _res = Z3_is_well_sorted(c, t); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_symbol_kind( + value _v_c, + value _v_s) +{ + Z3_context c; /*in*/ + Z3_symbol s; /*in*/ + Z3_symbol_kind _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_s, &s, _ctx); + _res = Z3_get_symbol_kind(c, s); + _vres = camlidl_c2ml_z3_Z3_symbol_kind(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_symbol_int( + value _v_c, + value _v_s) +{ + Z3_context c; /*in*/ + Z3_symbol s; /*in*/ + int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_s, &s, _ctx); + _res = Z3_get_symbol_int(c, s); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_symbol_string( + value _v_c, + value _v_s) +{ + Z3_context c; /*in*/ + Z3_symbol s; /*in*/ + char const *_res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_s, &s, _ctx); + _res = Z3_get_symbol_string(c, s); + _vres = copy_string(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_ast_kind( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + Z3_ast_kind _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + _res = Z3_get_ast_kind(c, a); + _vres = camlidl_c2ml_z3_Z3_ast_kind(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_numeral_string( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + char const *_res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + _res = Z3_get_numeral_string(c, a); + _vres = copy_string(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_numeral_small( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + __int64 *num; /*out*/ + __int64 *den; /*out*/ + int _res; + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + __int64 _c1; + __int64 _c2; + value _vresult; + value _vres[3] = { 0, 0, 0, }; + + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + num = &_c1; + den = &_c2; + _res = Z3_get_numeral_small(c, a, num, den); + Begin_roots_block(_vres, 3) + _vres[0] = Val_int(_res); + _vres[1] = copy_int64(*num); + _vres[2] = copy_int64(*den); + _vresult = camlidl_alloc_small(3, 0); + Field(_vresult, 0) = _vres[0]; + Field(_vresult, 1) = _vres[1]; + Field(_vresult, 2) = _vres[2]; + End_roots() + camlidl_free(_ctx); + return _vresult; +} + +value camlidl_z3_Z3_get_numeral_int( + value _v_c, + value _v_v) +{ + Z3_context c; /*in*/ + Z3_ast v; /*in*/ + int *i; /*out*/ + int _res; + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + int _c1; + value _vresult; + value _vres[2] = { 0, 0, }; + + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_v, &v, _ctx); + i = &_c1; + _res = Z3_get_numeral_int(c, v, i); + Begin_roots_block(_vres, 2) + _vres[0] = Val_int(_res); + _vres[1] = Val_int(*i); + _vresult = camlidl_alloc_small(2, 0); + Field(_vresult, 0) = _vres[0]; + Field(_vresult, 1) = _vres[1]; + End_roots() + camlidl_free(_ctx); + return _vresult; +} + +value camlidl_z3_Z3_get_numeral_uint( + value _v_c, + value _v_v) +{ + Z3_context c; /*in*/ + Z3_ast v; /*in*/ + unsigned int *u; /*out*/ + int _res; + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + unsigned int _c1; + value _vresult; + value _vres[2] = { 0, 0, }; + + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_v, &v, _ctx); + u = &_c1; + _res = Z3_get_numeral_uint(c, v, u); + Begin_roots_block(_vres, 2) + _vres[0] = Val_int(_res); + _vres[1] = Val_int(*u); + _vresult = camlidl_alloc_small(2, 0); + Field(_vresult, 0) = _vres[0]; + Field(_vresult, 1) = _vres[1]; + End_roots() + camlidl_free(_ctx); + return _vresult; +} + +value camlidl_z3_Z3_get_bool_value( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + Z3_lbool _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + _res = Z3_get_bool_value(c, a); + _vres = camlidl_c2ml_z3_Z3_lbool(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_app_decl( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_app a; /*in*/ + Z3_func_decl _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_app(_v_a, &a, _ctx); + _res = Z3_get_app_decl(c, a); + _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_app_num_args( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_app a; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_app(_v_a, &a, _ctx); + _res = Z3_get_app_num_args(c, a); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_app_arg( + value _v_c, + value _v_a, + value _v_i) +{ + Z3_context c; /*in*/ + Z3_app a; /*in*/ + unsigned int i; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_app(_v_a, &a, _ctx); + i = Int_val(_v_i); + _res = Z3_get_app_arg(c, a, i); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_index_value( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + _res = Z3_get_index_value(c, a); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_is_quantifier_forall( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + _res = Z3_is_quantifier_forall(c, a); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_quantifier_weight( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + _res = Z3_get_quantifier_weight(c, a); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_quantifier_num_patterns( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + _res = Z3_get_quantifier_num_patterns(c, a); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_quantifier_pattern_ast( + value _v_c, + value _v_a, + value _v_i) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + unsigned int i; /*in*/ + Z3_pattern _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + i = Int_val(_v_i); + _res = Z3_get_quantifier_pattern_ast(c, a, i); + _vres = camlidl_c2ml_z3_Z3_pattern(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_quantifier_num_no_patterns( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + _res = Z3_get_quantifier_num_no_patterns(c, a); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_quantifier_no_pattern_ast( + value _v_c, + value _v_a, + value _v_i) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + unsigned int i; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + i = Int_val(_v_i); + _res = Z3_get_quantifier_no_pattern_ast(c, a, i); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_quantifier_bound_name( + value _v_c, + value _v_a, + value _v_i) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + unsigned int i; /*in*/ + Z3_symbol _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + i = Int_val(_v_i); + _res = Z3_get_quantifier_bound_name(c, a, i); + _vres = camlidl_c2ml_z3_Z3_symbol(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_quantifier_bound_sort( + value _v_c, + value _v_a, + value _v_i) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + unsigned int i; /*in*/ + Z3_sort _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + i = Int_val(_v_i); + _res = Z3_get_quantifier_bound_sort(c, a, i); + _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_quantifier_body( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + _res = Z3_get_quantifier_body(c, a); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_quantifier_num_bound( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + _res = Z3_get_quantifier_num_bound(c, a); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_decl_name( + value _v_c, + value _v_d) +{ + Z3_context c; /*in*/ + Z3_func_decl d; /*in*/ + Z3_symbol _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); + _res = Z3_get_decl_name(c, d); + _vres = camlidl_c2ml_z3_Z3_symbol(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_decl_num_parameters( + value _v_c, + value _v_d) +{ + Z3_context c; /*in*/ + Z3_func_decl d; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); + _res = Z3_get_decl_num_parameters(c, d); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_decl_parameter_kind( + value _v_c, + value _v_d, + value _v_idx) +{ + Z3_context c; /*in*/ + Z3_func_decl d; /*in*/ + unsigned int idx; /*in*/ + Z3_parameter_kind _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); + idx = Int_val(_v_idx); + _res = Z3_get_decl_parameter_kind(c, d, idx); + _vres = camlidl_c2ml_z3_Z3_parameter_kind(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_decl_int_parameter( + value _v_c, + value _v_d, + value _v_idx) +{ + Z3_context c; /*in*/ + Z3_func_decl d; /*in*/ + unsigned int idx; /*in*/ + int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); + idx = Int_val(_v_idx); + _res = Z3_get_decl_int_parameter(c, d, idx); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_decl_double_parameter( + value _v_c, + value _v_d, + value _v_idx) +{ + Z3_context c; /*in*/ + Z3_func_decl d; /*in*/ + unsigned int idx; /*in*/ + double _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); + idx = Int_val(_v_idx); + _res = Z3_get_decl_double_parameter(c, d, idx); + _vres = copy_double(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_decl_symbol_parameter( + value _v_c, + value _v_d, + value _v_idx) +{ + Z3_context c; /*in*/ + Z3_func_decl d; /*in*/ + unsigned int idx; /*in*/ + Z3_symbol _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); + idx = Int_val(_v_idx); + _res = Z3_get_decl_symbol_parameter(c, d, idx); + _vres = camlidl_c2ml_z3_Z3_symbol(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_decl_sort_parameter( + value _v_c, + value _v_d, + value _v_idx) +{ + Z3_context c; /*in*/ + Z3_func_decl d; /*in*/ + unsigned int idx; /*in*/ + Z3_sort _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); + idx = Int_val(_v_idx); + _res = Z3_get_decl_sort_parameter(c, d, idx); + _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_decl_ast_parameter( + value _v_c, + value _v_d, + value _v_idx) +{ + Z3_context c; /*in*/ + Z3_func_decl d; /*in*/ + unsigned int idx; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); + idx = Int_val(_v_idx); + _res = Z3_get_decl_ast_parameter(c, d, idx); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_decl_func_decl_parameter( + value _v_c, + value _v_d, + value _v_idx) +{ + Z3_context c; /*in*/ + Z3_func_decl d; /*in*/ + unsigned int idx; /*in*/ + Z3_func_decl _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); + idx = Int_val(_v_idx); + _res = Z3_get_decl_func_decl_parameter(c, d, idx); + _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_decl_rational_parameter( + value _v_c, + value _v_d, + value _v_idx) +{ + Z3_context c; /*in*/ + Z3_func_decl d; /*in*/ + unsigned int idx; /*in*/ + char const *_res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); + idx = Int_val(_v_idx); + _res = Z3_get_decl_rational_parameter(c, d, idx); + _vres = copy_string(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_sort_name( + value _v_c, + value _v_d) +{ + Z3_context c; /*in*/ + Z3_sort d; /*in*/ + Z3_symbol _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_d, &d, _ctx); + _res = Z3_get_sort_name(c, d); + _vres = camlidl_c2ml_z3_Z3_symbol(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_sort( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + Z3_sort _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + _res = Z3_get_sort(c, a); + _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_domain_size( + value _v_c, + value _v_d) +{ + Z3_context c; /*in*/ + Z3_func_decl d; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); + _res = Z3_get_domain_size(c, d); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_domain( + value _v_c, + value _v_d, + value _v_i) +{ + Z3_context c; /*in*/ + Z3_func_decl d; /*in*/ + unsigned int i; /*in*/ + Z3_sort _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); + i = Int_val(_v_i); + _res = Z3_get_domain(c, d, i); + _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_range( + value _v_c, + value _v_d) +{ + Z3_context c; /*in*/ + Z3_func_decl d; /*in*/ + Z3_sort _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); + _res = Z3_get_range(c, d); + _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_sort_kind( + value _v_c, + value _v_t) +{ + Z3_context c; /*in*/ + Z3_sort t; /*in*/ + Z3_sort_kind _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); + _res = Z3_get_sort_kind(c, t); + _vres = camlidl_c2ml_z3_Z3_sort_kind(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_bv_sort_size( + value _v_c, + value _v_t) +{ + Z3_context c; /*in*/ + Z3_sort t; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); + _res = Z3_get_bv_sort_size(c, t); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_array_sort_domain( + value _v_c, + value _v_t) +{ + Z3_context c; /*in*/ + Z3_sort t; /*in*/ + Z3_sort _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); + _res = Z3_get_array_sort_domain(c, t); + _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_array_sort_range( + value _v_c, + value _v_t) +{ + Z3_context c; /*in*/ + Z3_sort t; /*in*/ + Z3_sort _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); + _res = Z3_get_array_sort_range(c, t); + _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_tuple_sort_mk_decl( + value _v_c, + value _v_t) +{ + Z3_context c; /*in*/ + Z3_sort t; /*in*/ + Z3_func_decl _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); + _res = Z3_get_tuple_sort_mk_decl(c, t); + _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_decl_kind( + value _v_c, + value _v_d) +{ + Z3_context c; /*in*/ + Z3_func_decl d; /*in*/ + Z3_decl_kind _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); + _res = Z3_get_decl_kind(c, d); + _vres = camlidl_c2ml_z3_Z3_decl_kind(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_tuple_sort_num_fields( + value _v_c, + value _v_t) +{ + Z3_context c; /*in*/ + Z3_sort t; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); + _res = Z3_get_tuple_sort_num_fields(c, t); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_tuple_sort_field_decl( + value _v_c, + value _v_t, + value _v_i) +{ + Z3_context c; /*in*/ + Z3_sort t; /*in*/ + unsigned int i; /*in*/ + Z3_func_decl _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); + i = Int_val(_v_i); + _res = Z3_get_tuple_sort_field_decl(c, t, i); + _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_datatype_sort_num_constructors( + value _v_c, + value _v_t) +{ + Z3_context c; /*in*/ + Z3_sort t; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); + _res = Z3_get_datatype_sort_num_constructors(c, t); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_datatype_sort_constructor( + value _v_c, + value _v_t, + value _v_idx) +{ + Z3_context c; /*in*/ + Z3_sort t; /*in*/ + unsigned int idx; /*in*/ + Z3_func_decl _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); + idx = Int_val(_v_idx); + _res = Z3_get_datatype_sort_constructor(c, t, idx); + _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_datatype_sort_recognizer( + value _v_c, + value _v_t, + value _v_idx) +{ + Z3_context c; /*in*/ + Z3_sort t; /*in*/ + unsigned int idx; /*in*/ + Z3_func_decl _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); + idx = Int_val(_v_idx); + _res = Z3_get_datatype_sort_recognizer(c, t, idx); + _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_datatype_sort_constructor_accessor( + value _v_c, + value _v_t, + value _v_idx_c, + value _v_idx_a) +{ + Z3_context c; /*in*/ + Z3_sort t; /*in*/ + unsigned int idx_c; /*in*/ + unsigned int idx_a; /*in*/ + Z3_func_decl _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); + idx_c = Int_val(_v_idx_c); + idx_a = Int_val(_v_idx_a); + _res = Z3_get_datatype_sort_constructor_accessor(c, t, idx_c, idx_a); + _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_relation_arity( + value _v_c, + value _v_s) +{ + Z3_context c; /*in*/ + Z3_sort s; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_s, &s, _ctx); + _res = Z3_get_relation_arity(c, s); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_relation_column( + value _v_c, + value _v_s, + value _v_col) +{ + Z3_context c; /*in*/ + Z3_sort s; /*in*/ + unsigned int col; /*in*/ + Z3_sort _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_s, &s, _ctx); + col = Int_val(_v_col); + _res = Z3_get_relation_column(c, s, col); + _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_pattern_num_terms( + value _v_c, + value _v_p) +{ + Z3_context c; /*in*/ + Z3_pattern p; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_pattern(_v_p, &p, _ctx); + _res = Z3_get_pattern_num_terms(c, p); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_pattern( + value _v_c, + value _v_p, + value _v_idx) +{ + Z3_context c; /*in*/ + Z3_pattern p; /*in*/ + unsigned int idx; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_pattern(_v_p, &p, _ctx); + idx = Int_val(_v_idx); + _res = Z3_get_pattern(c, p, idx); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_simplify( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + _res = Z3_simplify(c, a); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_update_term( + value _v_c, + value _v_a, + value _v_args) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + unsigned int num_args; /*in*/ + Z3_ast *args; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + _c1 = Wosize_val(_v_args); + args = camlidl_malloc(_c1 * sizeof(Z3_ast ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_args, _c2); + camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); + } + num_args = _c1; + _res = Z3_update_term(c, a, num_args, args); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_substitute( + value _v_c, + value _v_a, + value _v_from, + value _v_to) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + unsigned int num_exprs; /*in*/ + Z3_ast *from; /*in*/ + Z3_ast *to; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + mlsize_t _c5; + value _v6; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + _c1 = Wosize_val(_v_from); + from = camlidl_malloc(_c1 * sizeof(Z3_ast ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_from, _c2); + camlidl_ml2c_z3_Z3_ast(_v3, &from[_c2], _ctx); + } + num_exprs = _c1; + _c4 = Wosize_val(_v_to); + to = camlidl_malloc(_c4 * sizeof(Z3_ast ), _ctx); + for (_c5 = 0; _c5 < _c4; _c5++) { + _v6 = Field(_v_to, _c5); + camlidl_ml2c_z3_Z3_ast(_v6, &to[_c5], _ctx); + } + num_exprs = _c4; + _res = Z3_substitute(c, a, num_exprs, from, to); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_substitute_vars( + value _v_c, + value _v_a, + value _v_to) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + unsigned int num_exprs; /*in*/ + Z3_ast *to; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + _c1 = Wosize_val(_v_to); + to = camlidl_malloc(_c1 * sizeof(Z3_ast ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_to, _c2); + camlidl_ml2c_z3_Z3_ast(_v3, &to[_c2], _ctx); + } + num_exprs = _c1; + _res = Z3_substitute_vars(c, a, num_exprs, to); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_sort_to_ast( + value _v_c, + value _v_s) +{ + Z3_context c; /*in*/ + Z3_sort s; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_s, &s, _ctx); + _res = Z3_sort_to_ast(c, s); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_func_decl_to_ast( + value _v_c, + value _v_f) +{ + Z3_context c; /*in*/ + Z3_func_decl f; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_f, &f, _ctx); + _res = Z3_func_decl_to_ast(c, f); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_pattern_to_ast( + value _v_c, + value _v_p) +{ + Z3_context c; /*in*/ + Z3_pattern p; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_pattern(_v_p, &p, _ctx); + _res = Z3_pattern_to_ast(c, p); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_app_to_ast( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_app a; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_app(_v_a, &a, _ctx); + _res = Z3_app_to_ast(c, a); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_to_app( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + Z3_app _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + _res = Z3_to_app(c, a); + _vres = camlidl_c2ml_z3_Z3_app(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_push( + value _v_c) +{ + Z3_context c; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + Z3_push(c); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_pop( + value _v_c, + value _v_num_scopes) +{ + Z3_context c; /*in*/ + unsigned int num_scopes; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + num_scopes = Int_val(_v_num_scopes); + Z3_pop(c, num_scopes); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_get_num_scopes( + value _v_c) +{ + Z3_context c; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_get_num_scopes(c); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_persist_ast( + value _v_c, + value _v_a, + value _v_num_scopes) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + unsigned int num_scopes; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + num_scopes = Int_val(_v_num_scopes); + Z3_persist_ast(c, a, num_scopes); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_assert_cnstr( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + Z3_assert_cnstr(c, a); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_check_and_get_model( + value _v_c) +{ + Z3_context c; /*in*/ + Z3_model *m; /*out*/ + Z3_lbool _res; + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + Z3_model _c1; + value _vresult; + value _vres[2] = { 0, 0, }; + + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + m = &_c1; + _res = Z3_check_and_get_model(c, m); + Begin_roots_block(_vres, 2) + _vres[0] = camlidl_c2ml_z3_Z3_lbool(&_res, _ctx); + _vres[1] = camlidl_c2ml_z3_Z3_model(&*m, _ctx); + _vresult = camlidl_alloc_small(2, 0); + Field(_vresult, 0) = _vres[0]; + Field(_vresult, 1) = _vres[1]; + End_roots() + camlidl_free(_ctx); + return _vresult; +} + +value camlidl_z3_Z3_check( + value _v_c) +{ + Z3_context c; /*in*/ + Z3_lbool _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_check(c); + _vres = camlidl_c2ml_z3_Z3_lbool(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_check_assumptions( + value _v_c, + value _v_assumptions, + value _v_core_size, + value _v_core) +{ + Z3_context c; /*in*/ + unsigned int num_assumptions; /*in*/ + Z3_ast *assumptions; /*in*/ + Z3_model *m; /*out*/ + Z3_ast *proof; /*out*/ + unsigned int *core_size; /*in,out*/ + Z3_ast *core; /*in,out*/ + Z3_lbool _res; + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + unsigned int _c4; + mlsize_t _c5; + mlsize_t _c6; + value _v7; + Z3_model _c8; + Z3_ast _c9; + mlsize_t _c10; + value _v11; + value _vresult; + value _vres[5] = { 0, 0, 0, 0, 0, }; + + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _c1 = Wosize_val(_v_assumptions); + assumptions = camlidl_malloc(_c1 * sizeof(Z3_ast ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_assumptions, _c2); + camlidl_ml2c_z3_Z3_ast(_v3, &assumptions[_c2], _ctx); + } + num_assumptions = _c1; + core_size = &_c4; + _c4 = Int_val(_v_core_size); + _c5 = Wosize_val(_v_core); + core = camlidl_malloc(_c5 * sizeof(Z3_ast ), _ctx); + for (_c6 = 0; _c6 < _c5; _c6++) { + _v7 = Field(_v_core, _c6); + camlidl_ml2c_z3_Z3_ast(_v7, &core[_c6], _ctx); + } + num_assumptions = _c5; + m = &_c8; + proof = &_c9; + _res = Z3_check_assumptions(c, num_assumptions, assumptions, m, proof, core_size, core); + Begin_roots_block(_vres, 5) + _vres[0] = camlidl_c2ml_z3_Z3_lbool(&_res, _ctx); + _vres[1] = camlidl_c2ml_z3_Z3_model(&*m, _ctx); + _vres[2] = camlidl_c2ml_z3_Z3_ast(&*proof, _ctx); + _vres[3] = Val_int(*core_size); + _vres[4] = camlidl_alloc(num_assumptions, 0); + Begin_root(_vres[4]) + for (_c10 = 0; _c10 < num_assumptions; _c10++) { + _v11 = camlidl_c2ml_z3_Z3_ast(&core[_c10], _ctx); + modify(&Field(_vres[4], _c10), _v11); + } + End_roots() + _vresult = camlidl_alloc_small(5, 0); + { mlsize_t _c12; + for (_c12 = 0; _c12 < 5; _c12++) Field(_vresult, _c12) = _vres[_c12]; + } + End_roots() + camlidl_free(_ctx); + return _vresult; +} + +value camlidl_z3_Z3_get_implied_equalities( + value _v_c, + value _v_terms) +{ + Z3_context c; /*in*/ + unsigned int num_terms; /*in*/ + Z3_ast *terms; /*in*/ + unsigned int *class_ids; /*out*/ + Z3_lbool _res; + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + value _v5; + value _vresult; + value _vres[2] = { 0, 0, }; + + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _c1 = Wosize_val(_v_terms); + terms = camlidl_malloc(_c1 * sizeof(Z3_ast ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_terms, _c2); + camlidl_ml2c_z3_Z3_ast(_v3, &terms[_c2], _ctx); + } + num_terms = _c1; + class_ids = camlidl_malloc(num_terms * sizeof(unsigned int ), _ctx); + _res = Z3_get_implied_equalities(c, num_terms, terms, class_ids); + Begin_roots_block(_vres, 2) + _vres[0] = camlidl_c2ml_z3_Z3_lbool(&_res, _ctx); + _vres[1] = camlidl_alloc(num_terms, 0); + for (_c4 = 0; _c4 < num_terms; _c4++) { + _v5 = Val_int(class_ids[_c4]); + modify(&Field(_vres[1], _c4), _v5); + } + _vresult = camlidl_alloc_small(2, 0); + Field(_vresult, 0) = _vres[0]; + Field(_vresult, 1) = _vres[1]; + End_roots() + camlidl_free(_ctx); + return _vresult; +} + +value camlidl_z3_Z3_del_model( + value _v_c, + value _v_m) +{ + Z3_context c; /*in*/ + Z3_model m; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); + Z3_del_model(c, m); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_soft_check_cancel( + value _v_c) +{ + Z3_context c; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + Z3_soft_check_cancel(c); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_get_search_failure( + value _v_c) +{ + Z3_context c; /*in*/ + Z3_search_failure _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_get_search_failure(c); + _vres = camlidl_c2ml_z3_Z3_search_failure(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_relevant_labels( + value _v_c) +{ + Z3_context c; /*in*/ + Z3_literals _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_get_relevant_labels(c); + _vres = camlidl_c2ml_z3_Z3_literals(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_relevant_literals( + value _v_c) +{ + Z3_context c; /*in*/ + Z3_literals _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_get_relevant_literals(c); + _vres = camlidl_c2ml_z3_Z3_literals(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_guessed_literals( + value _v_c) +{ + Z3_context c; /*in*/ + Z3_literals _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_get_guessed_literals(c); + _vres = camlidl_c2ml_z3_Z3_literals(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_del_literals( + value _v_c, + value _v_lbls) +{ + Z3_context c; /*in*/ + Z3_literals lbls; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_literals(_v_lbls, &lbls, _ctx); + Z3_del_literals(c, lbls); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_get_num_literals( + value _v_c, + value _v_lbls) +{ + Z3_context c; /*in*/ + Z3_literals lbls; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_literals(_v_lbls, &lbls, _ctx); + _res = Z3_get_num_literals(c, lbls); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_label_symbol( + value _v_c, + value _v_lbls, + value _v_idx) +{ + Z3_context c; /*in*/ + Z3_literals lbls; /*in*/ + unsigned int idx; /*in*/ + Z3_symbol _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_literals(_v_lbls, &lbls, _ctx); + idx = Int_val(_v_idx); + _res = Z3_get_label_symbol(c, lbls, idx); + _vres = camlidl_c2ml_z3_Z3_symbol(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_literal( + value _v_c, + value _v_lbls, + value _v_idx) +{ + Z3_context c; /*in*/ + Z3_literals lbls; /*in*/ + unsigned int idx; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_literals(_v_lbls, &lbls, _ctx); + idx = Int_val(_v_idx); + _res = Z3_get_literal(c, lbls, idx); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_disable_literal( + value _v_c, + value _v_lbls, + value _v_idx) +{ + Z3_context c; /*in*/ + Z3_literals lbls; /*in*/ + unsigned int idx; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_literals(_v_lbls, &lbls, _ctx); + idx = Int_val(_v_idx); + Z3_disable_literal(c, lbls, idx); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_block_literals( + value _v_c, + value _v_lbls) +{ + Z3_context c; /*in*/ + Z3_literals lbls; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_literals(_v_lbls, &lbls, _ctx); + Z3_block_literals(c, lbls); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_get_model_num_constants( + value _v_c, + value _v_m) +{ + Z3_context c; /*in*/ + Z3_model m; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); + _res = Z3_get_model_num_constants(c, m); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_model_constant( + value _v_c, + value _v_m, + value _v_i) +{ + Z3_context c; /*in*/ + Z3_model m; /*in*/ + unsigned int i; /*in*/ + Z3_func_decl _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); + i = Int_val(_v_i); + _res = Z3_get_model_constant(c, m, i); + _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_eval_func_decl( + value _v_c, + value _v_m, + value _v_decl) +{ + Z3_context c; /*in*/ + Z3_model m; /*in*/ + Z3_func_decl decl; /*in*/ + Z3_ast *v; /*out*/ + int _res; + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + Z3_ast _c1; + value _vresult; + value _vres[2] = { 0, 0, }; + + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_decl, &decl, _ctx); + v = &_c1; + _res = Z3_eval_func_decl(c, m, decl, v); + Begin_roots_block(_vres, 2) + _vres[0] = Val_int(_res); + _vres[1] = camlidl_c2ml_z3_Z3_ast(&*v, _ctx); + _vresult = camlidl_alloc_small(2, 0); + Field(_vresult, 0) = _vres[0]; + Field(_vresult, 1) = _vres[1]; + End_roots() + camlidl_free(_ctx); + return _vresult; +} + +value camlidl_z3_Z3_is_array_value( + value _v_c, + value _v_m, + value _v_v) +{ + Z3_context c; /*in*/ + Z3_model m; /*in*/ + Z3_ast v; /*in*/ + unsigned int *num_entries; /*out*/ + int _res; + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + unsigned int _c1; + value _vresult; + value _vres[2] = { 0, 0, }; + + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_v, &v, _ctx); + num_entries = &_c1; + _res = Z3_is_array_value(c, m, v, num_entries); + Begin_roots_block(_vres, 2) + _vres[0] = Val_int(_res); + _vres[1] = Val_int(*num_entries); + _vresult = camlidl_alloc_small(2, 0); + Field(_vresult, 0) = _vres[0]; + Field(_vresult, 1) = _vres[1]; + End_roots() + camlidl_free(_ctx); + return _vresult; +} + +value camlidl_z3_Z3_get_array_value( + value _v_c, + value _v_m, + value _v_v, + value _v_indices, + value _v_values) +{ + Z3_context c; /*in*/ + Z3_model m; /*in*/ + Z3_ast v; /*in*/ + unsigned int num_entries; /*in*/ + Z3_ast *indices; /*in,out*/ + Z3_ast *values; /*in,out*/ + Z3_ast *else_value; /*out*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + mlsize_t _c5; + value _v6; + Z3_ast _c7; + mlsize_t _c8; + value _v9; + mlsize_t _c10; + value _v11; + value _vresult; + value _vres[3] = { 0, 0, 0, }; + + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_v, &v, _ctx); + _c1 = Wosize_val(_v_indices); + indices = camlidl_malloc(_c1 * sizeof(Z3_ast ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_indices, _c2); + camlidl_ml2c_z3_Z3_ast(_v3, &indices[_c2], _ctx); + } + num_entries = _c1; + _c4 = Wosize_val(_v_values); + values = camlidl_malloc(_c4 * sizeof(Z3_ast ), _ctx); + for (_c5 = 0; _c5 < _c4; _c5++) { + _v6 = Field(_v_values, _c5); + camlidl_ml2c_z3_Z3_ast(_v6, &values[_c5], _ctx); + } + num_entries = _c4; + else_value = &_c7; + Z3_get_array_value(c, m, v, num_entries, indices, values, else_value); + Begin_roots_block(_vres, 3) + _vres[0] = camlidl_alloc(num_entries, 0); + Begin_root(_vres[0]) + for (_c8 = 0; _c8 < num_entries; _c8++) { + _v9 = camlidl_c2ml_z3_Z3_ast(&indices[_c8], _ctx); + modify(&Field(_vres[0], _c8), _v9); + } + End_roots() + _vres[1] = camlidl_alloc(num_entries, 0); + Begin_root(_vres[1]) + for (_c10 = 0; _c10 < num_entries; _c10++) { + _v11 = camlidl_c2ml_z3_Z3_ast(&values[_c10], _ctx); + modify(&Field(_vres[1], _c10), _v11); + } + End_roots() + _vres[2] = camlidl_c2ml_z3_Z3_ast(&*else_value, _ctx); + _vresult = camlidl_alloc_small(3, 0); + Field(_vresult, 0) = _vres[0]; + Field(_vresult, 1) = _vres[1]; + Field(_vresult, 2) = _vres[2]; + End_roots() + camlidl_free(_ctx); + return _vresult; +} + +value camlidl_z3_Z3_get_model_num_funcs( + value _v_c, + value _v_m) +{ + Z3_context c; /*in*/ + Z3_model m; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); + _res = Z3_get_model_num_funcs(c, m); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_model_func_decl( + value _v_c, + value _v_m, + value _v_i) +{ + Z3_context c; /*in*/ + Z3_model m; /*in*/ + unsigned int i; /*in*/ + Z3_func_decl _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); + i = Int_val(_v_i); + _res = Z3_get_model_func_decl(c, m, i); + _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_model_func_else( + value _v_c, + value _v_m, + value _v_i) +{ + Z3_context c; /*in*/ + Z3_model m; /*in*/ + unsigned int i; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); + i = Int_val(_v_i); + _res = Z3_get_model_func_else(c, m, i); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_model_func_num_entries( + value _v_c, + value _v_m, + value _v_i) +{ + Z3_context c; /*in*/ + Z3_model m; /*in*/ + unsigned int i; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); + i = Int_val(_v_i); + _res = Z3_get_model_func_num_entries(c, m, i); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_model_func_entry_num_args( + value _v_c, + value _v_m, + value _v_i, + value _v_j) +{ + Z3_context c; /*in*/ + Z3_model m; /*in*/ + unsigned int i; /*in*/ + unsigned int j; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); + i = Int_val(_v_i); + j = Int_val(_v_j); + _res = Z3_get_model_func_entry_num_args(c, m, i, j); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_model_func_entry_arg( + value _v_c, + value _v_m, + value _v_i, + value _v_j, + value _v_k) +{ + Z3_context c; /*in*/ + Z3_model m; /*in*/ + unsigned int i; /*in*/ + unsigned int j; /*in*/ + unsigned int k; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); + i = Int_val(_v_i); + j = Int_val(_v_j); + k = Int_val(_v_k); + _res = Z3_get_model_func_entry_arg(c, m, i, j, k); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_model_func_entry_value( + value _v_c, + value _v_m, + value _v_i, + value _v_j) +{ + Z3_context c; /*in*/ + Z3_model m; /*in*/ + unsigned int i; /*in*/ + unsigned int j; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); + i = Int_val(_v_i); + j = Int_val(_v_j); + _res = Z3_get_model_func_entry_value(c, m, i, j); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_eval( + value _v_c, + value _v_m, + value _v_t) +{ + Z3_context c; /*in*/ + Z3_model m; /*in*/ + Z3_ast t; /*in*/ + Z3_ast *v; /*out*/ + int _res; + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + Z3_ast _c1; + value _vresult; + value _vres[2] = { 0, 0, }; + + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_t, &t, _ctx); + v = &_c1; + _res = Z3_eval(c, m, t, v); + Begin_roots_block(_vres, 2) + _vres[0] = Val_int(_res); + _vres[1] = camlidl_c2ml_z3_Z3_ast(&*v, _ctx); + _vresult = camlidl_alloc_small(2, 0); + Field(_vresult, 0) = _vres[0]; + Field(_vresult, 1) = _vres[1]; + End_roots() + camlidl_free(_ctx); + return _vresult; +} + +value camlidl_z3_Z3_eval_decl( + value _v_c, + value _v_m, + value _v_d, + value _v_args) +{ + Z3_context c; /*in*/ + Z3_model m; /*in*/ + Z3_func_decl d; /*in*/ + unsigned int num_args; /*in*/ + Z3_ast *args; /*in*/ + Z3_ast *v; /*out*/ + int _res; + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + Z3_ast _c4; + value _vresult; + value _vres[2] = { 0, 0, }; + + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); + _c1 = Wosize_val(_v_args); + args = camlidl_malloc(_c1 * sizeof(Z3_ast ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_args, _c2); + camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); + } + num_args = _c1; + v = &_c4; + _res = Z3_eval_decl(c, m, d, num_args, args, v); + Begin_roots_block(_vres, 2) + _vres[0] = Val_int(_res); + _vres[1] = camlidl_c2ml_z3_Z3_ast(&*v, _ctx); + _vresult = camlidl_alloc_small(2, 0); + Field(_vresult, 0) = _vres[0]; + Field(_vresult, 1) = _vres[1]; + End_roots() + camlidl_free(_ctx); + return _vresult; +} + +value camlidl_z3_Z3_open_log( + value _v_c, + value _v_filename) +{ + Z3_context c; /*in*/ + char const *filename; /*in*/ + int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + filename = String_val(_v_filename); + _res = Z3_open_log(c, filename); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_append_log( + value _v_c, + value _v_string) +{ + Z3_context c; /*in*/ + char const *string; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + string = String_val(_v_string); + Z3_append_log(c, string); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_close_log( + value _v_c) +{ + Z3_context c; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + Z3_close_log(c); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_set_ast_print_mode( + value _v_c, + value _v_mode) +{ + Z3_context c; /*in*/ + Z3_ast_print_mode mode; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast_print_mode(_v_mode, &mode, _ctx); + Z3_set_ast_print_mode(c, mode); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_ast_to_string( + value _v_c, + value _v_a) +{ + Z3_context c; /*in*/ + Z3_ast a; /*in*/ + char const *_res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); + _res = Z3_ast_to_string(c, a); + _vres = copy_string(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_pattern_to_string( + value _v_c, + value _v_p) +{ + Z3_context c; /*in*/ + Z3_pattern p; /*in*/ + char const *_res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_pattern(_v_p, &p, _ctx); + _res = Z3_pattern_to_string(c, p); + _vres = copy_string(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_sort_to_string( + value _v_c, + value _v_s) +{ + Z3_context c; /*in*/ + Z3_sort s; /*in*/ + char const *_res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_s, &s, _ctx); + _res = Z3_sort_to_string(c, s); + _vres = copy_string(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_func_decl_to_string( + value _v_c, + value _v_d) +{ + Z3_context c; /*in*/ + Z3_func_decl d; /*in*/ + char const *_res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); + _res = Z3_func_decl_to_string(c, d); + _vres = copy_string(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_model_to_string( + value _v_c, + value _v_m) +{ + Z3_context c; /*in*/ + Z3_model m; /*in*/ + char const *_res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); + _res = Z3_model_to_string(c, m); + _vres = copy_string(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_benchmark_to_smtlib_string( + value _v_c, + value _v_name, + value _v_logic, + value _v_status, + value _v_attributes, + value _v_assumptions, + value _v_formula) +{ + Z3_context c; /*in*/ + char const *name; /*in*/ + char const *logic; /*in*/ + char const *status; /*in*/ + char const *attributes; /*in*/ + unsigned int num_assumptions; /*in*/ + Z3_ast *assumptions; /*in*/ + Z3_ast formula; /*in*/ + char const *_res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + name = String_val(_v_name); + logic = String_val(_v_logic); + status = String_val(_v_status); + attributes = String_val(_v_attributes); + _c1 = Wosize_val(_v_assumptions); + assumptions = camlidl_malloc(_c1 * sizeof(Z3_ast ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_assumptions, _c2); + camlidl_ml2c_z3_Z3_ast(_v3, &assumptions[_c2], _ctx); + } + num_assumptions = _c1; + camlidl_ml2c_z3_Z3_ast(_v_formula, &formula, _ctx); + _res = Z3_benchmark_to_smtlib_string(c, name, logic, status, attributes, num_assumptions, assumptions, formula); + _vres = copy_string(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_benchmark_to_smtlib_string_bytecode(value * argv, int argn) +{ + return camlidl_z3_Z3_benchmark_to_smtlib_string(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]); +} + +value camlidl_z3_Z3_context_to_string( + value _v_c) +{ + Z3_context c; /*in*/ + char const *_res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_context_to_string(c); + _vres = copy_string(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_statistics_to_string( + value _v_c) +{ + Z3_context c; /*in*/ + char const *_res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_statistics_to_string(c); + _vres = copy_string(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_context_assignment( + value _v_c) +{ + Z3_context c; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_get_context_assignment(c); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_parse_smtlib_string( + value _v_c, + value _v_str, + value _v_sort_names, + value _v_sorts, + value _v_decl_names, + value _v_decls) +{ + Z3_context c; /*in*/ + char const *str; /*in*/ + unsigned int num_sorts; /*in*/ + Z3_symbol *sort_names; /*in*/ + Z3_sort *sorts; /*in*/ + unsigned int num_decls; /*in*/ + Z3_symbol *decl_names; /*in*/ + Z3_func_decl *decls; /*in*/ + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + mlsize_t _c5; + value _v6; + mlsize_t _c7; + mlsize_t _c8; + value _v9; + mlsize_t _c10; + mlsize_t _c11; + value _v12; + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + str = String_val(_v_str); + _c1 = Wosize_val(_v_sort_names); + sort_names = camlidl_malloc(_c1 * sizeof(Z3_symbol ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_sort_names, _c2); + camlidl_ml2c_z3_Z3_symbol(_v3, &sort_names[_c2], _ctx); + } + num_sorts = _c1; + _c4 = Wosize_val(_v_sorts); + sorts = camlidl_malloc(_c4 * sizeof(Z3_sort ), _ctx); + for (_c5 = 0; _c5 < _c4; _c5++) { + _v6 = Field(_v_sorts, _c5); + camlidl_ml2c_z3_Z3_sort(_v6, &sorts[_c5], _ctx); + } + num_sorts = _c4; + _c7 = Wosize_val(_v_decl_names); + decl_names = camlidl_malloc(_c7 * sizeof(Z3_symbol ), _ctx); + for (_c8 = 0; _c8 < _c7; _c8++) { + _v9 = Field(_v_decl_names, _c8); + camlidl_ml2c_z3_Z3_symbol(_v9, &decl_names[_c8], _ctx); + } + num_decls = _c7; + _c10 = Wosize_val(_v_decls); + decls = camlidl_malloc(_c10 * sizeof(Z3_func_decl ), _ctx); + for (_c11 = 0; _c11 < _c10; _c11++) { + _v12 = Field(_v_decls, _c11); + camlidl_ml2c_z3_Z3_func_decl(_v12, &decls[_c11], _ctx); + } + num_decls = _c10; + Z3_parse_smtlib_string(c, str, num_sorts, sort_names, sorts, num_decls, decl_names, decls); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_parse_smtlib_string_bytecode(value * argv, int argn) +{ + return camlidl_z3_Z3_parse_smtlib_string(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); +} + +value camlidl_z3_Z3_parse_smtlib_file( + value _v_c, + value _v_file_name, + value _v_sort_names, + value _v_sorts, + value _v_decl_names, + value _v_decls) +{ + Z3_context c; /*in*/ + char const *file_name; /*in*/ + unsigned int num_sorts; /*in*/ + Z3_symbol *sort_names; /*in*/ + Z3_sort *sorts; /*in*/ + unsigned int num_decls; /*in*/ + Z3_symbol *decl_names; /*in*/ + Z3_func_decl *decls; /*in*/ + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + mlsize_t _c5; + value _v6; + mlsize_t _c7; + mlsize_t _c8; + value _v9; + mlsize_t _c10; + mlsize_t _c11; + value _v12; + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + file_name = String_val(_v_file_name); + _c1 = Wosize_val(_v_sort_names); + sort_names = camlidl_malloc(_c1 * sizeof(Z3_symbol ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_sort_names, _c2); + camlidl_ml2c_z3_Z3_symbol(_v3, &sort_names[_c2], _ctx); + } + num_sorts = _c1; + _c4 = Wosize_val(_v_sorts); + sorts = camlidl_malloc(_c4 * sizeof(Z3_sort ), _ctx); + for (_c5 = 0; _c5 < _c4; _c5++) { + _v6 = Field(_v_sorts, _c5); + camlidl_ml2c_z3_Z3_sort(_v6, &sorts[_c5], _ctx); + } + num_sorts = _c4; + _c7 = Wosize_val(_v_decl_names); + decl_names = camlidl_malloc(_c7 * sizeof(Z3_symbol ), _ctx); + for (_c8 = 0; _c8 < _c7; _c8++) { + _v9 = Field(_v_decl_names, _c8); + camlidl_ml2c_z3_Z3_symbol(_v9, &decl_names[_c8], _ctx); + } + num_decls = _c7; + _c10 = Wosize_val(_v_decls); + decls = camlidl_malloc(_c10 * sizeof(Z3_func_decl ), _ctx); + for (_c11 = 0; _c11 < _c10; _c11++) { + _v12 = Field(_v_decls, _c11); + camlidl_ml2c_z3_Z3_func_decl(_v12, &decls[_c11], _ctx); + } + num_decls = _c10; + Z3_parse_smtlib_file(c, file_name, num_sorts, sort_names, sorts, num_decls, decl_names, decls); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_parse_smtlib_file_bytecode(value * argv, int argn) +{ + return camlidl_z3_Z3_parse_smtlib_file(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); +} + +value camlidl_z3_Z3_get_smtlib_num_formulas( + value _v_c) +{ + Z3_context c; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_get_smtlib_num_formulas(c); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_smtlib_formula( + value _v_c, + value _v_i) +{ + Z3_context c; /*in*/ + unsigned int i; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + i = Int_val(_v_i); + _res = Z3_get_smtlib_formula(c, i); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_smtlib_num_assumptions( + value _v_c) +{ + Z3_context c; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_get_smtlib_num_assumptions(c); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_smtlib_assumption( + value _v_c, + value _v_i) +{ + Z3_context c; /*in*/ + unsigned int i; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + i = Int_val(_v_i); + _res = Z3_get_smtlib_assumption(c, i); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_smtlib_num_decls( + value _v_c) +{ + Z3_context c; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_get_smtlib_num_decls(c); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_smtlib_decl( + value _v_c, + value _v_i) +{ + Z3_context c; /*in*/ + unsigned int i; /*in*/ + Z3_func_decl _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + i = Int_val(_v_i); + _res = Z3_get_smtlib_decl(c, i); + _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_smtlib_num_sorts( + value _v_c) +{ + Z3_context c; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_get_smtlib_num_sorts(c); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_smtlib_sort( + value _v_c, + value _v_i) +{ + Z3_context c; /*in*/ + unsigned int i; /*in*/ + Z3_sort _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + i = Int_val(_v_i); + _res = Z3_get_smtlib_sort(c, i); + _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_get_smtlib_error( + value _v_c) +{ + Z3_context c; /*in*/ + char const *_res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + _res = Z3_get_smtlib_error(c); + _vres = copy_string(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_parse_z3_string( + value _v_c, + value _v_str) +{ + Z3_context c; /*in*/ + char const *str; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + str = String_val(_v_str); + _res = Z3_parse_z3_string(c, str); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_parse_z3_file( + value _v_c, + value _v_file_name) +{ + Z3_context c; /*in*/ + char const *file_name; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + file_name = String_val(_v_file_name); + _res = Z3_parse_z3_file(c, file_name); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_parse_smtlib2_string( + value _v_c, + value _v_str, + value _v_sort_names, + value _v_sorts, + value _v_decl_names, + value _v_decls) +{ + Z3_context c; /*in*/ + char const *str; /*in*/ + unsigned int num_sorts; /*in*/ + Z3_symbol *sort_names; /*in*/ + Z3_sort *sorts; /*in*/ + unsigned int num_decls; /*in*/ + Z3_symbol *decl_names; /*in*/ + Z3_func_decl *decls; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + mlsize_t _c5; + value _v6; + mlsize_t _c7; + mlsize_t _c8; + value _v9; + mlsize_t _c10; + mlsize_t _c11; + value _v12; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + str = String_val(_v_str); + _c1 = Wosize_val(_v_sort_names); + sort_names = camlidl_malloc(_c1 * sizeof(Z3_symbol ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_sort_names, _c2); + camlidl_ml2c_z3_Z3_symbol(_v3, &sort_names[_c2], _ctx); + } + num_sorts = _c1; + _c4 = Wosize_val(_v_sorts); + sorts = camlidl_malloc(_c4 * sizeof(Z3_sort ), _ctx); + for (_c5 = 0; _c5 < _c4; _c5++) { + _v6 = Field(_v_sorts, _c5); + camlidl_ml2c_z3_Z3_sort(_v6, &sorts[_c5], _ctx); + } + num_sorts = _c4; + _c7 = Wosize_val(_v_decl_names); + decl_names = camlidl_malloc(_c7 * sizeof(Z3_symbol ), _ctx); + for (_c8 = 0; _c8 < _c7; _c8++) { + _v9 = Field(_v_decl_names, _c8); + camlidl_ml2c_z3_Z3_symbol(_v9, &decl_names[_c8], _ctx); + } + num_decls = _c7; + _c10 = Wosize_val(_v_decls); + decls = camlidl_malloc(_c10 * sizeof(Z3_func_decl ), _ctx); + for (_c11 = 0; _c11 < _c10; _c11++) { + _v12 = Field(_v_decls, _c11); + camlidl_ml2c_z3_Z3_func_decl(_v12, &decls[_c11], _ctx); + } + num_decls = _c10; + _res = Z3_parse_smtlib2_string(c, str, num_sorts, sort_names, sorts, num_decls, decl_names, decls); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_parse_smtlib2_string_bytecode(value * argv, int argn) +{ + return camlidl_z3_Z3_parse_smtlib2_string(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); +} + +value camlidl_z3_Z3_parse_smtlib2_file( + value _v_c, + value _v_file_name, + value _v_sort_names, + value _v_sorts, + value _v_decl_names, + value _v_decls) +{ + Z3_context c; /*in*/ + char const *file_name; /*in*/ + unsigned int num_sorts; /*in*/ + Z3_symbol *sort_names; /*in*/ + Z3_sort *sorts; /*in*/ + unsigned int num_decls; /*in*/ + Z3_symbol *decl_names; /*in*/ + Z3_func_decl *decls; /*in*/ + Z3_ast _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + mlsize_t _c4; + mlsize_t _c5; + value _v6; + mlsize_t _c7; + mlsize_t _c8; + value _v9; + mlsize_t _c10; + mlsize_t _c11; + value _v12; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + file_name = String_val(_v_file_name); + _c1 = Wosize_val(_v_sort_names); + sort_names = camlidl_malloc(_c1 * sizeof(Z3_symbol ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_sort_names, _c2); + camlidl_ml2c_z3_Z3_symbol(_v3, &sort_names[_c2], _ctx); + } + num_sorts = _c1; + _c4 = Wosize_val(_v_sorts); + sorts = camlidl_malloc(_c4 * sizeof(Z3_sort ), _ctx); + for (_c5 = 0; _c5 < _c4; _c5++) { + _v6 = Field(_v_sorts, _c5); + camlidl_ml2c_z3_Z3_sort(_v6, &sorts[_c5], _ctx); + } + num_sorts = _c4; + _c7 = Wosize_val(_v_decl_names); + decl_names = camlidl_malloc(_c7 * sizeof(Z3_symbol ), _ctx); + for (_c8 = 0; _c8 < _c7; _c8++) { + _v9 = Field(_v_decl_names, _c8); + camlidl_ml2c_z3_Z3_symbol(_v9, &decl_names[_c8], _ctx); + } + num_decls = _c7; + _c10 = Wosize_val(_v_decls); + decls = camlidl_malloc(_c10 * sizeof(Z3_func_decl ), _ctx); + for (_c11 = 0; _c11 < _c10; _c11++) { + _v12 = Field(_v_decls, _c11); + camlidl_ml2c_z3_Z3_func_decl(_v12, &decls[_c11], _ctx); + } + num_decls = _c10; + _res = Z3_parse_smtlib2_file(c, file_name, num_sorts, sort_names, sorts, num_decls, decl_names, decls); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_parse_smtlib2_file_bytecode(value * argv, int argn) +{ + return camlidl_z3_Z3_parse_smtlib2_file(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); +} + +value camlidl_z3_Z3_get_version(value _unit) +{ + unsigned int *major; /*out*/ + unsigned int *minor; /*out*/ + unsigned int *build_number; /*out*/ + unsigned int *revision_number; /*out*/ + unsigned int _c1; + unsigned int _c2; + unsigned int _c3; + unsigned int _c4; + value _vresult; + value _vres[4] = { 0, 0, 0, 0, }; + + major = &_c1; + minor = &_c2; + build_number = &_c3; + revision_number = &_c4; + Z3_get_version(major, minor, build_number, revision_number); + Begin_roots_block(_vres, 4) + _vres[0] = Val_int(*major); + _vres[1] = Val_int(*minor); + _vres[2] = Val_int(*build_number); + _vres[3] = Val_int(*revision_number); + _vresult = camlidl_alloc_small(4, 0); + Field(_vresult, 0) = _vres[0]; + Field(_vresult, 1) = _vres[1]; + Field(_vresult, 2) = _vres[2]; + Field(_vresult, 3) = _vres[3]; + End_roots() + return _vresult; +} + +value camlidl_z3_Z3_reset_memory(value _unit) +{ + Z3_reset_memory(); + return Val_unit; +} + +value camlidl_z3_Z3_theory_mk_sort( + value _v_c, + value _v_t, + value _v_s) +{ + Z3_context c; /*in*/ + Z3_theory t; /*in*/ + Z3_symbol s; /*in*/ + Z3_sort _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_s, &s, _ctx); + _res = Z3_theory_mk_sort(c, t, s); + _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_theory_mk_value( + value _v_c, + value _v_t, + value _v_n, + value _v_s) +{ + Z3_context c; /*in*/ + Z3_theory t; /*in*/ + Z3_symbol n; /*in*/ + Z3_sort s; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_n, &n, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_s, &s, _ctx); + _res = Z3_theory_mk_value(c, t, n, s); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_theory_mk_constant( + value _v_c, + value _v_t, + value _v_n, + value _v_s) +{ + Z3_context c; /*in*/ + Z3_theory t; /*in*/ + Z3_symbol n; /*in*/ + Z3_sort s; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_n, &n, _ctx); + camlidl_ml2c_z3_Z3_sort(_v_s, &s, _ctx); + _res = Z3_theory_mk_constant(c, t, n, s); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_theory_mk_func_decl( + value _v_c, + value _v_t, + value _v_n, + value _v_domain, + value _v_range) +{ + Z3_context c; /*in*/ + Z3_theory t; /*in*/ + Z3_symbol n; /*in*/ + unsigned int domain_size; /*in*/ + Z3_sort const *domain; /*in*/ + Z3_sort range; /*in*/ + Z3_func_decl _res; + mlsize_t _c1; + mlsize_t _c2; + value _v3; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_n, &n, _ctx); + _c1 = Wosize_val(_v_domain); + domain = camlidl_malloc(_c1 * sizeof(Z3_sort const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_domain, _c2); + camlidl_ml2c_z3_Z3_sort(_v3, &domain[_c2], _ctx); + } + domain_size = _c1; + camlidl_ml2c_z3_Z3_sort(_v_range, &range, _ctx); + _res = Z3_theory_mk_func_decl(c, t, n, domain_size, domain, range); + _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_theory_get_context( + value _v_t) +{ + Z3_theory t; /*in*/ + Z3_context _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); + _res = Z3_theory_get_context(t); + _vres = camlidl_c2ml_z3_Z3_context(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_theory_assert_axiom( + value _v_t, + value _v_ax) +{ + Z3_theory t; /*in*/ + Z3_ast ax; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_ax, &ax, _ctx); + Z3_theory_assert_axiom(t, ax); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_theory_assume_eq( + value _v_t, + value _v_lhs, + value _v_rhs) +{ + Z3_theory t; /*in*/ + Z3_ast lhs; /*in*/ + Z3_ast rhs; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_lhs, &lhs, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_rhs, &rhs, _ctx); + Z3_theory_assume_eq(t, lhs, rhs); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_theory_enable_axiom_simplification( + value _v_t, + value _v_flag) +{ + Z3_theory t; /*in*/ + int flag; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); + flag = Int_val(_v_flag); + Z3_theory_enable_axiom_simplification(t, flag); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_theory_get_eqc_root( + value _v_t, + value _v_n) +{ + Z3_theory t; /*in*/ + Z3_ast n; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_n, &n, _ctx); + _res = Z3_theory_get_eqc_root(t, n); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_theory_get_eqc_next( + value _v_t, + value _v_n) +{ + Z3_theory t; /*in*/ + Z3_ast n; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_n, &n, _ctx); + _res = Z3_theory_get_eqc_next(t, n); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_theory_get_num_parents( + value _v_t, + value _v_n) +{ + Z3_theory t; /*in*/ + Z3_ast n; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_n, &n, _ctx); + _res = Z3_theory_get_num_parents(t, n); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_theory_get_parent( + value _v_t, + value _v_n, + value _v_i) +{ + Z3_theory t; /*in*/ + Z3_ast n; /*in*/ + unsigned int i; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_n, &n, _ctx); + i = Int_val(_v_i); + _res = Z3_theory_get_parent(t, n, i); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_theory_is_value( + value _v_t, + value _v_n) +{ + Z3_theory t; /*in*/ + Z3_ast n; /*in*/ + int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_n, &n, _ctx); + _res = Z3_theory_is_value(t, n); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_theory_is_decl( + value _v_t, + value _v_d) +{ + Z3_theory t; /*in*/ + Z3_func_decl d; /*in*/ + int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); + _res = Z3_theory_is_decl(t, d); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_theory_get_num_elems( + value _v_t) +{ + Z3_theory t; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); + _res = Z3_theory_get_num_elems(t); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_theory_get_elem( + value _v_t, + value _v_i) +{ + Z3_theory t; /*in*/ + unsigned int i; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); + i = Int_val(_v_i); + _res = Z3_theory_get_elem(t, i); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_theory_get_num_apps( + value _v_t) +{ + Z3_theory t; /*in*/ + unsigned int _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); + _res = Z3_theory_get_num_apps(t); + _vres = Val_int(_res); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_theory_get_app( + value _v_t, + value _v_i) +{ + Z3_theory t; /*in*/ + unsigned int i; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); + i = Int_val(_v_i); + _res = Z3_theory_get_app(t, i); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_datalog_add_rule( + value _v_c, + value _v_horn_rule, + value _v_name) +{ + Z3_context c; /*in*/ + Z3_ast horn_rule; /*in*/ + Z3_symbol name; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_horn_rule, &horn_rule, _ctx); + camlidl_ml2c_z3_Z3_symbol(_v_name, &name, _ctx); + Z3_datalog_add_rule(c, horn_rule, name); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_datalog_query( + value _v_c, + value _v_q) +{ + Z3_context c; /*in*/ + Z3_ast q; /*in*/ + Z3_ast _res; + value _vres; + + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_ast(_v_q, &q, _ctx); + _res = Z3_datalog_query(c, q); + _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); + camlidl_free(_ctx); + return _vres; +} + +value camlidl_z3_Z3_datalog_set_predicate_representation( + value _v_c, + value _v_f, + value _v_relation_kinds) +{ + Z3_context c; /*in*/ + Z3_func_decl f; /*in*/ + unsigned int num_relations; /*in*/ + Z3_symbol const *relation_kinds; /*in*/ + mlsize_t _c1; + mlsize_t _c2; + value _v3; + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + camlidl_ml2c_z3_Z3_func_decl(_v_f, &f, _ctx); + _c1 = Wosize_val(_v_relation_kinds); + relation_kinds = camlidl_malloc(_c1 * sizeof(Z3_symbol const ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { + _v3 = Field(_v_relation_kinds, _c2); + camlidl_ml2c_z3_Z3_symbol(_v3, &relation_kinds[_c2], _ctx); + } + num_relations = _c1; + Z3_datalog_set_predicate_representation(c, f, num_relations, relation_kinds); + camlidl_free(_ctx); + return Val_unit; +} + +value camlidl_z3_Z3_datalog_parse_file( + value _v_c, + value _v_filename) +{ + Z3_context c; /*in*/ + char const *filename; /*in*/ + struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; + camlidl_ctx _ctx = &_ctxs; + camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); + filename = String_val(_v_filename); + Z3_datalog_parse_file(c, filename); + camlidl_free(_ctx); + return Val_unit; +} + diff --git a/external/z3/ocaml/z3_theory_stubs.c b/external/z3/ocaml/z3_theory_stubs.c new file mode 100644 --- /dev/null +++ b/external/z3/ocaml/z3_theory_stubs.c @@ -0,0 +1,337 @@ +/*++ +Copyright (c) 2010 Microsoft Corporation + +Module Name: + + z3_theory_stubs.c + +Abstract: + + OCaml C bindings for callbacks between OCaml and C for + theory plugins. + The API for theory plugins require associating a set of + callbacks as C function pointers. + We use the following strategy: + + - store in the user_ext_data blob that theory constructors allow + a record of callback functions. + + - define catch-all static callback functions that access the + ML record with the callbacks. It then invokes these through user-registered + application functions that apply the callback stored in the record to the + actual parameters. + It is tempting to avoid this user-registered callback and directly access + the record of callback functions and apply the proper field. + However, the layout of records appears to be opaque, or at least we assume it is + so, from the C runtime. + +Author: + + +Revision History: +--*/ + +#include +#include +#include +#include +#include +#include +#include +#ifdef Custom_tag +#include +#include +#endif + +#include "z3.h" + +#define ML_SIZE(_ty) ((sizeof(_ty) + sizeof(value) - 1)/ sizeof(value)) + +static value mk_func_decl(Z3_func_decl f) { + value _f = alloc(ML_SIZE(Z3_func_decl), Abstract_tag); + *((Z3_func_decl*) Bp_val(_f)) = f; + return _f; +} + +static value Val_ast(Z3_ast a) { + value _a = alloc(ML_SIZE(Z3_ast), Abstract_tag); + *((Z3_ast*) Bp_val(_a)) = a; + return _a; +} + + +static value Val_ast_array(unsigned int sz, Z3_ast const args[]) { + value res; + Z3_ast* args1; + unsigned int i; + args1 = malloc((sz+1)*sizeof(Z3_ast)); + for (i = 0; i < sz; ++i) { + args1[i] = args[i]; + } + args1[sz] = 0; + res = alloc_array((value (*)(char const*))Val_ast, (const char**)args1); + free(args1); + return res; +} + +// ------------------ +// get_theory_callbacks +// + +value get_theory_callbacks(value th) +{ + Z3_theory _th = *((Z3_theory*) Bp_val(th)); + return (value) Z3_theory_get_ext_data(_th); +} + +// ------------------ +// delete_theory +// +static void delete_callback_static(Z3_theory th) +{ + CAMLparam0(); + CAMLlocal1(f); + value user_data = (value) Z3_theory_get_ext_data(th); + f = *(caml_named_value("apply_delete")) ; + callback(f, user_data); + remove_global_root(&user_data); + CAMLreturn0; +} + +#define SET_CALLBACK(_cb_name) \ + value set_ ## _cb_name ## _callback_register(value th) \ + { \ + CAMLparam1(th); \ + Z3_theory _th = *((Z3_theory*) Bp_val(th)); \ + Z3_set_ ## _cb_name ## _callback(_th, _cb_name ## _callback_static); \ + CAMLreturn(Val_unit); \ + } \ + +SET_CALLBACK(delete); + + +// ------------------ +// mk_theory +// + +value mk_theory_register(value context, value name, value user_data) +{ + CAMLparam3(context, name, user_data); + Z3_context _context = *((Z3_context *) Bp_val(context)); + value _th; + Z3_theory th; + register_global_root(&user_data); + th = Z3_mk_theory(_context, String_val(name), (void*)user_data); + Z3_set_delete_callback(th, delete_callback_static); + _th = alloc(ML_SIZE(Z3_context), Abstract_tag); + *((Z3_theory*) Bp_val(_th)) = th; + CAMLreturn(_th); +} + + +// ------------------- +// reduce_app_callback + +static Z3_bool reduce_app_callback_static(Z3_theory th, Z3_func_decl f, unsigned num_args, Z3_ast const args[], Z3_ast* r) { + CAMLparam0(); + CAMLlocal4(cb, _r, _v, _args); + value user_data; + Z3_bool result; + + _args = Val_ast_array(num_args, args); + + user_data = (value) Z3_theory_get_ext_data(th); + + cb = *(caml_named_value("apply_reduce_app")); + _r = callback3(cb, user_data, mk_func_decl(f), _args); + + cb = *(caml_named_value("is_some")); + _v = callback(cb, _r); + result = 0 != Bool_val(_v); + + if (result && r) { + cb = *(caml_named_value("get_some")); + _v = callback(cb, _r); + *r = *((Z3_ast*) Bp_val(_v)); + } + + CAMLreturn (result); +} + +SET_CALLBACK(reduce_app); + +// ------------------- +// reduce_eq_callback + +static Z3_bool reduce_eq_callback_static(Z3_theory th, Z3_ast a, Z3_ast b, Z3_ast * r) +{ + CAMLparam0(); + CAMLlocal5(cb, _r, _a, _b, _v); + value user_data; + Z3_bool result; + + _a = Val_ast(a); + _b = Val_ast(b); + + user_data = (value) Z3_theory_get_ext_data(th); + + cb = *(caml_named_value("apply_reduce_eq")); + _r = callback3(cb, user_data, _a, _b); + + cb = *(caml_named_value("is_some")); + _v = callback(cb, _r); + result = 0 != Bool_val(_v); + + if (result && r) { + cb = *(caml_named_value("get_some")); + _v = callback(cb, _r); + *r = *((Z3_ast*) Bp_val(_v)); + } + + CAMLreturn (result); +} + +SET_CALLBACK(reduce_eq); + + +// ------------------- +// reduce_distinct + +static Z3_bool reduce_distinct_callback_static(Z3_theory th, unsigned n, Z3_ast const args[], Z3_ast * r) +{ + CAMLparam0(); + CAMLlocal4(cb, _r, _args, _v); + value user_data; + Z3_bool result; + + _args = Val_ast_array(n, args); + + user_data = (value) Z3_theory_get_ext_data(th); + + cb = *(caml_named_value("apply_reduce_distinct")); + _r = callback2(cb, user_data, _args); + + cb = *(caml_named_value("is_some")); + _v = callback(cb, _r); + result = 0 != Bool_val(_v); + + if (result && r) { + cb = *(caml_named_value("get_some")); + _v = callback(cb, _r); + *r = *((Z3_ast*) Bp_val(_v)); + } + + CAMLreturn (result); +} + +SET_CALLBACK(reduce_distinct); + +// ------------------- +// new_app + +#define AST_CALLBACK(_cb_name) \ +static void _cb_name##_callback_static(Z3_theory th, Z3_ast a) \ +{ \ + CAMLparam0(); \ + CAMLlocal3(cb, _a, user_data); \ + _a = Val_ast(a); \ + user_data = (value) Z3_theory_get_ext_data(th); \ + cb = *(caml_named_value("apply_" #_cb_name)); \ + callback2(cb, user_data, _a); \ + CAMLreturn0; \ +} \ + +AST_CALLBACK(new_app); +SET_CALLBACK(new_app); + +// ------------------- +// new_elem + +AST_CALLBACK(new_elem); +SET_CALLBACK(new_elem); + +// ------------------- +// init_search + +#define TH_CALLBACK(_cb_name) \ +static void _cb_name##_callback_static(Z3_theory th) \ +{ \ + CAMLparam0(); \ + CAMLlocal2(cb, user_data); \ + user_data = (value) Z3_theory_get_ext_data(th); \ + cb = *(caml_named_value("apply_" #_cb_name)); \ + callback(cb, user_data); \ + CAMLreturn0; \ +} \ + +TH_CALLBACK(init_search); +SET_CALLBACK(init_search); + +// ------------------- +// push + +TH_CALLBACK(push); +SET_CALLBACK(push); + +TH_CALLBACK(pop); +SET_CALLBACK(pop); + +TH_CALLBACK(restart); +SET_CALLBACK(restart); + +TH_CALLBACK(reset); +SET_CALLBACK(reset); + + +#define FC_CALLBACK(_cb_name) \ + static Z3_bool _cb_name##_callback_static(Z3_theory th) \ + { \ + CAMLparam0(); \ + CAMLlocal3(cb, r, user_data); \ + user_data = (value) Z3_theory_get_ext_data(th); \ + cb = *(caml_named_value("apply_" #_cb_name)); \ + r = callback(cb, user_data); \ + CAMLreturn (Bool_val(r) != 0); \ + } \ + +FC_CALLBACK(final_check); +SET_CALLBACK(final_check); + +#define AST_AST_CALLBACK(_cb_name) \ + static void _cb_name##_callback_static(Z3_theory th, Z3_ast a, Z3_ast b) \ + { \ + CAMLparam0(); \ + CAMLlocal4(cb, _a, _b, user_data); \ + _a = Val_ast(a); \ + _b = Val_ast(b); \ + user_data = (value) Z3_theory_get_ext_data(th); \ + cb = *(caml_named_value("apply_" #_cb_name)); \ + callback3(cb, user_data, _a, _b); \ + CAMLreturn0; \ + } \ + +AST_AST_CALLBACK(new_eq); +SET_CALLBACK(new_eq); + +AST_AST_CALLBACK(new_diseq); +SET_CALLBACK(new_diseq); + +#define AST_BOOL_CALLBACK(_cb_name) \ + static void _cb_name##_callback_static(Z3_theory th, Z3_ast a, Z3_bool b) \ + { \ + CAMLparam0(); \ + CAMLlocal4(cb, _a, _b, user_data); \ + _a = Val_ast(a); \ + _b = Val_bool(b); \ + user_data = (value) Z3_theory_get_ext_data(th); \ + cb = *(caml_named_value("apply_" #_cb_name)); \ + callback3(cb, user_data, _a, _b); \ + CAMLreturn0; \ + } \ + + +AST_BOOL_CALLBACK(new_assignment); +SET_CALLBACK(new_assignment); + +AST_CALLBACK(new_relevant); +SET_CALLBACK(new_relevant); diff --git a/liquid-fixpoint.cabal b/liquid-fixpoint.cabal new file mode 100644 --- /dev/null +++ b/liquid-fixpoint.cabal @@ -0,0 +1,133 @@ +name: liquid-fixpoint +version: 0.1.0.0 +synopsis: Predicate Abstraction-based Horn-Clause/Implication Constraint Solver +homepage: https://github.com/ucsd-progsys/liquid-fixpoint +license: BSD3 +license-file: LICENSE +author: Ranjit Jhala +maintainer: jhala@cs.ucsd.edu +category: Language +build-type: Custom +cabal-version: >=1.8 + +description: This package is a Haskell wrapper to the SMTLIB-based + Horn-Clause/Logical Implication constraint solver used + for Liquid Types. + . + The solver itself is written in Ocaml. + . + The package includes: + . + 1. Types for Expressions, Predicates, Constraints, Solutions + . + 2. Code for serializing the above + . + 3. Code for parsing the results from the fixpoint.native binary + . + 4. The Ocaml fixpoint code + . + 5. (Deprecated) Z3 binaries if you want to link against the API. + . + Requirements + . + In addition to the .cabal dependencies you require + . + - A Recent Ocaml compiler + . + - A Z3 Binary () + + +Extra-Source-Files: configure + , external/fixpoint/Makefile + , external/fixpoint/*.ml + , external/fixpoint/smtZ3.mem.ml + , external/fixpoint/smtZ3.nomem.ml + , external/fixpoint/*.mli + , external/fixpoint/*.mll + , external/fixpoint/*.mly + , external/misc/*.ml + , external/misc/*.mli + , external/ocamlgraph/.depend + , external/ocamlgraph/Makefile + , external/ocamlgraph/Makefile.in + , external/ocamlgraph/META + , external/ocamlgraph/META.in + , external/ocamlgraph/configure + , external/ocamlgraph/configure.in + , external/ocamlgraph/lib/*.ml + , external/ocamlgraph/lib/*.mli + , external/ocamlgraph/src/*.ml + , external/ocamlgraph/src/*.mli + , external/ocamlgraph/src/*.mll + , external/ocamlgraph/src/*.mly + , external/z3/include/*.h + , external/z3/lib/libz3-a-32b + , external/z3/lib/libz3-a-64b + , external/z3/lib/libz3-so-32b + , external/z3/lib/libz3-so-64b + , external/z3/ocaml/build-lib.sh + , external/z3/ocaml/z3.ml + , external/z3/ocaml/*.c + +Flag z3mem + Description: Link to Z3 + Default: False + +Executable fixpoint + Main-is: Fixpoint.hs + Build-Depends: base >= 4 && < 5 + , ghc==7.6.3 + , array + , syb + , cmdargs + , ansi-terminal + , bifunctors + , bytestring + , containers + , deepseq + , directory + , filemanip + , filepath + , ghc-prim + , mtl + , parsec + , pretty + , process + , text + , hashable<1.2 + , unordered-containers + , liquid-fixpoint + +Library + hs-source-dirs: src + Exposed-Modules: Language.Fixpoint.Names, + Language.Fixpoint.Files, + Language.Fixpoint.Config, + Language.Fixpoint.Types, + Language.Fixpoint.Sort, + Language.Fixpoint.Interface, + Language.Fixpoint.Parse, + Language.Fixpoint.PrettyPrint, + Language.Fixpoint.Misc + + Build-Depends: base + , ghc==7.6.3 + , array + , syb + , cmdargs + , ansi-terminal + , bifunctors + , bytestring + , containers + , deepseq + , directory + , filemanip + , filepath + , ghc-prim + , mtl + , parsec + , pretty + , process + , text + , hashable<1.2 + , unordered-containers diff --git a/src/Language/Fixpoint/Config.hs b/src/Language/Fixpoint/Config.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Config.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + + +module Language.Fixpoint.Config ( + Config (..) + , Command (..) + , SMTSolver (..) + , GenQualifierSort (..) + , withTarget +) where + +import Language.Fixpoint.Files +import System.FilePath +import System.Console.CmdArgs.Default +import Data.Typeable (Typeable) +import Data.Generics (Data) + + +class Command a where + command :: a -> String + +------------------------------------------------------------------------ +-- Configuration Options ----------------------------------------------- +------------------------------------------------------------------------ + +withTarget :: Config -> FilePath -> Config +withTarget cfg fq = cfg { inFile = fq } { outFile = fq `withExt` Out } + +data Config + = Config { + inFile :: FilePath -- target fq-file + , outFile :: FilePath -- output file + , solver :: SMTSolver -- which SMT solver to use + , genSorts :: GenQualifierSort -- generalize qualifier sorts + } deriving (Eq,Data,Typeable,Show) + +instance Default Config where + def = Config "" def def def + +instance Command Config where + command c = command (genSorts c) + ++ command (solver c) + ++ " -out " + ++ (outFile c) ++ " " ++ (inFile c) + +--------------------------------------------------------------------------------------- +-- newtype OFilePath = O FilePath +-- deriving (Eq, Data,Typeable,Show) +-- +-- instance Default OFilePath where +-- def = O "out" +-- +-- instance Command OFilePath where +-- command (O s) = " -out " ++ s + +newtype GenQualifierSort = GQS Bool + deriving (Eq, Data,Typeable,Show) + +instance Default GenQualifierSort where + def = GQS False + +instance Command GenQualifierSort where + command (GQS True) = "" + command (GQS False) = "-no-gen-qual-sorts" + +--------------------------------------------------------------------------------------- + +data SMTSolver = Z3 | Cvc4 | Mathsat | Z3mem + deriving (Eq,Data,Typeable) + +instance Command SMTSolver where + command s = " -smtsolver " ++ show s + +instance Default SMTSolver where + def = Z3 + +instance Show SMTSolver where + show Z3 = "z3" + show Cvc4 = "cvc4" + show Mathsat = "mathsat" + show Z3mem = "z3mem" + +smtSolver "z3" = Z3 +smtSolver "cvc4" = Cvc4 +smtSolver "mathsat" = Mathsat +smtSolver "z3mem" = Z3mem +smtSolver other = error $ "ERROR: unsupported SMT Solver = " ++ other + +-- defaultSolver :: Maybe SMTSolver -> SMTSolver +-- defaultSolver = fromMaybe Z3 + + + diff --git a/src/Language/Fixpoint/Files.hs b/src/Language/Fixpoint/Files.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Files.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module contains Haskell variables representing globally visible +-- names for files, paths, extensions. +-- +-- Rather than have strings floating around the system, all constant names +-- should be defined here, and the (exported) variables should be used and +-- manipulated elsewhere. + +module Language.Fixpoint.Files ( + + -- * Hardwired file extension names + Ext (..) + , extFileName + , extModuleName + , withExt + , isExtFile + + -- * Hardwired paths + , getFixpointPath, getZ3LibPath + + -- * Various generic utility functions for finding and removing files + , getHsTargets + , getFileInDirs + , findFileInDirs + , copyFiles + +) where + +import qualified Control.Exception as Ex +import Control.Monad -- .State +import Data.Functor ((<$>)) +import Data.List hiding (find) +import Data.Maybe (fromMaybe) +import System.Directory +import System.Environment +import System.FilePath +import System.FilePath.Find +import Language.Fixpoint.Misc + +------------------------------------------------------------ +-- | Hardwired Paths and Files ----------------------------- +------------------------------------------------------------ + +getFixpointPath = fromMaybe msg <$> findExecutable "fixpoint.native" + where msg = errorstar "Cannot find fixpoint binary [fixpoint.native]" + +getZ3LibPath = dropFileName <$> getFixpointPath + + +checkM f msg p + = do ex <- f p + if ex then return p else errorstar $ "Cannot find " ++ msg ++ " at :" ++ p + + +----------------------------------------------------------------------------------- + +data Ext = Cgi -- ^ Constraint Generation Information + | Fq -- ^ Input to constraint solving (fixpoint) + | Out -- ^ Output from constraint solving (fixpoint) + | Html -- ^ HTML file with inferred type annotations + | Annot -- ^ Text file with inferred types + | Hs -- ^ Target source + | LHs -- ^ Literate Haskell target source file + | Spec -- ^ Spec file (e.g. include/Prelude.spec) + | Hquals -- ^ Qualifiers file (e.g. include/Prelude.hquals) + | Result -- ^ Final result: SAFE/UNSAFE + | Cst -- ^ HTML file with templates? + | Mkdn -- ^ Markdown file (temporarily generated from .Lhs + annots) + | Json -- ^ JSON file containing result (annots + errors) + | Saved -- ^ Previous version of source (for incremental checking) + | Pred + | PAss + | Dat + deriving (Eq, Ord, Show) + +extMap e = go e + where + go Cgi = ".cgi" + go Pred = ".pred" + go PAss = ".pass" + go Dat = ".dat" + go Out = ".fqout" + go Fq = ".fq" + go Html = ".html" + go Cst = ".cst" + go Annot = ".annot" + go Hs = ".hs" + go LHs = ".lhs" + go Mkdn = ".markdown" + go Json = ".json" + go Spec = ".spec" + go Hquals = ".hquals" + go Result = ".out" + go Saved = ".bak" + go _ = errorstar $ "extMap: Unknown extension " ++ show e + +withExt :: FilePath -> Ext -> FilePath +withExt f ext = replaceExtension f (extMap ext) + +extFileName :: Ext -> FilePath -> FilePath +extFileName ext = (`addExtension` (extMap ext)) + +isExtFile :: Ext -> FilePath -> Bool +isExtFile ext = ((extMap ext) ==) . takeExtension + +extModuleName :: String -> Ext -> FilePath +extModuleName modName ext = + case explode modName of + [] -> errorstar $ "malformed module name: " ++ modName + ws -> extFileName ext $ foldr1 () ws + where explode = words . map (\c -> if c == '.' then ' ' else c) + +copyFiles :: [FilePath] -> FilePath -> IO () +copyFiles srcs tgt + = do Ex.catch (removeFile tgt) $ \(_ :: Ex.IOException) -> return () + forM_ srcs (readFile >=> appendFile tgt) + + +---------------------------------------------------------------------------------- + +getHsTargets p + | hasTrailingPathSeparator p = getHsSourceFiles p + | otherwise = return [p] + +getHsSourceFiles = find dirs hs + where hs = extension ==? ".hs" ||? extension ==? ".lhs" + dirs = liftM (not . ("dist" `isSuffixOf`)) directory + +--------------------------------------------------------------------------- + + +getFileInDirs :: FilePath -> [FilePath] -> IO (Maybe FilePath) +getFileInDirs name = findFirst (testM doesFileExist . ( name)) + +findFileInDirs :: FilePath -> [FilePath] -> IO FilePath +findFileInDirs file dirs + = liftM (fromMaybe err) (findFirst (find always (fileName ==? file)) dirs) + where err = errorstar $ "findFileInDirs: cannot find " ++ file ++ " in " ++ show dirs diff --git a/src/Language/Fixpoint/Interface.hs b/src/Language/Fixpoint/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Interface.hs @@ -0,0 +1,127 @@ +module Language.Fixpoint.Interface ( + + -- * Containing Constraints + FInfo (..) + + -- * Invoke Solver on Set of Constraints + , solve + , solveFile + + -- * Function to determine outcome + , resultExit + + -- * Validity Query + , checkValid + +) where + +{- Interfacing with Fixpoint Binary -} + +import Data.Hashable +import Data.Monoid +import Data.Functor +import Data.List +import qualified Data.HashMap.Strict as M +import System.IO (hPutStr, withFile, IOMode (..)) +import System.Exit +import System.Directory (getTemporaryDirectory) +import System.FilePath (()) +import Text.Printf + +import Language.Fixpoint.Config +import Language.Fixpoint.Types hiding (kuts, lits) +import Language.Fixpoint.Misc +import Language.Fixpoint.Parse (rr) +import Language.Fixpoint.Files +import Text.PrettyPrint.HughesPJ +import System.Console.CmdArgs.Default +import System.Console.CmdArgs.Verbosity + +--------------------------------------------------------------------------- +-- | One Shot validity query ---------------------------------------------- +--------------------------------------------------------------------------- + +--------------------------------------------------------------------------- +checkValid :: (Hashable a) => a -> [(Symbol, Sort)] -> Pred -> IO (FixResult a) +--------------------------------------------------------------------------- +checkValid n xts p + = do file <- ( show (hash n)) <$> getTemporaryDirectory + (r, _) <- solve def file [] $ validFInfo n xts p + return (sinfo <$> r) + +validFInfo :: a -> [(Symbol, Sort)] -> Pred -> FInfo a +validFInfo l xts p = FI constrm [] benv emptySEnv [] ksEmpty [] + where + constrm = M.singleton 0 $ validSubc l ibenv p + binds = [(x, trueSortedReft t) | (x, t) <- xts] + ibenv = insertsIBindEnv bids emptyIBindEnv + (bids, benv) = foldlMap (\e (x,t) -> insertBindEnv x t e) emptyBindEnv binds + +validSubc :: a -> IBindEnv -> Pred -> SubC a +validSubc l env p = subC env PTrue lhs rhs i t l + where + lhs = top + rhs = RR mempty (predReft p) + i = Just 0 + t = [] + +result :: a -> Bool -> FixResult a +result _ True = Safe +result x False = Unsafe [x] + + +--------------------------------------------------------------------------- +-- | Solve a system of horn-clause constraints ---------------------------- +--------------------------------------------------------------------------- + +--------------------------------------------------------------------------- +solve :: Config -> FilePath -> [FilePath] -> FInfo a + -> IO (FixResult (SubC a), M.HashMap Symbol Pred) +--------------------------------------------------------------------------- +solve cfg fn hqs fi + = {-# SCC "Solve" #-} execFq cfg fn hqs fi + >>= {-# SCC "exitFq" #-} exitFq fn (cm fi) + +execFq cfg fn hqs fi + = do copyFiles hqs fq + appendFile fq qstr + withFile fq AppendMode (\h -> {-# SCC "HPrintDump" #-} hPutStr h (render d)) + solveFile $ cfg `withTarget` fq + where + fq = extFileName Fq fn + d = {-# SCC "FixPointify" #-} toFixpoint fi + qstr = render ((vcat $ toFix <$> (quals fi)) $$ text "\n") + +--------------------------------------------------------------------------- +solveFile :: Config -> IO ExitCode +--------------------------------------------------------------------------- +solveFile cfg + = do fp <- getFixpointPath + z3 <- getZ3LibPath + v <- (\b -> if b then "-v 1" else "") <$> isLoud + ec <- {-# SCC "sysCall:Fixpoint" #-} executeShellCommand "fixpoint" $ fixCommand cfg fp z3 v + return ec + +fixCommand cfg fp z3 verbosity + = printf "LD_LIBRARY_PATH=%s %s %s -notruekvars -refinesort -noslice -nosimple -strictsortcheck -sortedquals %s" + z3 fp verbosity (command cfg) + +exitFq _ _ (ExitFailure n) | (n /= 1) + = return (Crash [] "Unknown Error", M.empty) +exitFq fn cm _ + = do str <- {-# SCC "readOut" #-} readFile (extFileName Out fn) + let (x, y) = {-# SCC "parseFixOut" #-} rr ({-# SCC "sanitizeFixpointOutput" #-} sanitizeFixpointOutput str) + return $ (plugC cm x, y) + +plugC = fmap . mlookup + +sanitizeFixpointOutput + = unlines + . filter (not . ("//" `isPrefixOf`)) + . chopAfter ("//QUALIFIERS" `isPrefixOf`) + . lines + +resultExit Safe = ExitSuccess +resultExit (Unsafe _) = ExitFailure 1 +resultExit _ = ExitFailure 2 + diff --git a/src/Language/Fixpoint/Misc.hs b/src/Language/Fixpoint/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Misc.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE DeriveDataTypeable, TupleSections, NoMonomorphismRestriction, ScopedTypeVariables #-} + +module Language.Fixpoint.Misc where + +import Data.Hashable +import qualified Control.Exception as Ex +-- import qualified Data.HashSet as S +import qualified Data.HashMap.Strict as M +import qualified Data.List as L +import qualified Data.ByteString as B +import Data.ByteString.Char8 (pack, unpack) +import Control.Applicative ((<$>)) +import Control.Monad (forM_) +import Data.Maybe (fromJust) +import Data.Maybe (catMaybes, fromMaybe) + +import System.Exit +import System.Process (system) +import Debug.Trace (trace) +import Data.Data +import System.Console.ANSI +import System.Console.CmdArgs.Verbosity (whenLoud) + +import Text.PrettyPrint.HughesPJ + +----------------------------------------------------------------------------------- +------------ Support for Colored Logging ------------------------------------------ +----------------------------------------------------------------------------------- + +data Moods = Ok | Loud | Sad | Happy | Angry + +moodColor Ok = Black +moodColor Loud = Blue +moodColor Sad = Magenta +moodColor Happy = Green +moodColor Angry = Red + +wrapStars msg = "\n**** " ++ msg ++ " " ++ replicate (74 - length msg) '*' + +withColor c act + = do setSGR [ SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid c] + act + setSGR [ Reset] + +colorStrLn c = withColor (moodColor c) . putStrLn +colorPhaseLn c msg = colorStrLn c . wrapStars . (msg ++) +startPhase c msg = colorPhaseLn c "START: " msg >> colorStrLn Ok " " +doneLine c msg = colorPhaseLn c "DONE: " msg >> colorStrLn Ok " " + +donePhase c str + = case lines str of + (l:ls) -> doneLine c l >> forM_ ls (colorPhaseLn c "") + _ -> return () + +----------------------------------------------------------------------------------- + +data Empty = Emp deriving (Data, Typeable, Eq, Show) + +unIntersperse x ys + = case L.elemIndex x ys of + Nothing -> [ys] + Just i -> let (y, _:ys') = splitAt i ys + in (y : unIntersperse x ys') + +(=>>) m f = m >>= (\x -> f x >> return x) + +wrap l r s = l ++ s ++ r + +repeats n = concat . replicate n + +errorstar = error . wrap (stars ++ "\n") (stars ++ "\n") + where stars = repeats 3 $ wrapStars "ERROR" + +errortext = errorstar . render + +putDocLn :: Doc -> IO () +putDocLn = putStrLn . render + +assertstar _ True x = x +assertstar msg False x = errorstar msg + +findWithDefaultL f ls d = fromMaybe d (L.find f ls) + +fst3 :: (a, b, c) -> a +fst3 (x,_,_) = x + +snd3 :: (a, b, c) -> b +snd3 (_,x,_) = x + +thd3 :: (a, b, c) -> c +thd3 (_,_,x) = x + + +single :: a -> [a] +single x = [x] + +mapFst f (x, y) = (f x, y) +mapSnd f (x, y) = (x, f y) + +mapFst3 f (x, y, z) = (f x, y, z) +mapSnd3 f (x, y, z) = (x, f y, z) +mapThd3 f (x, y, z) = (x, y, f z) + +expandSnd = concatMap (\(xs, y) -> (, y) <$> xs) + +mapPair :: (a -> b) -> (a, a) -> (b, b) +mapPair f (x, y) = (f x, f y) + +-- mlookup :: (Show k, Hashable k) => M.HashMap k v -> k -> v +mlookup m k + = case M.lookup k m of + Just v -> v + Nothing -> errorstar $ "mlookup: unknown key " ++ show k + + +mfromJust :: String -> Maybe a -> a +mfromJust _ (Just x) = x +mfromJust s Nothing = errorstar $ "mfromJust: Nothing " ++ s + +boxStrCat :: String -> [String] -> String +boxStrCat sep = ("[" ++) . (++ "]") . L.intercalate sep + +tryIgnore :: String -> IO () -> IO () +tryIgnore s a = Ex.catch a $ \e -> + do let err = show (e :: Ex.IOException) + putStrLn ("Warning: Couldn't do " ++ s ++ ": " ++ err) + return () + +traceShow :: Show a => String -> a -> a +traceShow s x = trace ("\nTrace: [" ++ s ++ "] : " ++ show x) $ x + +warnShow :: Show a => String -> a -> a +warnShow s x = trace ("\nWarning: [" ++ s ++ "] : " ++ show x) $ x + +-- inserts :: Hashable k => k -> v -> M.HashMap k [v] -> M.HashMap k [v] +inserts k v m = M.insert k (v : M.lookupDefault [] k m) m + +-- group :: Hashable k => [(k, v)] -> M.HashMap k [v] +group = L.foldl' (\m (k, v) -> inserts k v m) M.empty + +groupList = M.toList . group + +-- groupMap :: Hashable k => (a -> k) -> [a] -> M.HashMap k [a] +groupMap f xs = L.foldl' (\m x -> inserts (f x) x m) M.empty xs + +sortNub :: (Ord a) => [a] -> [a] +sortNub = nubOrd . L.sort + where nubOrd (x:t@(y:_)) + | x == y = nubOrd t + | otherwise = x : nubOrd t + nubOrd xs = xs + + +sortDiff :: (Ord a) => [a] -> [a] -> [a] +sortDiff x1s x2s = go (sortNub x1s) (sortNub x2s) + where go xs@(x:xs') ys@(y:ys') + | x < y = x : go xs' ys + | x == y = go xs' ys' + | otherwise = go xs ys' + go xs [] = xs + go [] _ = [] + + + + +distinct :: Ord a => [a] -> Bool +distinct xs = length xs == length (sortNub xs) + +tr_reverse :: [a] -> [a] +tr_reverse = L.foldl' (flip (:)) [] + +tr_foldr' :: (a -> b -> b) -> b -> [a] -> b +tr_foldr' f b = L.foldl' (flip f) b . tr_reverse + +safeZip msg xs ys + | nxs == nys + = zip xs ys + | otherwise + = errorstar $ "safeZip called on non-eq-sized lists (nxs = " ++ show nxs ++ ", nys = " ++ show nys ++ ") : " ++ msg + where nxs = length xs + nys = length ys + +-- eqLen = on (==) length + +safeZipWith msg f xs ys + | nxs == nys + = zipWith f xs ys + | otherwise + = errorstar $ "safeZipWith called on non-eq-sized lists (nxs = " ++ show nxs ++ ", nys = " ++ show nys ++ ") : " ++ msg + where nxs = length xs + nys = length ys + +-- safe0ZipWith msg f xs ys +-- | length xs == length ys +-- = zipWith f xs ys +-- safe0ZipWith _ _ [] _ +-- = [] +-- safe0ZipWith _ _ _ [] +-- = [] +-- safe0ZipWith msg _ xs ys +-- = errorstar $ "safeZipWith called on non-eq-sized lists (nxs = " ++ show nxs ++ ", nys = " ++ show nys ++ ") : " ++ msg +-- where nxs = length xs +-- nys = length ys + + +-- safeFromList :: (Hashable k, Show k, Show a) => String -> [(k, a)] -> M.HashMap k a +safeFromList msg = L.foldl' safeAdd M.empty + where safeAdd m (k, v) + | k `M.member` m = errorstar $ msg ++ "Duplicate key " ++ show k ++ "maps to: \n" ++ (show v) ++ "\n and \n" ++ show (m M.! k) + | otherwise = M.insert k v m + +safeUnion msg m1 m2 = + case L.find (`M.member` m1) (M.keys m2) of + Just k -> errorstar $ "safeUnion with common key = " ++ show k ++ " " ++ msg + Nothing -> M.union m1 m2 + +safeHead _ (x:_) = x +safeHead msg _ = errorstar $ "safeHead with empty list " ++ msg + +safeLast _ xs@(_:_) = last xs +safeLast msg _ = errorstar $ "safeLast with empty list " ++ msg + +safeInit _ xs@(_:_) = init xs +safeInit msg _ = errorstar $ "safeInit with empty list " ++ msg + + +-- memoIndex :: (Hashable b) => (a -> Maybe b) -> [a] -> [Maybe Int] +memoIndex f = snd . L.mapAccumL foo M.empty + where + foo memo z = + case f z of + Nothing -> (memo, Nothing) + Just k -> case k `M.lookup` memo of + Just i -> (memo, Just i) + Nothing -> (M.insert k (M.size memo) memo, Just (M.size memo)) + +checkFail :: [Char] -> (a -> Bool) -> a -> a +checkFail msg f x + | f x + = x + | otherwise + = errorstar $ "Check-Failure: " ++ msg + +chopAfter :: (a -> Bool) -> [a] -> [a] +chopAfter f xs + = case L.findIndex f xs of + Just n -> take n xs + Nothing -> xs + +chopPrefix p xs + | p `L.isPrefixOf` xs + = Just $ drop (length p) xs + | otherwise + = Nothing + +firstElem :: (Eq a) => [(a, t)] -> [a] -> Maybe Int +firstElem seps str + = case catMaybes [ L.elemIndex c str | (c, _) <- seps ] of + [] -> Nothing + is -> Just $ minimum is + +chopAlt :: (Eq a) => [(a, a)] -> [a] -> [[a]] +chopAlt seps = go + where go s = maybe [s] (go' s) (firstElem seps s) + go' s i = let (s0, s1@(c:_)) = splitAt i s + (Just c') = lookup c seps + in case L.elemIndex c' s1 of + Nothing -> [s1] + Just i' -> let (s2, s3) = splitAt (i' + 1) s1 in + s0 : s2 : go s3 + +firstElems :: [(B.ByteString, B.ByteString)] -> B.ByteString -> Maybe (Int, B.ByteString, (B.ByteString, B.ByteString)) +firstElems seps str + = case splitters seps str of + [] -> Nothing + is -> Just $ L.minimumBy (\x y -> compare (fst3 x) (fst3 y)) is + +splitters seps str + = [(i, c', z) | (c, c') <- seps + , let z = B.breakSubstring c str + , let i = B.length (fst z) + , i < B.length str ] + + +bchopAlts :: [(B.ByteString, B.ByteString)] -> B.ByteString -> [B.ByteString] +bchopAlts seps = go + where + go s = maybe [s] (go' s) (firstElems seps s) + go' s (i,c',(s0, s1)) = if (B.length s2 == B.length s1) then [B.concat [s0,s1]] else (s0 : s2' : go s3') + where (s2, s3) = B.breakSubstring c' s1 + s2' = B.append s2 c' + s3' = B.drop (B.length c') s3 + +chopAlts seps str = unpack <$> bchopAlts [(pack c, pack c') | (c, c') <- seps] (pack str) + +findFirst :: Monad m => (t -> m [a]) -> [t] -> m (Maybe a) +findFirst _ [] = return Nothing +findFirst f (x:xs) = do r <- f x + case r of + y:_ -> return (Just y) + [] -> findFirst f xs + +testM f x = do b <- f x + return $ if b then [x] else [] + +-- unions :: (Hashable a) => [S.HashSet a] -> S.HashSet a +-- unions = foldl' S.union S.empty +-- Just S.unions! + +stripParens ('(':xs) = stripParens xs +stripParens xs = stripParens' (reverse xs) +stripParens' (')':xs) = stripParens' xs +stripParens' xs = reverse xs + +ifM :: (Monad m) => m Bool -> m a -> m a -> m a +ifM bm xm ym + = do b <- bm + if b then xm else ym + +executeShellCommand phase cmd + = do whenLoud $ putStrLn $ "EXEC: " ++ cmd + Ex.bracket_ (startPhase Loud phase) (donePhase Loud phase) $ system cmd + +checkExitCode _ (ExitSuccess) = return () +checkExitCode cmd (ExitFailure n) = errorstar $ "cmd: " ++ cmd ++ " failure code " ++ show n + +hashMapToAscList :: Ord a => M.HashMap a b -> [(a, b)] +hashMapToAscList = L.sortBy (\x y -> compare (fst x) (fst y)) . M.toList + +hashMapMapWithKey :: (k -> v1 -> v2) -> M.HashMap k v1 -> M.HashMap k v2 +hashMapMapWithKey f = fromJust . M.traverseWithKey (\k v -> Just (f k v)) + +hashMapMapKeys :: (Eq k, Hashable k) => (t -> k) -> M.HashMap t v -> M.HashMap k v +hashMapMapKeys f = M.fromList . fmap (mapFst f) . M.toList + + +applyNonNull def _ [] = def +applyNonNull _ f xs = f xs + +concatMapM f = fmap concat . mapM f + + + +angleBrackets p = char '<' <> p <> char '>' +dot = char '.' +arrow = text "->" +dcolon = colon <> colon +intersperse d ds = hsep $ punctuate d ds + +tshow = text . show + +foldlMap :: (a -> b -> (c, a)) -> a -> [b] -> ([c], a) +foldlMap f b xs = (reverse zs, res) + where + (zs, res) = L.foldl' ff ([], b) xs + ff (ys, acc) x = let (y, acc') = f acc x in (y:ys, acc') + + diff --git a/src/Language/Fixpoint/Names.hs b/src/Language/Fixpoint/Names.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Names.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module contains Haskell variables representing globally visible names. +-- Rather than have strings floating around the system, all constant names +-- should be defined here, and the (exported) variables should be used and +-- manipulated elsewhere. + +module Language.Fixpoint.Names ( + + -- * Hardwired global names + dummyName + , preludeName + , boolConName + , funConName + , listConName + , tupConName + , propConName + , strConName + , vvName + , symSepName + , dropModuleNames + , takeModuleNames +) where + +import Data.List (intercalate) +import Language.Fixpoint.Misc (errorstar, safeLast, stripParens) + +---------------------------------------------------------------------------- +--------------- Global Name Definitions ------------------------------------ +---------------------------------------------------------------------------- + +preludeName = "Prelude" +dummyName = "_LIQUID_dummy" +boolConName = "Bool" +funConName = "->" +listConName = "[]" -- "List" +tupConName = "()" -- "Tuple" +propConName = "Prop" +strConName = "Str" +vvName = "VV" +symSepName = '#' + +-- dropModuleNames [] = [] +-- dropModuleNames s +-- | s == tupConName = tupConName +-- | otherwise = safeLast msg $ words $ dotWhite `fmap` stripParens s +-- where +-- msg = "dropModuleNames: " ++ s +-- dotWhite '.' = ' ' +-- dotWhite c = c + +dropModuleNames = mungeModuleNames safeLast "dropModuleNames: " +takeModuleNames = mungeModuleNames safeInit "takeModuleNames: " + +safeInit _ xs@(_:_) = intercalate "." $ init xs +safeInit msg _ = errorstar $ "safeInit with empty list " ++ msg + +mungeModuleNames _ _ [] = [] +mungeModuleNames f msg s + | s == tupConName = tupConName + | otherwise = f (msg ++ s) $ words $ dotWhite `fmap` stripParens s + where + dotWhite '.' = ' ' + dotWhite c = c + diff --git a/src/Language/Fixpoint/Parse.hs b/src/Language/Fixpoint/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Parse.hs @@ -0,0 +1,484 @@ +{-# LANGUAGE NoMonomorphismRestriction, FlexibleInstances, UndecidableInstances, TypeSynonymInstances, TupleSections #-} + +module Language.Fixpoint.Parse ( + + -- * Top Level Class for Parseable Values + Inputable (..) + + -- * Top Level Class for Parseable Values + , Parser + + -- * Lexer to add new tokens + , lexer + + -- * Some Important keyword and parsers + , reserved, reservedOp + , parens , brackets + , semi , comma + , colon , dcolon + , whiteSpace, blanks + + -- * Parsing basic entities + , fTyConP -- Type constructors + , lowerIdP -- Lower-case identifiers + , upperIdP -- Upper-case identifiers + , symbolP -- Arbitrary Symbols + , constantP -- (Integer) Constants + , integer -- Integer + + -- * Parsing recursive entities + , exprP -- Expressions + , predP -- Refinement Predicates + , qualifierP -- Qualifiers + + -- * Some Combinators + , condIdP -- condIdP :: [Char] -> (String -> Bool) -> Parser String + + -- * Getting a Fresh Integer while parsing + , freshIntP + + -- * Parsing Function + , doParse' + , parseFromFile + , remainderP + ) where + +import Control.Applicative ((<*>), (<$>), (<*)) +import Control.Monad +import Text.Parsec +import Text.Parsec.Expr +import Text.Parsec.Language +import Text.Parsec.String hiding (Parser, parseFromFile) +import Text.Printf (printf) +import qualified Text.Parsec.Token as Token +import qualified Data.HashMap.Strict as M + +import Data.Char (isLower, toUpper) +import Language.Fixpoint.Misc hiding (dcolon) +import Language.Fixpoint.Types +import Data.Maybe(maybe) + +type Parser = Parsec String Integer + +-------------------------------------------------------------------- + +languageDef = + emptyDef { Token.commentStart = "/* " + , Token.commentEnd = " */" + , Token.commentLine = "--" + , Token.identStart = satisfy (\_ -> False) + , Token.identLetter = satisfy (\_ -> False) + , Token.reservedNames = [ "SAT" + , "UNSAT" + , "true" + , "false" + , "mod" + , "data" + , "Bexp" + , "forall" + , "exists" + , "assume" + , "measure" + , "module" + , "spec" + , "where" + , "True" + , "Int" + , "import" + , "_|_" + , "|" + , "if", "then", "else" + ] + , Token.reservedOpNames = [ "+", "-", "*", "/", "\\" + , "<", ">", "<=", ">=", "=", "!=" , "/=" + , "mod", "and", "or" + --, "is" + , "&&", "||" + , "~", "=>", "<=>" + , "->" + , ":=" + , "&", "^", "<<", ">>", "--" + , "?", "Bexp" -- , "'" + ] + } + +lexer = Token.makeTokenParser languageDef +reserved = Token.reserved lexer +reservedOp = Token.reservedOp lexer +parens = Token.parens lexer +brackets = Token.brackets lexer +semi = Token.semi lexer +colon = Token.colon lexer +comma = Token.comma lexer +whiteSpace = Token.whiteSpace lexer +stringLiteral = Token.stringLiteral lexer + +-- identifier = Token.identifier lexer + + +blanks = many (satisfy (`elem` [' ', '\t'])) + +integer = try (liftM toInt is) + <|> liftM (negate . toInt) (char '-' >> is) + where is = liftM2 (\is _ -> is) (many1 digit) blanks + toInt s = (read s) :: Integer + +---------------------------------------------------------------- +------------------------- Expressions -------------------------- +---------------------------------------------------------------- + +condIdP :: [Char] -> (String -> Bool) -> Parser String +condIdP chars f + = do c <- letter + cs <- many (satisfy (`elem` chars)) + blanks + if f (c:cs) then return (c:cs) else parserZero + +upperIdP :: Parser String +upperIdP = condIdP symChars (not . isLower . head) + +lowerIdP :: Parser String +lowerIdP = condIdP symChars (isLower . head) + +symbolP :: Parser Symbol +symbolP = liftM stringSymbol symCharsP + +constantP :: Parser Constant +constantP = liftM I integer + +symconstP :: Parser SymConst +symconstP = SL <$> stringLiteral + +exprP :: Parser Expr +exprP = expr2P <|> lexprP + +lexprP :: Parser Expr +lexprP + = try (parens exprP) + <|> try (parens exprCastP) + <|> try (parens $ condP EIte exprP) + <|> try exprFunP + <|> try (liftM (EVar . stringSymbol) upperIdP) + <|> liftM expr symbolP + <|> liftM ECon constantP + <|> liftM ESym symconstP + <|> (reserved "_|_" >> return EBot) + +exprFunP = (try exprFunSpacesP) <|> (try exprFunSemisP) <|> exprFunCommasP + where + exprFunSpacesP = parens $ liftM2 EApp funSymbolP (sepBy exprP spaces) + exprFunCommasP = liftM2 EApp funSymbolP (parens $ sepBy exprP comma) + exprFunSemisP = liftM2 EApp funSymbolP (parenBrackets $ sepBy exprP semi) + funSymbolP = symbolP -- liftM stringSymbol lowerIdP + + +parenBrackets = parens . brackets + +expr2P = buildExpressionParser bops lexprP + +bops = [ [Infix (reservedOp "*" >> return (EBin Times)) AssocLeft] + , [Infix (reservedOp "/" >> return (EBin Div )) AssocLeft] + , [Infix (reservedOp "+" >> return (EBin Plus )) AssocLeft] + , [Infix (reservedOp "-" >> return (EBin Minus)) AssocLeft] + , [Infix (reservedOp "mod" >> return (EBin Mod )) AssocLeft] + ] + + +exprCastP + = do e <- exprP + ((try dcolon) <|> colon) + so <- sortP + return $ ECst e so + +dcolon = string "::" <* spaces + +sortP + = try (string "Integer" >> return FInt) + <|> try (string "Int" >> return FInt) + <|> try (string "int" >> return FInt) + <|> try (FObj . stringSymbol <$> lowerIdP) + <|> (FApp <$> fTyConP <*> many sortP ) + +symCharsP = (condIdP symChars (\_ -> True)) + +--------------------------------------------------------------------- +-------------------------- Predicates ------------------------------- +--------------------------------------------------------------------- + +predP :: Parser Pred +predP = try (parens pred2P) + <|> try (parens $ condP pIte predP) + <|> try (reservedOp "not" >> liftM PNot predP) + <|> try (reservedOp "&&" >> liftM PAnd predsP) + <|> try (reservedOp "||" >> liftM POr predsP) + <|> (qmP >> liftM PBexp exprP) + <|> (reserved "true" >> return PTrue) + <|> (reserved "false" >> return PFalse) + <|> (try predrP) + <|> (try (liftM PBexp exprFunP)) + +qmP = reserved "?" <|> reserved "Bexp" + +pred2P = buildExpressionParser lops predP + +predsP = brackets $ sepBy predP semi + +lops = [ [Prefix (reservedOp "~" >> return PNot)] + , [Infix (reservedOp "&&" >> return (\x y -> PAnd [x,y])) AssocRight] + , [Infix (reservedOp "||" >> return (\x y -> POr [x,y])) AssocRight] + , [Infix (reservedOp "=>" >> return PImp) AssocRight] + , [Infix (reservedOp "<=>" >> return PIff) AssocRight]] + +predrP = do e1 <- expr2P + r <- brelP + e2 <- expr2P + return $ r e1 e2 + +brelP :: Parser (Expr -> Expr -> Pred) +brelP = (reservedOp "==" >> return (PAtom Eq)) + <|> (reservedOp "=" >> return (PAtom Eq)) + <|> (reservedOp "!=" >> return (PAtom Ne)) + <|> (reservedOp "/=" >> return (PAtom Ne)) + <|> (reservedOp "<" >> return (PAtom Lt)) + <|> (reservedOp "<=" >> return (PAtom Le)) + <|> (reservedOp ">" >> return (PAtom Gt)) + <|> (reservedOp ">=" >> return (PAtom Ge)) + +condIteP f bodyP + = do reserved "if" + p <- predP + reserved "then" + b1 <- bodyP + reserved "else" + b2 <- bodyP + return $ f p b1 b2 + +condQmP f bodyP + = do p <- predP + reserved "?" + b1 <- bodyP + colon + b2 <- bodyP + return $ f p b1 b2 + +condP f bodyP + = try (condIteP f bodyP) + <|> (condQmP f bodyP) + +---------------------------------------------------------------------------------- +------------------------------------ BareTypes ----------------------------------- +---------------------------------------------------------------------------------- + +fTyConP + = (reserved "int" >> return intFTyCon) + <|> (reserved "bool" >> return boolFTyCon) + <|> (stringFTycon <$> upperIdP) + +refasP :: Parser [Refa] +refasP = (try (brackets $ sepBy (RConc <$> predP) semi)) + <|> liftM ((:[]) . RConc) predP + +--------------------------------------------------------------------- +-- | Parsing Qualifiers --------------------------------------------- +--------------------------------------------------------------------- + +-- qualifierP = mkQual <$> upperIdP <*> parens $ sepBy1 sortBindP comma <*> predP + +qualifierP = do n <- upperIdP + params <- parens $ sepBy1 sortBindP comma + _ <- colon + body <- predP + return $ mkQual n params body + +sortBindP = (,) <$> symbolP <* colon <*> sortP + +mkQual n xts p = Q n ((vv, t) : yts) (subst su p) + where + (vv,t):zts = xts + yts = mapFst mkParam <$> zts + su = mkSubst $ zipWith (\(z,_) (y,_) -> (z, eVar y)) zts yts + +mkParam s = stringSymbolRaw ('~' : toUpper c : cs) + where + (c:cs) = symbolString s + + +--------------------------------------------------------------------- +------------ Interacting with Fixpoint ------------------------------ +--------------------------------------------------------------------- + +fixResultP :: Parser a -> Parser (FixResult a) +fixResultP pp + = (reserved "SAT" >> return Safe) + <|> (reserved "UNSAT" >> Unsafe <$> (brackets $ sepBy pp comma)) + <|> (reserved "CRASH" >> crashP pp) + + + +crashP pp + = do i <- pp + msg <- many anyChar + return $ Crash [i] msg + +predSolP + = parens $ (predP <* (comma >> iQualP)) + + +iQualP + = upperIdP >> (parens $ sepBy symbolP comma) + +solution1P + = do reserved "solution:" + k <- symbolP + reserved ":=" + ps <- brackets $ sepBy predSolP semi + return (k, simplify $ PAnd ps) + +solutionP :: Parser (M.HashMap Symbol Pred) +solutionP + = M.fromList <$> sepBy solution1P whiteSpace + +solutionFileP + = liftM2 (,) (fixResultP integer) solutionP + +------------------------------------------------------------------------ + +remainderP p + = do res <- p + str <- stateInput <$> getParserState + return (res, str) + +doParse' parser f s + = case runParser (remainderP p) 0 f s of + Left e -> errorstar $ printf "parseError %s\n when parsing from %s\n" + (show e) f + Right (r, "") -> r + Right (_, rem) -> errorstar $ printf "doParse has leftover when parsing: %s\nfrom file %s\n" + rem f + where p = whiteSpace >> parser + + +parseFromFile :: Parser b -> SourceName -> IO b +parseFromFile p f = doParse' p f <$> readFile f + +freshIntP :: Parser Integer +freshIntP = do n <- stateUser <$> getParserState + updateState (+ 1) + return n + +---------------------------------------------------------------------------------------- +------------------------ Bundling Parsers into a Typeclass ----------------------------- +---------------------------------------------------------------------------------------- + +class Inputable a where + rr :: String -> a + rr' :: String -> String -> a + rr' = \_ -> rr + rr = rr' "" + +instance Inputable Symbol where + rr' = doParse' symbolP + +instance Inputable Constant where + rr' = doParse' constantP + +instance Inputable Pred where + rr' = doParse' predP + +instance Inputable Expr where + rr' = doParse' exprP + +instance Inputable [Refa] where + rr' = doParse' refasP + +instance Inputable (FixResult Integer) where + rr' = doParse' $ fixResultP integer + +instance Inputable (FixResult Integer, FixSolution) where + rr' = doParse' solutionFileP + +{- +--------------------------------------------------------------- +--------------------------- Testing --------------------------- +--------------------------------------------------------------- + +sa = "0" +sb = "x" +sc = "(x0 + y0 + z0) " +sd = "(x+ y * 1)" +se = "_|_ " +sf = "(1 + x + _|_)" +sg = "f(x,y,z)" +sh = "(f((x+1), (y * a * b - 1), _|_))" +si = "(2 + f((x+1), (y * a * b - 1), _|_))" + +s0 = "true" +s1 = "false" +s2 = "v > 0" +s3 = "(0 < v && v < 100)" +s4 = "(x < v && v < y+10 && v < z)" +s6 = "[(v > 0)]" +s6' = "x" +s7' = "(x <=> y)" +s8' = "(x <=> a = b)" +s9' = "(x <=> (a <= b && b < c))" + +s7 = "{ v: Int | [(v > 0)] }" +s8 = "x:{ v: Int | v > 0 } -> {v : Int | v >= x}" +s9 = "v = x+y" +s10 = "{v: Int | v = x + y}" + +s11 = "x:{v:Int | true } -> {v:Int | true }" +s12 = "y : {v:Int | true } -> {v:Int | v = x }" +s13 = "x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x + y}" +s14 = "x:{v:a | true} -> y:{v:b | true } -> {v:a | (x < v && v < y) }" +s15 = "x:Int -> Bool" +s16 = "x:Int -> y:Int -> {v:Int | v = x + y}" +s17 = "a" +s18 = "x:a -> Bool" +s20 = "forall a . x:Int -> Bool" + +s21 = "x:{v : GHC.Prim.Int# | true } -> {v : Int | true }" + +r0 = (rr s0) :: Pred +r0' = (rr s0) :: [Refa] +r1 = (rr s1) :: [Refa] + + +e1, e2 :: Expr +e1 = rr "(k_1 + k_2)" +e2 = rr "k_1" + +o1, o2, o3 :: FixResult Integer +o1 = rr "SAT " +o2 = rr "UNSAT [1, 2, 9,10]" +o3 = rr "UNSAT []" + +-- sol1 = doParse solution1P "solution: k_5 := [0 <= VV_int]" +-- sol2 = doParse solution1P "solution: k_4 := [(0 <= VV_int)]" + +b0, b1, b2, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13 :: BareType +b0 = rr "Int" +b1 = rr "x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x + y}" +b2 = rr "x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x - y}" +b4 = rr "forall a . x : a -> Bool" +b5 = rr "Int -> Int -> Int" +b6 = rr "(Int -> Int) -> Int" +b7 = rr "({v: Int | v > 10} -> Int) -> Int" +b8 = rr "(x:Int -> {v: Int | v > x}) -> {v: Int | v > 10}" +b9 = rr "x:Int -> {v: Int | v > x} -> {v: Int | v > 10}" +b10 = rr "[Int]" +b11 = rr "x:[Int] -> {v: Int | v > 10}" +b12 = rr "[Int] -> String" +b13 = rr "x:(Int, [Bool]) -> [(String, String)]" + +-- b3 :: BareType +-- b3 = rr "x:Int -> y:Int -> {v:Bool | ((v is True) <=> x = y)}" + +m1 = ["len :: [a] -> Int", "len (Nil) = 0", "len (Cons x xs) = 1 + len(xs)"] +m2 = ["tog :: LL a -> Int", "tog (Nil) = 100", "tog (Cons y ys) = 200"] + +me1, me2 :: Measure.Measure BareType Symbol +me1 = (rr $ intercalate "\n" m1) +me2 = (rr $ intercalate "\n" m2) +-} diff --git a/src/Language/Fixpoint/PrettyPrint.hs b/src/Language/Fixpoint/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/PrettyPrint.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + + +module Language.Fixpoint.PrettyPrint where + +import Text.PrettyPrint.HughesPJ +import Language.Fixpoint.Types +import Language.Fixpoint.Misc +import Control.Applicative ((<$>)) +import Text.Parsec + +class PPrint a where + pprint :: a -> Doc + +showpp :: (PPrint a) => a -> String +showpp = render . pprint + +instance PPrint a => PPrint (Maybe a) where + pprint = maybe (text "Nothing") ((text "Just" <+>) . pprint) + +instance PPrint a => PPrint [a] where + pprint = brackets . intersperse comma . map pprint + +instance (PPrint a, PPrint b, PPrint c) => PPrint (a, b, c) where + pprint (x, y, z) = parens $ (pprint x) <> text "," <> (pprint y) <> text "," <> (pprint z) + + +instance (PPrint a, PPrint b) => PPrint (a,b) where + pprint (x, y) = (pprint x) <+> text ":" <+> (pprint y) + +instance PPrint SourcePos where + pprint = text . show + +instance PPrint () where + pprint = text . show + +instance PPrint String where + pprint = text + +instance PPrint Int where + pprint = toFix + +instance PPrint Integer where + pprint = toFix + +instance PPrint Constant where + pprint = toFix + +instance PPrint Brel where + pprint Eq = text "==" + pprint Ne = text "/=" + pprint r = toFix r + +instance PPrint Bop where + pprint = toFix + +instance PPrint Sort where + pprint = toFix + +instance PPrint Symbol where + pprint = toFix + +instance PPrint SymConst where + pprint (SL x) = doubleQuotes $ text x + +instance PPrint Expr where + pprint (EApp f es) = parens $ intersperse empty $ (pprint f) : (pprint <$> es) + pprint (ESym c) = pprint c + pprint (ECon c) = pprint c + pprint (EVar s) = pprint s + pprint (ELit s _) = pprint s + pprint (EBin o e1 e2) = parens $ pprint e1 <+> pprint o <+> pprint e2 + pprint (EIte p e1 e2) = parens $ text "if" <+> pprint p <+> text "then" <+> pprint e1 <+> text "else" <+> pprint e2 + pprint (ECst e so) = parens $ pprint e <+> text " : " <+> pprint so + pprint (EBot) = text "_|_" + +instance PPrint Pred where + pprint PTop = text "???" + pprint PTrue = trueD + pprint PFalse = falseD + pprint (PBexp e) = parens $ pprint e + pprint (PNot p) = parens $ text "not" <+> parens (pprint p) + pprint (PImp p1 p2) = parens $ (pprint p1) <+> text "=>" <+> (pprint p2) + pprint (PIff p1 p2) = parens $ (pprint p1) <+> text "<=>" <+> (pprint p2) + pprint (PAnd ps) = parens $ pprintBin trueD andD ps + pprint (POr ps) = parens $ pprintBin falseD orD ps + pprint (PAtom r e1 e2) = parens $ pprint e1 <+> pprint r <+> pprint e2 + pprint (PAll xts p) = text "forall" <+> toFix xts <+> text "." <+> pprint p + +trueD = text "true" +falseD = text "false" +andD = text " &&" +orD = text " ||" + +pprintBin b _ [] = b +pprintBin _ o xs = intersperse o $ pprint <$> xs + +pprintBin b o [] = b +pprintBin b o [x] = pprint x +pprintBin b o (x:xs) = pprint x <+> o <+> pprintBin b o xs + +instance PPrint Refa where + pprint (RConc p) = pprint p + pprint k = toFix k + +instance PPrint Reft where + pprint r@(Reft (_,ras)) + | isTauto r = text "true" + | otherwise = {- intersperse comma -} pprintBin trueD andD $ flattenRefas ras + + + +instance PPrint SortedReft where + pprint (RR so (Reft (v, ras))) + = braces + $ (pprint v) <+> (text ":") <+> (toFix so) <+> (text "|") <+> pprint ras + + + + + + + + + diff --git a/src/Language/Fixpoint/Sort.hs b/src/Language/Fixpoint/Sort.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Sort.hs @@ -0,0 +1,323 @@ + +-- | This module has the functions that perform sort-checking, and related +-- operations on Fixpoint expressions and predicates. + +module Language.Fixpoint.Sort ( + -- * Checking Well-Formedness + checkSorted + , checkSortedReft + , checkSortedReftFull + , pruneUnsortedReft + ) where + + + +import Language.Fixpoint.Types +import Language.Fixpoint.Misc +import Text.PrettyPrint.HughesPJ +import Text.Printf +import Control.Monad.Error (catchError, throwError) +import Control.Monad +import Control.Applicative +import Data.Maybe (fromMaybe, catMaybes) +import qualified Data.HashMap.Strict as M + +import Debug.Trace (trace) + +-- | Types used throughout checker + +type CheckM a = Either String a +type Env = Symbol -> SESearch Sort +fProp = FApp boolFTyCon [] +-- fProp = FApp propFTyCon [] + +------------------------------------------------------------------------- +-- | Checking Refinements ----------------------------------------------- +------------------------------------------------------------------------- + +checkSortedReft :: SEnv SortedReft -> [Symbol] -> SortedReft -> Maybe Doc +checkSortedReft env xs sr = applyNonNull Nothing error unknowns + where + error = Just . (text "Unknown symbols:" <+>) . toFix + unknowns = [ x | x <- syms sr, not (x `elem` v : xs), not (x `memberSEnv` env)] + Reft (v,_) = sr_reft sr + +checkSortedReftFull :: Checkable a => SEnv SortedReft -> a -> Maybe Doc +checkSortedReftFull γ t + = case check γ' t of + Left err -> Just (text err) + Right _ -> Nothing + where + γ' = mapSEnv sr_sort γ + +checkSorted :: Checkable a => SEnv Sort -> a -> Maybe Doc +checkSorted γ t + = case check γ t of + Left err -> Just (text err) + Right _ -> Nothing + +pruneUnsortedReft :: SEnv Sort -> SortedReft -> SortedReft +pruneUnsortedReft γ (RR s (Reft (v, ras))) + = RR s (Reft (v, catMaybes (go <$> ras))) + where + go r = case checkRefa f r of + Left war -> trace (wmsg war r) $ Nothing + Right _ -> Just r + γ' = insertSEnv v s γ + f = (`lookupSEnvWithDistance` γ') + + wmsg t r = "WARNING: prune unsorted reft:\n" ++ showFix r ++ "\n" ++ t + +checkRefa f (RConc p) = checkPred f p +checkRefa f _ = return () + + +class Checkable a where + check :: SEnv Sort -> a -> CheckM () + +instance Checkable Refa where + check γ = checkRefa (`lookupSEnvWithDistance` γ) + +instance Checkable Expr where + check γ e = do {checkExpr f e; return ()} + where f = (`lookupSEnvWithDistance` γ) + +instance Checkable Pred where + check γ = checkPred f + where f = (`lookupSEnvWithDistance` γ) + +instance Checkable SortedReft where + check γ (RR s (Reft (v, ras))) = mapM_ (check γ') ras + where γ' = insertSEnv v s γ + +------------------------------------------------------------------------- +-- | Checking Expressions ----------------------------------------------- +------------------------------------------------------------------------- + +checkExpr :: Env -> Expr -> CheckM Sort + +checkExpr _ EBot = throwError "Type Error: Bot" +checkExpr _ (ECon _) = return FInt +checkExpr f (EVar x) = checkSym f x +checkExpr f (EBin o e1 e2) = checkOp f e1 o e2 +checkExpr f (EIte p e1 e2) = checkIte f p e1 e2 +checkExpr f (ECst e t) = checkCst f t e +checkExpr f (EApp g es) = checkApp f Nothing g es +checkExpr f (ELit _ t) = return t + +-- | Helper for checking symbol occurrences + +checkSym f x + = case f x of + Found s -> return s + Alts xs -> throwError $ errUnboundAlts x xs +-- $ traceFix ("checkSym: x = " ++ showFix x) (f x) + +-- | Helper for checking if-then-else expressions + +checkIte f p e1 e2 + = do tp <- checkPred f p + t1 <- checkExpr f e1 + t2 <- checkExpr f e2 + if t1 == t2 + then return t1 + else throwError (errIte e1 e2 t1 t2) + +-- | Helper for checking cast expressions + +checkCst f t (EApp g es) + = checkApp f (Just t) g es +checkCst f t e + = do t' <- checkExpr f e + if t == t' + then return t + else throwError (errCast e t' t) + +-- | Helper for checking uninterpreted function applications + +checkApp' f to g es + = do gt <- checkSym f g + (n, its, ot) <- sortFunction gt + unless (length its == length es) $ throwError (errArgArity g its es) + ets <- mapM (checkExpr f) es + θ <- unify its ets + let t = apply θ ot + case to of + Nothing -> return (θ, t) + Just t' -> do θ' <- unifyMany θ [t] [t'] + return (θ', apply θ' t) + + +checkApp f to g es + = snd <$> checkApp' f to g es + + +-- | Helper for checking binary (numeric) operations + +checkOp f e1 o e2 + = do t1 <- checkExpr f e1 + t2 <- checkExpr f e2 + checkOpTy f (EBin o e1 e2) t1 t2 + +checkOpTy f _ FInt FInt + = return FInt + +checkOpTy f e t@(FObj l) t'@(FObj l') + | l == l' + = checkNumeric f l >> return t + +checkOpTy f e t t' + = throwError $ errOp e t t' + +checkNumeric f l + = do t <- checkSym f l + unless (t == FNum) (throwError $ errNonNumeric l) + return () + +------------------------------------------------------------------------- +-- | Checking Predicates ------------------------------------------------ +------------------------------------------------------------------------- + +checkPred :: Env -> Pred -> CheckM () + +checkPred f PTrue = return () +checkPred f PFalse = return () +checkPred f (PBexp e) = checkPredBExp f e +checkPred f (PNot p) = checkPred f p +checkPred f (PImp p p') = mapM_ (checkPred f) [p, p'] +checkPred f (PIff p p') = mapM_ (checkPred f) [p, p'] +checkPred f (PAnd ps) = mapM_ (checkPred f) ps +checkPred f (POr ps) = mapM_ (checkPred f) ps +checkPred f (PAtom r e e') = checkRel f r e e' +checkPred f p = throwError $ errUnexpectedPred p + +checkPredBExp f e = do t <- checkExpr f e + unless (t == fProp) (throwError $ errBExp e t) + return () + + +-- | Checking Relations + +checkRel f Eq (EVar x) (EApp g es) = checkRelEqVar f x g es +checkRel f Eq (EApp g es) (EVar x) = checkRelEqVar f x g es +checkRel f r e1 e2 = do t1 <- checkExpr f e1 + t2 <- checkExpr f e2 + checkRelTy f (PAtom r e1 e2) r t1 t2 + +checkRelTy :: (Fixpoint a) => Env -> a -> Brel -> Sort -> Sort -> CheckM () +checkRelTy f _ _ (FObj l) (FObj l') | l /= l' + = (checkNumeric f l >> checkNumeric f l') `catchError` (\_ -> throwError $ errNonNumerics l l') +checkRelTy f _ _ FInt (FObj l) = (checkNumeric f l) `catchError` (\_ -> throwError $ errNonNumeric l) +checkRelTy f _ _ (FObj l) FInt = (checkNumeric f l) `catchError` (\_ -> throwError $ errNonNumeric l) +checkRelTy _ e Eq t1 t2 = unless (t1 == t2 && t1 /= fProp) (throwError $ errRel e t1 t2) +checkRelTy _ e Ne t1 t2 = unless (t1 == t2 && t1 /= fProp) (throwError $ errRel e t1 t2) +checkRelTy _ e _ t1 t2 = unless (t1 == t2) (throwError $ errRel e t1 t2) + + +-- | Special case for polymorphic singleton variable equality e.g. (x = Set_emp) + +checkRelEqVar f x g es = do tx <- checkSym f x + _ <- checkApp f (Just tx) g es + return () + + + + +------------------------------------------------------------------------- +-- | Error messages ----------------------------------------------------- +------------------------------------------------------------------------- + +errUnify t1 t2 = printf "Cannot unify %s with %s" (showFix t1) (showFix t2) + +errUnifyMany ts ts' = printf "Cannot unify types with different cardinalities %s and %s" + (showFix ts) (showFix ts') + +errRel e t1 t2 = printf "Invalid Relation %s with operand types %s and %s" + (showFix e) (showFix t1) (showFix t2) + +errBExp e t = printf "BExp %s with non-propositional type %s" (showFix e) (showFix t) + +errOp e t t' + | t == t' = printf "Operands have non-numeric types %s in %s" + (showFix t) (showFix e) + | otherwise = printf "Operands have different types %s and %s in %s" + (showFix t) (showFix t') (showFix e) + +errArgArity g its es = printf "Measure %s expects %d args but gets %d in %s" + (showFix g) (length its) (length es) (showFix (EApp g es)) + +errIte e1 e2 t1 t2 = printf "Mismatched branches in Ite: then %s : %s, else %s : %s" + (showFix e1) (showFix t1) (showFix e2) (showFix t2) + +errCast e t' t = printf "Cannot cast %s of sort %s to incompatible sort %s" + (showFix e) (showFix t') (showFix t) + +errUnbound x = printf "Unbound Symbol %s" (showFix x) +errUnboundAlts x xs = printf "Unbound Symbol %s\n Perhaps you meant: %s" + (showFix x) + (foldr1 (\w s -> w ++ ", " ++ s) (showFix <$> xs)) + +errNonFunction t = printf "Sort %s is not a function" (showFix t) + +errNonNumeric l = printf "FObj sort %s is not numeric" (showFix l) +errNonNumerics l l' = printf "FObj sort %s and %s are different and not numeric" (showFix l) (showFix l') + +errUnexpectedPred p = printf "Sort Checking: Unexpected Predicate %s" (showFix p) + +------------------------------------------------------------------------- +-- | Utilities for working with sorts ----------------------------------- +------------------------------------------------------------------------- + +-- | Unification of Sorts + +unify = unifyMany (Th M.empty) + +unifyMany θ ts ts' + | length ts == length ts' = foldM (uncurry . unify1) θ $ zip ts ts' + | otherwise = throwError $ errUnifyMany ts ts' + +-- unify1 _ FNum _ = Nothing +unify1 θ (FVar i) t = unifyVar θ i t +unify1 θ t (FVar i) = unifyVar θ i t +unify1 θ (FApp c ts) (FApp c' ts') + | c == c' = unifyMany θ ts ts' +unify1 θ t1 t2 + | t1 == t2 = return θ + | otherwise = throwError $ errUnify t1 t2 + +unifyVar θ i t + = case lookupVar i θ of + Just t' -> if t == t' then return θ else throwError (errUnify t t') + Nothing -> return $ updateVar i t θ + +-- | Sort Substitutions +newtype TVSubst = Th (M.HashMap Int Sort) + +-- | API for manipulating substitutions +lookupVar i (Th m) = M.lookup i m +updateVar i t (Th m) = Th (M.insert i t m) + +------------------------------------------------------------------------- +-- | Applying a Type Substitution --------------------------------------- +------------------------------------------------------------------------- + +apply θ = sortMap f + where + f t@(FVar i) = fromMaybe t (lookupVar i θ) + f t = t + +sortMap f (FFunc n ts) = FFunc n (sortMap f <$> ts) +sortMap f (FApp c ts) = FApp c (sortMap f <$> ts) +sortMap f t = f t + +------------------------------------------------------------------------ +-- | Deconstruct a function-sort --------------------------------------- +------------------------------------------------------------------------ + +sortFunction (FFunc n ts') = return (n, ts, t) + where + ts = take numArgs ts' + t = last ts' + numArgs = length ts' - 1 + +sortFunction t = throwError $ errNonFunction t diff --git a/src/Language/Fixpoint/Types.hs b/src/Language/Fixpoint/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Types.hs @@ -0,0 +1,1439 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module contains the data types, operations and serialization functions +-- for representing Fixpoint's implication (i.e. subtyping) and well-formedness +-- constraints in Haskell. The actual constraint solving is done by the +-- `fixpoint.native` which is written in Ocaml. + +module Language.Fixpoint.Types ( + + -- * Top level serialization + Fixpoint (..) + , toFixpoint + , FInfo (..) + + -- * Rendering + , showFix + , traceFix + , resultDoc + + -- * Embedding to Fixpoint Types + , Sort (..), FTycon, TCEmb + , intFTyCon, boolFTyCon, strFTyCon, propFTyCon + , stringFTycon, fTyconString + + -- * Symbols + , Symbol(..) + , anfPrefix, tempPrefix, vv, intKvar + , symChars, isNonSymbol, nonSymbol + , isNontrivialVV + , stringSymbol, symbolString + + -- * Creating Symbols + , dummySymbol, intSymbol, tempSymbol + , qualifySymbol, stringSymbolRaw + , suffixSymbol + + -- * Expressions and Predicates + , SymConst (..), Constant (..) + , Bop (..), Brel (..) + , Expr (..), Pred (..) + , eVar + , eProp + , pAnd, pOr, pIte + , isTautoPred + + -- * Generalizing Embedding with Typeclasses + , Symbolic (..) + , Expression (..) + , Predicate (..) + + -- * Constraints and Solutions + , SubC, WfC, subC, lhsCs, rhsCs, wfC, Tag, FixResult (..), FixSolution, addIds, sinfo + , trueSubCKvar + , removeLhsKvars + + -- * Environments + , SEnv, SESearch(..) + , emptySEnv, toListSEnv, fromListSEnv + , mapSEnv + , insertSEnv, deleteSEnv, memberSEnv, lookupSEnv + , intersectWithSEnv + , filterSEnv + , lookupSEnvWithDistance + + , FEnv, insertFEnv + , IBindEnv, BindId, insertsIBindEnv, deleteIBindEnv, emptyIBindEnv + , BindEnv, insertBindEnv, emptyBindEnv + + -- * Refinements + , Refa (..), SortedReft (..), Reft(..), Reftable(..) + + -- * Constructing Refinements + , trueSortedReft -- trivial reft + , trueRefa -- trivial reft + , exprReft -- singleton: v == e + , notExprReft -- singleton: v /= e + , symbolReft -- singleton: v == x + , propReft -- singleton: Prop(v) <=> p + , predReft -- any pred : p + , isFunctionSortedReft + , isNonTrivialSortedReft + , isTautoReft + , isSingletonReft + , isEVar + , isFalse + , flattenRefas, squishRefas + , shiftVV + + -- * Substitutions + , Subst, Subable (..) + , emptySubst, mkSubst, catSubst + , substExcept, substfExcept, subst1Except + , sortSubst + + -- * Visitors + , reftKVars + + -- * Functions on @Result@ + , colorResult + + -- * Cut KVars + , Kuts (..), ksEmpty, ksUnion + + -- * Qualifiers + , Qualifier (..) + + ) where + +import GHC.Generics (Generic) +import Debug.Trace (trace) + +import Data.Typeable (Typeable) +import Data.Generics (Data) +import Data.Monoid hiding ((<>)) +import Data.Functor +import Data.Char (ord, chr, isAlpha, isUpper, toLower) +import Data.List (sort, stripPrefix) +import Data.Hashable + +import Data.Maybe (fromMaybe) +import Text.Printf (printf) +import Control.DeepSeq +import Control.Arrow ((***)) + +import Language.Fixpoint.Misc +import Text.PrettyPrint.HughesPJ + +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Data.Array hiding (indices) +import Language.Fixpoint.Names + +class Fixpoint a where + toFix :: a -> Doc + + simplify :: a -> a + simplify = id + + +------------------------------------------------------------------------ + +showFix :: (Fixpoint a) => a -> String +showFix = render . toFix + +traceFix :: (Fixpoint a) => String -> a -> a +traceFix s x = trace ("\nTrace: [" ++ s ++ "] : " ++ showFix x) $ x + +type TCEmb a = M.HashMap a FTycon + +-- instance (Eq a, Hashable a) => Monoid (TCEmb a) where +-- mappend m1 m2 = M.fromList (M.toList m1 ++ M.toList m2) +-- mempty = M.empty + +exprSymbols :: Expr -> [Symbol] +exprSymbols = go + where + go (EVar x) = [x] + -- go (EDat x _) = [x] + go (ELit x _) = [x] + go (EApp f es) = f : concatMap go es + go (EBin _ e1 e2) = go e1 ++ go e2 + go (EIte p e1 e2) = predSymbols p ++ go e1 ++ go e2 + go (ECst e _) = go e + go _ = [] + +predSymbols :: Pred -> [Symbol] +predSymbols = go + where + go (PAnd ps) = concatMap go ps + go (POr ps) = concatMap go ps + go (PNot p) = go p + go (PIff p1 p2) = go p1 ++ go p2 + go (PImp p1 p2) = go p1 ++ go p2 + go (PBexp e) = exprSymbols e + go (PAtom _ e1 e2) = exprSymbols e1 ++ exprSymbols e2 + go (PAll xts p) = (fst <$> xts) ++ go p + go _ = [] + +reftKVars :: Reft -> [Symbol] +reftKVars (Reft (_,ras)) = [k | (RKvar k _) <- ras] + +--------------------------------------------------------------- +---------- (Kut) Sets of Kvars -------------------------------- +--------------------------------------------------------------- + +newtype Kuts = KS (S.HashSet Symbol) + +instance NFData Kuts where + rnf (KS _) = () -- rnf s + +instance Fixpoint Kuts where + toFix (KS s) = vcat $ ((text "cut " <>) . toFix) <$> S.toList s + +ksEmpty = KS S.empty +ksUnion kvs (KS s') = KS (S.union (S.fromList kvs) s') + +--------------------------------------------------------------- +---------- Converting Constraints to Fixpoint Input ----------- +--------------------------------------------------------------- + +instance (Eq a, Hashable a, Fixpoint a) => Fixpoint (S.HashSet a) where + toFix xs = brackets $ sep $ punctuate (text ";") (toFix <$> S.toList xs) + simplify = S.fromList . map simplify . S.toList + +instance Fixpoint a => Fixpoint (Maybe a) where + toFix = maybe (text "Nothing") ((text "Just" <+>) . toFix) + simplify = fmap simplify + +instance Fixpoint a => Fixpoint [a] where + toFix xs = brackets $ sep $ punctuate (text ";") (fmap toFix xs) + simplify = map simplify + +instance (Fixpoint a, Fixpoint b) => Fixpoint (a,b) where + toFix (x,y) = (toFix x) <+> text ":" <+> (toFix y) + simplify (x,y) = (simplify x, simplify y) + +toFix_gs (SE e) + = vcat $ map (toFix_constant . mapSnd sr_sort) $ hashMapToAscList e +toFix_constant (c, so) + = text "constant" <+> toFix c <+> text ":" <+> toFix so + + + +---------------------------------------------------------------------- +------------------------ Type Constructors --------------------------- +---------------------------------------------------------------------- + +newtype FTycon = TC Symbol deriving (Eq, Ord, Show, Data, Typeable) + + +intFTyCon = TC (S "int") +boolFTyCon = TC (S "bool") +strFTyCon = TC (S strConName) +propFTyCon = TC (S propConName) + +-- listFTyCon = TC (S listConName) + +-- isListTC = (listFTyCon ==) +isListTC (TC (S c)) = c == listConName +isTupTC (TC (S c)) = c == tupConName + +fTyconString (TC (S s)) = s + +stringFTycon :: String -> FTycon +stringFTycon c + | c == listConName = TC . S $ listConName + | otherwise = TC $ stringSymbol c + + +---------------------------------------------------------------------- +------------------------------- Sorts -------------------------------- +---------------------------------------------------------------------- + +data Sort = FInt + | FNum -- ^ numeric kind for Num tyvars + | FObj Symbol -- ^ uninterpreted type + | FVar !Int -- ^ fixpoint type variable + | FFunc !Int ![Sort] -- ^ type-var arity, in-ts ++ [out-t] + | FApp FTycon [Sort] -- ^ constructed type + deriving (Eq, Ord, Show, Generic, Data, Typeable) + +instance Hashable Sort + +newtype Sub = Sub [(Int, Sort)] + +instance Fixpoint Sort where + toFix = toFix_sort + +toFix_sort (FVar i) = text "@" <> parens (toFix i) +toFix_sort FInt = text "int" +toFix_sort (FObj x) = toFix x +toFix_sort FNum = text "num" +toFix_sort (FFunc n ts) = text "func" <> parens ((toFix n) <> (text ", ") <> (toFix ts)) +toFix_sort (FApp c [t]) + | isListTC c = brackets $ toFix_sort t +toFix_sort (FApp c ts) + | isTupTC c = parens $ intersperse comma $ toFix_sort <$> ts + | otherwise = toFix c <+> intersperse space (fp <$> ts) + where fp s@(FApp _ (_:_)) = parens $ toFix_sort s + fp s = toFix_sort s + + +instance Fixpoint FTycon where + toFix (TC s) = toFix s + +------------------------------------------------------------------------------------------- +sortSubst :: (M.HashMap Symbol Sort) -> Sort -> Sort +------------------------------------------------------------------------------------------- +sortSubst θ t@(FObj x) = fromMaybe t (M.lookup x θ) +sortSubst θ (FFunc n ts) = FFunc n (sortSubst θ <$> ts) +sortSubst θ (FApp c ts) = FApp c (sortSubst θ <$> ts) +sortSubst _ t = t + + +--------------------------------------------------------------- +---------------------------- Symbols -------------------------- +--------------------------------------------------------------- + +symChars + = ['a' .. 'z'] + ++ ['A' .. 'Z'] + ++ ['0' .. '9'] + ++ ['_', '%', '.', '#'] + +data Symbol = S !String deriving (Eq, Ord, Data, Typeable) + +instance Fixpoint Symbol where + toFix (S x) = text x + +instance Show Symbol where + show (S x) = x + +instance Show Subst where + show = showFix + +instance Fixpoint Subst where + toFix (Su m) = case {- hashMapToAscList -} m of + [] -> empty + xys -> hcat $ map (\(x,y) -> brackets $ (toFix x) <> text ":=" <> (toFix y)) xys + + +--------------------------------------------------------------------------- +------ Converting Strings To Fixpoint ------------------------------------- +--------------------------------------------------------------------------- + +stringSymbolRaw :: String -> Symbol +stringSymbolRaw = S + +stringSymbol :: String -> Symbol +stringSymbol s + | isFixKey s = encodeSym s + | isFixSym' s = S s + | otherwise = encodeSym s -- S $ fixSymPrefix ++ concatMap encodeChar s + +encodeSym s = S $ fixSymPrefix ++ concatMap encodeChar s + +symbolString :: Symbol -> String +symbolString (S str) + = case chopPrefix fixSymPrefix str of + Just s -> concat $ zipWith tx indices $ chunks s + Nothing -> str + where + chunks = unIntersperse symSepName + tx i s = if even i then s else [decodeStr s] + +indices :: [Integer] +indices = [0..] + +okSymChars + = ['a' .. 'z'] + ++ ['A' .. 'Z'] + ++ ['0' .. '9'] + ++ ['_', '.' ] + +fixSymPrefix = "fix" ++ [symSepName] + +suffixSymbol s suf = stringSymbol (symbolString s ++ suf) + +isFixSym' (c:chs) = isAlpha c && all (`elem` (symSepName:okSymChars)) chs +isFixSym' _ = False + +isFixKey x = S.member x keywords +keywords = S.fromList ["env", "id", "tag", "qualif", "constant", "cut", "bind", "constraint", "grd", "lhs", "rhs"] + +encodeChar c + | c `elem` okSymChars + = [c] + | otherwise + = [symSepName] ++ (show $ ord c) ++ [symSepName] + +decodeStr s + = chr ((read s) :: Int) + +qualifySymbol x sy + | isQualified x' = sy + | isParened x' = stringSymbol (wrapParens (x ++ "." ++ stripParens x')) + | otherwise = stringSymbol (x ++ "." ++ x') + where x' = symbolString sy + +isQualified y = '.' `elem` y +wrapParens x = "(" ++ x ++ ")" +isParened xs = xs /= stripParens xs + +--------------------------------------------------------------------- + +vv :: Maybe Integer -> Symbol +vv (Just i) = S (vvName ++ [symSepName] ++ show i) +vv Nothing = S vvName + +vvCon = S (vvName ++ [symSepName] ++ "F") + +isNontrivialVV = not . (vv_ ==) + + +dummySymbol = S dummyName +intSymbol x i = S $ x ++ show i + +tempSymbol :: String -> Integer -> Symbol +tempSymbol prefix n = intSymbol (tempPrefix ++ prefix) n + +tempPrefix = "lq_tmp_" +anfPrefix = "lq_anf_" +nonSymbol = S "" +isNonSymbol = (0 ==) . length . symbolString + +intKvar :: Integer -> Symbol +intKvar = intSymbol "k_" + +--------------------------------------------------------------- +------------------------- Expressions ------------------------- +--------------------------------------------------------------- + +-- | Uninterpreted constants that are embedded as "constant symbol : Str" + +data SymConst = SL !String + deriving (Eq, Ord, Show, Data, Typeable) + +data Constant = I !Integer + deriving (Eq, Ord, Show, Data, Typeable) + +data Brel = Eq | Ne | Gt | Ge | Lt | Le + deriving (Eq, Ord, Show, Data, Typeable) + +data Bop = Plus | Minus | Times | Div | Mod + deriving (Eq, Ord, Show, Data, Typeable) + -- NOTE: For "Mod" 2nd expr should be a constant or a var *) + +data Expr = ESym !SymConst + | ECon !Constant + | EVar !Symbol + | ELit !Symbol !Sort + | EApp !Symbol ![Expr] + | EBin !Bop !Expr !Expr + | EIte !Pred !Expr !Expr + | ECst !Expr !Sort + | EBot + deriving (Eq, Ord, Show, Data, Typeable) + +instance Fixpoint Integer where + toFix = integer + +instance Fixpoint Constant where + toFix (I i) = toFix i + +instance Fixpoint SymConst where + toFix = toFix . encodeSymConst + +instance Fixpoint Brel where + toFix Eq = text "=" + toFix Ne = text "!=" + toFix Gt = text ">" + toFix Ge = text ">=" + toFix Lt = text "<" + toFix Le = text "<=" + +instance Fixpoint Bop where + toFix Plus = text "+" + toFix Minus = text "-" + toFix Times = text "*" + toFix Div = text "/" + toFix Mod = text "mod" + +instance Fixpoint Expr where + toFix (ESym c) = toFix $ encodeSymConst c + toFix (ECon c) = toFix c + toFix (EVar s) = toFix s + toFix (ELit s _) = toFix s + toFix (EApp f es) = (toFix f) <> (parens $ toFix es) + toFix (EBin o e1 e2) = parens $ toFix e1 <+> toFix o <+> toFix e2 + toFix (EIte p e1 e2) = parens $ toFix p <+> text "?" <+> toFix e1 <+> text ":" <+> toFix e2 + toFix (ECst e so) = parens $ toFix e <+> text " : " <+> toFix so + toFix (EBot) = text "_|_" + +---------------------------------------------------------- +--------------------- Predicates ------------------------- +---------------------------------------------------------- + +data Pred = PTrue + | PFalse + | PAnd ![Pred] + | POr ![Pred] + | PNot !Pred + | PImp !Pred !Pred + | PIff !Pred !Pred + | PBexp !Expr + | PAtom !Brel !Expr !Expr + | PAll ![(Symbol, Sort)] !Pred + | PTop + deriving (Eq, Ord, Show, Data, Typeable) + +instance Fixpoint Pred where + toFix PTop = text "???" + toFix PTrue = text "true" + toFix PFalse = text "false" + toFix (PBexp e) = parens $ text "?" <+> toFix e + toFix (PNot p) = parens $ text "~" <+> parens (toFix p) + toFix (PImp p1 p2) = parens $ (toFix p1) <+> text "=>" <+> (toFix p2) + toFix (PIff p1 p2) = parens $ (toFix p1) <+> text "<=>" <+> (toFix p2) + toFix (PAnd ps) = text "&&" <+> toFix ps + toFix (POr ps) = text "||" <+> toFix ps + toFix (PAtom r e1 e2) = parens $ toFix e1 <+> toFix r <+> toFix e2 + toFix (PAll xts p) = text "forall" <+> (toFix xts) <+> text "." <+> (toFix p) + + simplify (PAnd []) = PTrue + simplify (POr []) = PFalse + simplify (PAnd [p]) = simplify p + simplify (POr [p]) = simplify p + + simplify (PAnd ps) + | any isContraPred ps = PFalse + | otherwise = PAnd $ filter (not . isTautoPred) $ map simplify ps + + simplify (POr ps) + | any isTautoPred ps = PTrue + | otherwise = POr $ filter (not . isContraPred) $ map simplify ps + + simplify p + | isContraPred p = PFalse + | isTautoPred p = PTrue + | otherwise = p + +zero = ECon (I 0) +one = ECon (I 1) + +isContraPred z = eqC z || (z `elem` contras) + where + contras = [PFalse] + + eqC (PAtom Eq (ECon x) (ECon y)) + = x /= y + eqC (PAtom Ne x y) + = x == y + eqC _ = False + +isTautoPred z = eqT z || (z `elem` tautos) + where + tautos = [PTrue] + + eqT (PAtom Le x y) + = x == y + eqT (PAtom Ge x y) + = x == y + eqT (PAtom Eq x y) + = x == y + eqT (PAtom Ne (ECon x) (ECon y)) + = x /= y + eqT _ = False + + + +isTautoReft (Reft (_, ras)) = all isTautoRa ras +isTautoRa (RConc p) = isTautoPred p +isTautoRa _ = False + +isEVar (EVar _) = True +isEVar _ = False + +isSingletonReft (Reft (v, [RConc (PAtom Eq e1 e2)])) + | e1 == EVar v = Just e2 + | e2 == EVar v = Just e1 +isSingletonReft _ = Nothing + +pAnd = simplify . PAnd +pOr = simplify . POr +pIte p1 p2 p3 = pAnd [p1 `PImp` p2, (PNot p1) `PImp` p3] + +mkProp = PBexp . EApp (S propConName) . (: []) + +ppr_reft (Reft (v, ras)) d + | all isTautoRa ras + = d + | otherwise + = braces (toFix v <+> colon <+> d <+> text "|" <+> ppRas ras) + +ppr_reft_pred (Reft (_, ras)) + | all isTautoRa ras + = text "true" + | otherwise + = ppRas ras + +ppRas = cat . punctuate comma . map toFix . flattenRefas + +------------------------------------------------------------------------ +-- | Generalizing Symbol, Expression, Predicate into Classes ----------- +------------------------------------------------------------------------ + +-- | Values that can be viewed as Symbols + +class Symbolic a where + symbol :: a -> Symbol + +-- | Values that can be viewed as Expressions + +class Expression a where + expr :: a -> Expr + +-- | Values that can be viewed as Predicates + +class Predicate a where + prop :: a -> Pred + +instance Symbolic String where + symbol = stringSymbol + +instance Symbolic Symbol where + symbol = id + +instance Expression Expr where + expr = id + +-- | The symbol may be an encoding of a SymConst. + +instance Expression Symbol where + expr s = maybe (eVar s) ESym (decodeSymConst s) + -- expr = eVar + +instance Expression String where + expr = ESym . SL + +instance Expression Integer where + expr = ECon . I + +instance Expression Int where + expr = expr . toInteger + +instance Predicate Symbol where + prop = eProp + +instance Predicate Pred where + prop = id + +instance Predicate Bool where + prop True = PTrue + prop False = PFalse + +eVar :: Symbolic a => a -> Expr +eVar = EVar . symbol + +eProp :: Symbolic a => a -> Pred +eProp = mkProp . eVar + +exprReft, notExprReft :: (Expression a) => a -> Reft +exprReft e = Reft (vv_, [RConc $ PAtom Eq (eVar vv_) (expr e)]) +notExprReft e = Reft (vv_, [RConc $ PAtom Ne (eVar vv_) (expr e)]) + +propReft :: (Predicate a) => a -> Reft +propReft p = Reft (vv_, [RConc $ PIff (eProp vv_) (prop p)]) + +predReft :: (Predicate a) => a -> Reft +predReft p = Reft (vv_, [RConc $ prop p]) + + + + +--------------------------------------------------------------- +----------------- Refinements --------------------------------- +--------------------------------------------------------------- + +data Refa + = RConc !Pred + | RKvar !Symbol !Subst + deriving (Eq, Ord, Show, Data, Typeable) + +newtype Reft = Reft (Symbol, [Refa]) deriving (Eq, Ord, Data, Typeable) + +instance Show Reft where + show (Reft x) = render $ toFix x + +data SortedReft = RR { sr_sort :: !Sort, sr_reft :: !Reft } deriving (Eq) + +isNonTrivialSortedReft (RR _ (Reft (_, ras))) + = not $ null ras + +isFunctionSortedReft (RR (FFunc _ _) _) + = True +isFunctionSortedReft _ + = False + +sortedReftValueVariable (RR _ (Reft (v,_))) = v + +--------------------------------------------------------------- +----------------- Environments ------------------------------- +--------------------------------------------------------------- + +toListSEnv :: SEnv a -> [(Symbol, a)] +toListSEnv (SE env) = M.toList env +fromListSEnv :: [(Symbol, a)] -> SEnv a +fromListSEnv = SE . M.fromList +mapSEnv f (SE env) = SE (fmap f env) +deleteSEnv x (SE env) = SE (M.delete x env) +insertSEnv x y (SE env) = SE (M.insert x y env) +lookupSEnv x (SE env) = M.lookup x env +emptySEnv = SE M.empty +memberSEnv x (SE env) = M.member x env +intersectWithSEnv f (SE m1) (SE m2) = SE (M.intersectionWith f m1 m2) +filterSEnv f (SE m) = SE (M.filter f m) +lookupSEnvWithDistance x (SE env) + = case M.lookup x env of + Just x -> Found x + Nothing -> Alts $ stringSymbol <$> alts + where alts = takeMin $ (zip (editDistance x' <$> ss) ss) + ss = symbolString <$> fst <$> M.toList env + x' = symbolString x + takeMin = \xs -> [x | (d, x) <- xs, d == getMin xs] + getMin = minimum . (fst <$>) + +data SESearch a = Found a | Alts [Symbol] + +-- | Functions for Indexed Bind Environment + +emptyIBindEnv :: IBindEnv +emptyIBindEnv = FB (S.empty) + +deleteIBindEnv :: BindId -> IBindEnv -> IBindEnv +deleteIBindEnv i (FB s) = FB (S.delete i s) + +insertsIBindEnv :: [BindId] -> IBindEnv -> IBindEnv +insertsIBindEnv is (FB s) = FB (foldr S.insert s is) + +-- | Functions for Global Binder Environment +insertBindEnv :: Symbol -> SortedReft -> BindEnv -> (BindId, BindEnv) +insertBindEnv x r (BE n m) = (n, BE (n + 1) (M.insert n (x, r) m)) + +emptyBindEnv :: BindEnv +emptyBindEnv = BE 0 M.empty + + +instance Functor SEnv where + fmap f (SE m) = SE $ fmap f m + +instance Fixpoint Refa where + toFix (RConc p) = toFix p + toFix (RKvar k su) = toFix k <> toFix su + -- toFix (RPvar p) = toFix p + +instance Fixpoint Reft where + toFix = ppr_reft_pred + +instance Fixpoint SortedReft where + toFix (RR so (Reft (v, ras))) + = braces + $ (toFix v) <+> (text ":") <+> (toFix so) <+> (text "|") <+> toFix ras + +instance Fixpoint FEnv where + toFix (SE m) = toFix (hashMapToAscList m) + +instance Fixpoint BindEnv where + toFix (BE _ m) = vcat $ map toFix_bind $ hashMapToAscList m + +toFix_bind (i, (x, r)) = text "bind" <+> toFix i <+> toFix x <+> text ":" <+> toFix r + +insertFEnv = insertSEnv . lower + where lower x@(S (c:chs)) + | isUpper c = S $ toLower c : chs + | otherwise = x + lower z = z + +instance (Fixpoint a) => Fixpoint (SEnv a) where + toFix (SE e) = vcat $ map pprxt $ hashMapToAscList e + where pprxt (x, t) = toFix x <+> colon <> colon <+> toFix t + +instance Fixpoint (SEnv a) => Show (SEnv a) where + show = render . toFix + +----------------------------------------------------------------------------- +------------------- Constraints --------------------------------------------- +----------------------------------------------------------------------------- + +{-@ type Tag = { v : [Int] | len(v) = 1 } @-} +type Tag = [Int] + +type BindId = Int +type FEnv = SEnv SortedReft + +newtype IBindEnv = FB (S.HashSet BindId) +newtype SEnv a = SE { se_binds :: M.HashMap Symbol a } deriving (Eq, Data, Typeable) +data BindEnv = BE { be_size :: Int + , be_binds :: M.HashMap BindId (Symbol, SortedReft) + } + + +data SubC a = SubC { senv :: !IBindEnv + , sgrd :: !Pred + , slhs :: !SortedReft + , srhs :: !SortedReft + , sid :: !(Maybe Integer) + , stag :: !Tag + , sinfo :: !a + } + +data WfC a = WfC { wenv :: !IBindEnv + , wrft :: !SortedReft + , wid :: !(Maybe Integer) + , winfo :: !a + } -- deriving (Eq) + +data FixResult a = Crash [a] String + | Safe + | Unsafe ![a] + | UnknownError !Doc + deriving (Show) + +type FixSolution = M.HashMap Symbol Pred + +instance Eq a => Eq (FixResult a) where + Crash xs _ == Crash ys _ = xs == ys + Unsafe xs == Unsafe ys = xs == ys + Safe == Safe = True + _ == _ = False + +instance Monoid (FixResult a) where + mempty = Safe + mappend Safe x = x + mappend x Safe = x + mappend _ c@(Crash _ _) = c + mappend c@(Crash _ _) _ = c + mappend (Unsafe xs) (Unsafe ys) = Unsafe (xs ++ ys) + mappend u@(UnknownError _) _ = u + mappend _ u@(UnknownError _) = u + +instance Functor FixResult where + fmap f (Crash xs msg) = Crash (f <$> xs) msg + fmap f (Unsafe xs) = Unsafe (f <$> xs) + fmap _ Safe = Safe + fmap _ (UnknownError d) = UnknownError d + +instance (Ord a, Fixpoint a) => Fixpoint (FixResult (SubC a)) where + toFix Safe = text "Safe" + toFix (UnknownError d) = text "Unknown Error!" <+> d + toFix (Crash xs msg) = vcat $ [ text "Crash!" ] ++ ppr_sinfos "CRASH: " xs ++ [parens (text msg)] + toFix (Unsafe xs) = vcat $ text "Unsafe:" : ppr_sinfos "WARNING: " xs + +ppr_sinfos :: (Ord a, Fixpoint a) => String -> [SubC a] -> [Doc] +ppr_sinfos msg = map ((text msg <>) . toFix) . sort . fmap sinfo + + +resultDoc :: (Ord a, Fixpoint a) => FixResult a -> Doc +resultDoc Safe = text "Safe" +resultDoc (UnknownError d) = text "Unknown Error!" <+> d +resultDoc (Crash xs msg) = vcat $ (text ("Crash!: " ++ msg)) : (((text "CRASH:" <+>) . toFix) <$> xs) +resultDoc (Unsafe xs) = vcat $ (text "Unsafe:") : (((text "WARNING:" <+>) . toFix) <$> xs) + + + + + +colorResult (Safe) = Happy +colorResult (Unsafe _) = Angry +colorResult (_) = Sad + + +instance Show (SubC a) where + show = showFix + +instance Fixpoint (IBindEnv) where + toFix (FB ids) = text "env" <+> toFix ids + +instance Fixpoint (SubC a) where + toFix c = hang (text "\n\nconstraint:") 2 bd + where bd = -- text "env" <+> toFix (senv c) + toFix (senv c) + $+$ text "grd" <+> toFix (sgrd c) + $+$ text "lhs" <+> toFix (slhs c) + $+$ text "rhs" <+> toFix (srhs c) + $+$ (pprId (sid c) <+> pprTag (stag c)) + +instance Fixpoint (WfC a) where + toFix w = hang (text "\n\nwf:") 2 bd + where bd = -- text "env" <+> toFix (wenv w) + toFix (wenv w) + $+$ text "reft" <+> toFix (wrft w) + $+$ pprId (wid w) + +pprId (Just i) = text "id" <+> tshow i +pprId _ = text "" + +pprTag [] = text "" +pprTag is = text "tag" <+> toFix is + +instance Fixpoint Int where + toFix = tshow + +------------------------------------------------------- +------------------- Substitutions --------------------- +------------------------------------------------------- + +class Subable a where + syms :: a -> [Symbol] + substa :: (Symbol -> Symbol) -> a -> a + -- substa f = substf (EVar . f) + + substf :: (Symbol -> Expr) -> a -> a + subst :: Subst -> a -> a + subst1 :: a -> (Symbol, Expr) -> a + -- subst1 y (x, e) = subst (Su $ M.singleton x e) y + subst1 y (x, e) = subst (Su [(x,e)]) y + +subst1Except :: (Subable a) => [Symbol] -> a -> (Symbol, Expr) -> a +subst1Except xs z su@(x, _) + | x `elem` xs = z + | otherwise = subst1 z su + +substfExcept :: (Symbol -> Expr) -> [Symbol] -> (Symbol -> Expr) +substfExcept f xs y = if y `elem` xs then EVar y else f y + +substExcept :: Subst -> [Symbol] -> Subst +-- substExcept (Su m) xs = Su (foldr M.delete m xs) +substExcept (Su xes) xs = Su $ filter (not . (`elem` xs) . fst) xes + +instance Subable Symbol where + substa f x = f x + substf f x = subSymbol (Just (f x)) x + subst su x = subSymbol (Just $ appSubst su x) x -- subSymbol (M.lookup x s) x + syms x = [x] + +subSymbol (Just (EVar y)) _ = y +subSymbol Nothing x = x +subSymbol a b = errorstar (printf "Cannot substitute symbol %s with expression %s" (showFix b) (showFix a)) + +instance Subable Expr where + syms = exprSymbols + substa f = substf (EVar . f) + substf f (EApp s es) = EApp (substf f s) $ map (substf f) es + substf f (EBin op e1 e2) = EBin op (substf f e1) (substf f e2) + substf f (EIte p e1 e2) = EIte (substf f p) (substf f e1) (substf f e2) + substf f (ECst e so) = ECst (substf f e) so + substf f e@(EVar x) = f x + substf _ e = e + + subst su (EApp f es) = EApp (subst su f) $ map (subst su) es + subst su (EBin op e1 e2) = EBin op (subst su e1) (subst su e2) + subst su (EIte p e1 e2) = EIte (subst su p) (subst su e1) (subst su e2) + subst su (ECst e so) = ECst (subst su e) so + subst su (EVar x) = appSubst su x + subst _ e = e + + +instance Subable Pred where + syms = predSymbols + substa f = substf (EVar . f) + substf f (PAnd ps) = PAnd $ map (substf f) ps + substf f (POr ps) = POr $ map (substf f) ps + substf f (PNot p) = PNot $ substf f p + substf f (PImp p1 p2) = PImp (substf f p1) (substf f p2) + substf f (PIff p1 p2) = PIff (substf f p1) (substf f p2) + substf f (PBexp e) = PBexp $ substf f e + substf f (PAtom r e1 e2) = PAtom r (substf f e1) (substf f e2) + substf _ (PAll _ _) = errorstar $ "substf: FORALL" + substf _ p = p + + subst su (PAnd ps) = PAnd $ map (subst su) ps + subst su (POr ps) = POr $ map (subst su) ps + subst su (PNot p) = PNot $ subst su p + subst su (PImp p1 p2) = PImp (subst su p1) (subst su p2) + subst su (PIff p1 p2) = PIff (subst su p1) (subst su p2) + subst su (PBexp e) = PBexp $ subst su e + subst su (PAtom r e1 e2) = PAtom r (subst su e1) (subst su e2) + subst _ (PAll _ _) = errorstar $ "subst: FORALL" + subst _ p = p + +instance Subable Refa where + syms (RConc p) = syms p + syms (RKvar k (Su su')) = k : concatMap syms ({- M.elems -} su') + subst su (RConc p) = RConc $ subst su p + subst su (RKvar k su') = RKvar k $ su' `catSubst` su + -- subst _ (RPvar p) = RPvar p + substa f = substf (EVar . f) + substf f (RConc p) = RConc (substf f p) + substf _ ra@(RKvar _ _) = ra + +instance (Subable a, Subable b) => Subable (a,b) where + syms (x, y) = syms x ++ syms y + subst su (x,y) = (subst su x, subst su y) + substf f (x,y) = (substf f x, substf f y) + substa f (x,y) = (substa f x, substa f y) + +instance Subable a => Subable [a] where + syms = concatMap syms + subst = map . subst + substf = map . substf + substa = map . substa + +instance Subable a => Subable (M.HashMap k a) where + syms = syms . M.elems + subst = M.map . subst + substf = M.map . substf + substa = M.map . substa + +instance Subable Reft where + syms (Reft (v, ras)) = v : syms ras + substa f (Reft (v, ras)) = Reft (f v, substa f ras) + subst su (Reft (v, ras)) = Reft (v, subst (substExcept su [v]) ras) + substf f (Reft (v, ras)) = Reft (v, substf (substfExcept f [v]) ras) + subst1 (Reft (v, ras)) su = Reft (v, subst1Except [v] ras su) + + +instance Subable SortedReft where + syms = syms . sr_reft + subst su (RR so r) = RR so $ subst su r + substf f (RR so r) = RR so $ substf f r + substa f (RR so r) = RR so $ substa f r + + +-- newtype Subst = Su (M.HashMap Symbol Expr) deriving (Eq) +newtype Subst = Su [(Symbol, Expr)] deriving (Eq, Ord, Data, Typeable) + +mkSubst = Su -- . M.fromList +appSubst (Su s) x = fromMaybe (EVar x) (lookup x s) +emptySubst = Su [] -- M.empty +catSubst (Su s1) (Su s2) = Su $ s1' ++ s2 + where s1' = mapSnd (subst (Su s2)) <$> s1 + -- = Su $ s1' `M.union` s2 + -- where s1' = subst (Su s2) `M.map` s1 + +instance Monoid Subst where + mempty = emptySubst + mappend = catSubst + +------------------------------------------------------------ +------------- Generally Useful Refinements ----------------- +------------------------------------------------------------ + +symbolReft = exprReft . eVar + +vv_ = vv Nothing + +trueSortedReft :: Sort -> SortedReft +trueSortedReft = (`RR` trueReft) + +trueReft = Reft (vv_, []) +falseReft = Reft (vv_, [RConc PFalse]) + +trueRefa = RConc PTrue + +flattenRefas :: [Refa] -> [Refa] +flattenRefas = concatMap flatRa + where + flatRa (RConc p) = RConc <$> flatP p + flatRa ra = [ra] + flatP (PAnd ps) = concatMap flatP ps + flatP p = [p] + +squishRefas :: [Refa] -> [Refa] +squishRefas ras = (squish [p | RConc p <- ras]) : [] + where + squish = RConc . pAnd . sortNub . filter (not . isTautoPred) . concatMap conjuncts + +conjuncts (PAnd ps) = concatMap conjuncts ps +conjuncts p | isTautoPred p = [] + | otherwise = [p] +---------------------------------------------------------------- +---------------------- Strictness ------------------------------ +---------------------------------------------------------------- + +instance NFData Symbol where + rnf (S x) = rnf x + +instance NFData FTycon where + rnf (TC c) = rnf c + +instance NFData Sort where + rnf (FVar x) = rnf x + rnf (FFunc n ts) = rnf n `seq` (rnf <$> ts) `seq` () + rnf (FApp c ts) = rnf c `seq` (rnf <$> ts) `seq` () + rnf (z) = z `seq` () + +instance NFData Sub where + rnf (Sub x) = rnf x + +instance NFData Subst where + rnf (Su x) = rnf x + +instance NFData FEnv where + rnf (SE x) = rnf x + +instance NFData IBindEnv where + rnf (FB x) = rnf x + +instance NFData BindEnv where + rnf (BE x m) = rnf x `seq` rnf m + +instance NFData Constant where + rnf (I x) = rnf x + +instance NFData SymConst where + rnf (SL x) = rnf x + +instance NFData Brel +instance NFData Bop + +instance NFData Expr where + rnf (ESym x) = rnf x + rnf (ECon x) = rnf x + rnf (EVar x) = rnf x + -- rnf (EDat x1 x2) = rnf x1 `seq` rnf x2 + rnf (ELit x1 x2) = rnf x1 `seq` rnf x2 + rnf (EApp x1 x2) = rnf x1 `seq` rnf x2 + rnf (EBin x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 + rnf (EIte x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 + rnf (ECst x1 x2) = rnf x1 `seq` rnf x2 + rnf (_) = () + +instance NFData Pred where + rnf (PAnd x) = rnf x + rnf (POr x) = rnf x + rnf (PNot x) = rnf x + rnf (PBexp x) = rnf x + rnf (PImp x1 x2) = rnf x1 `seq` rnf x2 + rnf (PIff x1 x2) = rnf x1 `seq` rnf x2 + rnf (PAll x1 x2) = rnf x1 `seq` rnf x2 + rnf (PAtom x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 + rnf (_) = () + +instance NFData Refa where + rnf (RConc x) = rnf x + rnf (RKvar x1 x2) = rnf x1 `seq` rnf x2 + -- rnf (RPvar _) = () -- rnf x + +instance NFData Reft where + rnf (Reft (v, ras)) = rnf v `seq` rnf ras + +instance NFData SortedReft where + rnf (RR so r) = rnf so `seq` rnf r + +instance (NFData a) => NFData (SubC a) where + rnf (SubC x1 x2 x3 x4 x5 x6 x7) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 + +instance (NFData a) => NFData (WfC a) where + rnf (WfC x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 + +---------------------------------------------------------------------------- +-------------- Hashable Instances ----------------------------------------- +--------------------------------------------------------------------------- + +instance Hashable Symbol where + hashWithSalt i (S s) = hashWithSalt i s + +instance Hashable FTycon where + hashWithSalt i (TC s) = hashWithSalt i s + +--------------------------------------------------------------------------- +-------- Constraint Constructor Wrappers ---------------------------------- +--------------------------------------------------------------------------- + +wfC = WfC + +-- subC γ p r1@(RR _ (Reft (v,_))) (RR t2 r2) x y z +-- = SubC γ p r1 (RR t2 (shiftVV r2 v)) x y z +subC γ p (RR t1 r1) (RR t2 r2) x y z + = SubC γ p (RR t1 (shiftVV r1 vvCon)) (RR t2 (shiftVV r2 vvCon)) x y z + +lhsCs = sr_reft . slhs +rhsCs = sr_reft . srhs + +removeLhsKvars cs vs + = cs{slhs = goRR (slhs cs)} + where goRR rr = rr{sr_reft = goReft (sr_reft rr)} + goReft (Reft(v, rs)) = Reft(v, filter f rs) + f (RKvar v _) | v `elem` vs = False + f r = True + +trueSubCKvar v + = subC emptyIBindEnv PTrue mempty (RR mempty (Reft(vv_, [RKvar v emptySubst]))) Nothing [0] + +shiftVV r@(Reft (v, ras)) v' + | v == v' = r + | otherwise = Reft (v', (subst1 ras (v, EVar v'))) + + +addIds = zipWith (\i c -> (i, shiftId i $ c {sid = Just i})) [1..] + where -- Adding shiftId to have distinct VV for SMT conversion + shiftId i c = c { slhs = shiftSR i $ slhs c } + { srhs = shiftSR i $ srhs c } + shiftSR i sr = sr { sr_reft = shiftR i $ sr_reft sr } + shiftR i r@(Reft (S v, _)) = shiftVV r (S (v ++ show i)) + + +-- subC γ p r1 r2 x y z = (vvsu, SubC γ p r1' r2' x y z) +-- where (vvsu, r1', r2') = unifySRefts r1 r2 + +-- unifySRefts (RR t1 r1) (RR t2 r2) = (z, RR t1 r1', RR t2 r2') +-- where (r1', r2') = unifyRefts r1 r2 + +-- unifyRefts r1@(Reft (v1, _)) r2@(Reft (v2, _)) +-- | v1 == v2 = (r1, r2) +-- | otherwise = (r1, shiftVV r2 v1) + +-- unifySRefts (RR t1 r1) (RR t2 r2) = (z, RR t1 r1', RR t2 r2') +-- where (z, r1', r2') = unifyRefts r1 r2 +-- +-- unifyRefts r1@(Reft (v1, _)) r2@(Reft (v2, _)) +-- | v1 == v2 = ((v1, emptySubst), r1, r2) +-- | v1 /= vv_ = let (su, r2') = shiftVV r2 v1 in ((v1, su), r1 , r2') +-- | otherwise = let (su, r1') = shiftVV r1 v2 in ((v2, su), r1', r2 ) +-- +-- shiftVV (Reft (v, ras)) v' = (su, (Reft (v', subst su ras))) +-- where su = mkSubst [(v, EVar v')] + + +------------------------------------------------------------------------ +----------------- Qualifiers ------------------------------------------- +------------------------------------------------------------------------ + + +data Qualifier = Q { q_name :: String -- ^ Name + , q_params :: [(Symbol, Sort)] -- ^ Parameters + , q_body :: Pred -- ^ Predicate + } + deriving (Eq, Ord, Show, Data, Typeable) + +instance Fixpoint Qualifier where + toFix = pprQual + +instance NFData Qualifier where + rnf (Q x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 + +pprQual (Q n xts p) = text "qualif" <+> text n <> parens args <> colon <+> toFix p + where args = intersperse comma (toFix <$> xts) + +data FInfo a = FI { cm :: M.HashMap Integer (SubC a) + , ws :: ![WfC a] + , bs :: !BindEnv + , gs :: !FEnv + , lits :: ![(Symbol, Sort)] + , kuts :: Kuts + , quals :: ![Qualifier] + } + +-- toFixs = brackets . hsep . punctuate comma -- . map toFix + +toFixpoint x' = kutsDoc x' $+$ gsDoc x' $+$ conDoc x' $+$ bindsDoc x' $+$ csDoc x' $+$ wsDoc x' + where conDoc = vcat . map toFix_constant . getLits + csDoc = vcat . map toFix . M.elems . cm + wsDoc = vcat . map toFix . ws + kutsDoc = toFix . kuts + bindsDoc = toFix . bs + gsDoc = toFix_gs . gs + +getLits x = lits x ++ symConstLits x + + +------------------------------------------------------------------------- +-- | A Class Predicates for Valid Refinements Types --------------------- +------------------------------------------------------------------------- + +class (Monoid r, Subable r) => Reftable r where + isTauto :: r -> Bool + ppTy :: r -> Doc -> Doc + + top :: r + top = mempty + + -- | should also refactor `top` so it takes a parameter. + bot :: r -> r + + meet :: r -> r -> r + meet = mappend + + toReft :: r -> Reft + params :: r -> [Symbol] -- ^ parameters for Reft, vv + others + +instance Monoid Pred where + mempty = PTrue + mappend p q = pAnd [p, q] + +instance Monoid Reft where + mempty = trueReft + mappend = meetReft + +meetReft r@(Reft (v, ras)) r'@(Reft (v', ras')) + | v == v' = Reft (v , ras ++ ras') + | v == dummySymbol = Reft (v', ras' ++ (ras `subst1` (v , EVar v'))) + | otherwise = Reft (v , ras ++ (ras' `subst1` (v', EVar v ))) + +instance Subable () where + syms _ = [] + subst _ () = () + substf _ () = () + substa _ () = () + +instance Reftable () where + isTauto _ = True + ppTy _ d = d + top = () + bot _ = () + meet _ _ = () + toReft _ = top + params _ = [] + +instance Reftable Reft where + isTauto = isTautoReft + ppTy = ppr_reft + toReft = id + params _ = [] + bot _ = falseReft + +instance Monoid Sort where + mempty = FObj (S "any") + mappend t1 t2 + | t1 == mempty = t2 + | t2 == mempty = t1 + | t1 == t2 = t1 + | otherwise = errorstar $ "mappend-sort: conflicting sorts t1 =" ++ show t1 ++ " t2 = " ++ show t2 + +instance Monoid SortedReft where + mempty = RR mempty mempty + mappend t1 t2 = RR (mappend (sr_sort t1) (sr_sort t2)) (mappend (sr_reft t1) (sr_reft t2)) + +instance Reftable SortedReft where + isTauto = isTauto . toReft + ppTy = ppTy . toReft + toReft = sr_reft + params _ = [] + bot s = s { sr_reft = falseReft } + +class Falseable a where + isFalse :: a -> Bool + +instance Falseable Pred where + isFalse (PFalse) = True + isFalse _ = False + +instance Falseable Refa where + isFalse (RConc p) = isFalse p + isFalse _ = False + +instance Falseable Reft where + isFalse (Reft(_, rs)) = or [isFalse p | RConc p <- rs] + +-- instance Expression a => Reftable a where +-- isTauto _ = isTauto . toReft +-- ppTy = ppTy . toReft +-- toReft = exprReft +-- params _ = [] + +-- instance Predicate a => Reftable a where +-- isTauto = isTauto . toReft +-- ppTy = ppTy . toReft +-- toReft = propReft +-- params _ = [] + + +--------------------------------------------------------------- +-- |String Constants ------------------------------------------ +--------------------------------------------------------------- + +symConstLits :: FInfo a -> [(Symbol, Sort)] +symConstLits fi = [(encodeSymConst c, sortSymConst c) | c <- symConsts fi] + +-- | Replace all symbol-representations-of-string-literals with string-literal +-- Used to transform parsed output from fixpoint back into fq. + + +encodeSymConst :: SymConst -> Symbol +encodeSymConst (SL s) = stringSymbol $ litPrefix ++ s + +sortSymConst :: SymConst -> Sort +sortSymConst (SL _) = strSort + +decodeSymConst :: Symbol -> Maybe SymConst +decodeSymConst = fmap SL . stripPrefix litPrefix . symbolString + +litPrefix :: String +litPrefix = "lit" ++ [symSepName] + +strSort :: Sort +strSort = FApp strFTyCon [] + +class SymConsts a where + symConsts :: a -> [SymConst] + +instance SymConsts (FInfo a) where + symConsts fi = sortNub $ csLits ++ bsLits ++ gsLits ++ qsLits + where + csLits = concatMap symConsts $ M.elems $ cm fi + bsLits = concatMap symConsts $ map snd $ M.elems $ be_binds $ bs fi + gsLits = concatMap symConsts $ M.elems $ se_binds $ gs fi + qsLits = concatMap symConsts $ q_body <$> quals fi + +instance SymConsts (SubC a) where + symConsts c = symConsts (sgrd c) ++ + symConsts (slhs c) ++ + symConsts (srhs c) + +instance SymConsts SortedReft where + symConsts = symConsts . sr_reft + +instance SymConsts Reft where + symConsts (Reft (_, ras)) = concatMap symConsts ras + +instance SymConsts Refa where + symConsts (RConc p) = symConsts p + symConsts (RKvar _ (Su xes)) = concatMap symConsts $ snd <$> xes + +instance SymConsts Expr where + symConsts (ESym c) = [c] + symConsts (EApp _ es) = concatMap symConsts es + symConsts (EBin _ e e') = concatMap symConsts [e, e'] + symConsts (EIte p e e') = symConsts p ++ concatMap symConsts [e, e'] + symConsts (ECst e _) = symConsts e + symConsts _ = [] + +instance SymConsts Pred where + symConsts (PNot p) = symConsts p + symConsts (PAnd ps) = concatMap symConsts ps + symConsts (POr ps) = concatMap symConsts ps + symConsts (PImp p q) = concatMap symConsts [p, q] + symConsts (PIff p q) = concatMap symConsts [p, q] + symConsts (PAll _ p) = symConsts p + symConsts (PBexp e) = symConsts e + symConsts (PAtom _ e e') = concatMap symConsts [e, e'] + symConsts _ = [] + +--------------------------------------------------------------- +-- | Edit Distance -------------------------------------------- +--------------------------------------------------------------- + + +editDistance :: Eq a => [a] -> [a] -> Int +editDistance xs ys = table ! (m,n) + where + (m,n) = (length xs, length ys) + x = array (1,m) (zip [1..] xs) + y = array (1,n) (zip [1..] ys) + + table :: Array (Int,Int) Int + table = array bnds [(ij, dist ij) | ij <- range bnds] + bnds = ((0,0),(m,n)) + + dist (0,j) = j + dist (i,0) = i + dist (i,j) = minimum [table ! (i-1,j) + 1, table ! (i,j-1) + 1, + if x ! i == y ! j then table ! (i-1,j-1) else 1 + table ! (i-1,j-1)]