diff options
Diffstat (limited to 'src/extraction')
| -rw-r--r-- | src/extraction/Extract.v | 26 | ||||
| -rw-r--r-- | src/extraction/Makefile | 47 | ||||
| -rw-r--r-- | src/extraction/extrNative.ml | 332 | ||||
| -rw-r--r-- | src/extraction/extrNative.mli | 67 | ||||
| -rw-r--r-- | src/extraction/sat_checker.ml | 431 | ||||
| -rw-r--r-- | src/extraction/sat_checker.mli | 169 | ||||
| -rw-r--r-- | src/extraction/smt_checker.ml | 6849 | ||||
| -rw-r--r-- | src/extraction/smt_checker.mli | 1889 | ||||
| -rw-r--r-- | src/extraction/test.ml | 42 | ||||
| -rw-r--r-- | src/extraction/verit_checker.ml | 324 | ||||
| -rw-r--r-- | src/extraction/zchaff_checker.ml | 103 |
11 files changed, 10279 insertions, 0 deletions
diff --git a/src/extraction/Extract.v b/src/extraction/Extract.v new file mode 100644 index 0000000..1161f48 --- /dev/null +++ b/src/extraction/Extract.v @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2015 *) +(* *) +(* Michaël Armand *) +(* Benjamin Grégoire *) +(* Chantal Keller *) +(* *) +(* Inria - École Polytechnique - MSR-Inria Joint Lab *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +Require Int63Native. +Require Import ExtractNative. +Require Import SMTCoq. + +Extract Constant Int63Native.eqb => "fun i j -> ExtrNative.compare i j = ExtrNative.Eq". + +Set Extraction AccessOpaque. + +Extraction "extraction/sat_checker.ml" Sat_Checker.checker. +Extraction "extraction/smt_checker.ml" Euf_Checker.checker_ext. diff --git a/src/extraction/Makefile b/src/extraction/Makefile new file mode 100644 index 0000000..07a30dd --- /dev/null +++ b/src/extraction/Makefile @@ -0,0 +1,47 @@ +# List of user's files and name of the final program (edit this part) + +USERFILES=test.ml +PROGRAM=test +# USERFILES=../../../../examples/example.ml +# PROGRAM=../../../../examples/example + + +# Compilation + +COQTOP=$(COQBIN)../ + +FLAGS=-rectypes +COMPILEFLAGS=-cclib -lunix + +SMTLIB=-I .. -I ../zchaff -I ../verit -I ../trace -I ../lia -I ../euf -I ../cnf +COQLIB=-I ${COQTOP}kernel -I ${COQTOP}lib -I ${COQTOP}library -I ${COQTOP}parsing -I ${COQTOP}pretyping -I ${COQTOP}interp -I ${COQTOP}proofs -I ${COQTOP}tactics -I ${COQTOP}toplevel -I ${COQTOP}plugins/btauto -I ${COQTOP}plugins/cc -I ${COQTOP}plugins/decl_mode -I ${COQTOP}plugins/extraction -I ${COQTOP}plugins/field -I ${COQTOP}plugins/firstorder -I ${COQTOP}plugins/fourier -I ${COQTOP}plugins/funind -I ${COQTOP}plugins/micromega -I ${COQTOP}plugins/nsatz -I ${COQTOP}plugins/omega -I ${COQTOP}plugins/quote -I ${COQTOP}plugins/ring -I ${COQTOP}plugins/romega -I ${COQTOP}plugins/rtauto -I ${COQTOP}plugins/setoid_ring -I ${COQTOP}plugins/syntax -I ${COQTOP}plugins/xml -I /usr/lib/ocaml/camlp5 + +CMXA=nums.cmxa str.cmxa unix.cmxa gramlib.cmxa dynlink.cmxa ${COQTOP}kernel/byterun/coq_fix_code.o ${COQTOP}kernel/byterun/coq_interp.o ${COQTOP}kernel/byterun/coq_memory.o ${COQTOP}kernel/byterun/coq_values.o clib.cmxa lib.cmxa kernel.cmxa library.cmxa pretyping.cmxa interp.cmxa proofs.cmxa parsing.cmxa tactics.cmxa toplevel.cmxa micromega_plugin.cmxa smtcoq.cmxa +CMI=extrNative.cmi sat_checker.cmi smt_checker.cmi +CMX=extrNative.cmx sat_checker.cmx zchaff_checker.cmx smt_checker.cmx verit_checker.cmx +USERCMX=$(USERFILES:.ml=.cmx) + +OCAMLC=ocamlc +OCAMLOPT=ocamlopt + + +all: $(PROGRAM) + +%.cmi: %.mli + $(OCAMLC) -c $(FLAGS) $(SMTLIB) $(COQLIB) $< + +%.cmx: %.ml + $(OCAMLOPT) -c $(FLAGS) $(SMTLIB) $(COQLIB) $< + +$(PROGRAM): $(CMI) $(CMX) $(USERCMX) + $(OCAMLOPT) $(FLAGS) $(SMTLIB) $(COQLIB) -o $@ $(COMPILEFLAGS) $(CMXA) $(CMX) $(USERCMX) + + +.PHONY: clean mrproper + + +clean: + rm -f *.cmi *.cmx *.o + +mrproper: clean + rm -rf $(PROGRAM) diff --git a/src/extraction/extrNative.ml b/src/extraction/extrNative.ml new file mode 100644 index 0000000..4d56287 --- /dev/null +++ b/src/extraction/extrNative.ml @@ -0,0 +1,332 @@ +type comparison = Eq | Lt | Gt + +type 'a carry = C0 of 'a | C1 of 'a + +type uint = int + + (* to be used only on 32 bits achitectures *) +let maxuint31 = Int32.of_string "0x7FFFFFFF" +let uint_32 i = Int32.logand (Int32.of_int i) maxuint31 + +let select f32 f64 = if Sys.word_size = 64 then f64 else f32 + + (* conversion to an int *) +let to_int i = i + +let of_int_32 i = i +let of_int_64 i = i land 0x7FFFFFFF + +let of_int = select of_int_32 of_int_64 +let of_uint i = i + + (* convertion of an uint31 to a string *) +let to_string_32 i = Int32.to_string (uint_32 i) +let to_string_64 = string_of_int + +let to_string = select to_string_32 to_string_64 +let of_string s = + let i32 = Int32.of_string s in + if Int32.compare Int32.zero i32 <= 0 + && Int32.compare i32 maxuint31 <= 0 + then Int32.to_int i32 + else raise (Failure "int_of_string") + + + + (* logical shift *) +let l_sl x y = + of_int (if 0 <= y && y < 31 then x lsl y else 0) + +let l_sr x y = + if 0 <= y && y < 31 then x lsr y else 0 + +let l_and x y = x land y +let l_or x y = x lor y +let l_xor x y = x lxor y + + (* addition of int31 *) +let add x y = of_int (x + y) + + (* subtraction *) +let sub x y = of_int (x - y) + + (* multiplication *) +let mul x y = of_int (x * y) + + (* exact multiplication *) +let mulc_32 x y = + let x = Int64.of_int32 (uint_32 x) in + let y = Int64.of_int32 (uint_32 y) in + let m = Int64.mul x y in + let l = Int64.to_int m in + let h = Int64.to_int (Int64.shift_right_logical m 31) in + h,l + +let mulc_64 x y = + let m = x * y in + let l = of_int_64 m in + let h = of_int_64 (m lsr 31) in + h, l +let mulc = select mulc_32 mulc_64 + + (* division *) +let div_32 x y = + if y = 0 then 0 else + Int32.to_int (Int32.div (uint_32 x) (uint_32 y)) +let div_64 x y = if y = 0 then 0 else x / y +let div = select div_32 div_64 + + (* modulo *) +let rem_32 x y = + if y = 0 then 0 + else Int32.to_int (Int32.rem (uint_32 x) (uint_32 y)) +let rem_64 x y = if y = 0 then 0 else x mod y +let rem = select rem_32 rem_64 + + (* division of two numbers by one *) +let div21_32 xh xl y = + if y = 0 then (0,0) + else + let x = + Int64.logor + (Int64.shift_left (Int64.of_int32 (uint_32 xh)) 31) + (Int64.of_int32 (uint_32 xl)) in + let y = Int64.of_int32 (uint_32 y) in + let q = Int64.div x y in + let r = Int64.rem x y in + Int64.to_int q, Int64.to_int r +let div21_64 xh xl y = + if y = 0 then (0,0) + else + let x = (xh lsl 31) lor xl in + let q = x / y in + let r = x mod y in + q, r +let div21 = select div21_32 div21_64 + + (* comparison *) +let lt_32 x y = (x lxor 0x40000000) < (y lxor 0x40000000) +(* if 0 <= x then + if 0 <= y then x < y + else true + else if 0 <= y then false + else x < y *) +(* Int32.compare (uint_32 x) (uint_32 y) < 0 *) + +let lt_64 x y = x < y +let lt = select lt_32 lt_64 + +let le_32 x y = + (x lxor 0x40000000) <= (y lxor 0x40000000) +(* + if 0 <= x then + if 0 <= y then x <= y + else true + else if 0 <= y then false + else x <= y +*) +(*Int32.compare (uint_32 x) (uint_32 y) <= 0*) +let le_64 x y = x <= y +let le = select le_32 le_64 + +let eq x y = x == y + +let cmp_32 x y = Int32.compare (uint_32 x) (uint_32 y) +let cmp_64 x y = compare x y +let compare = select cmp_32 cmp_64 + +let compare x y = + match compare x y with + | x when x < 0 -> Lt + | 0 -> Eq + | _ -> Gt + + (* head tail *) + +let head0 x = + let r = ref 0 in + let x = ref x in + if !x land 0x7FFF0000 = 0 then r := !r + 15 + else x := !x lsr 15; + if !x land 0xFF00 = 0 then (x := !x lsl 8; r := !r + 8); + if !x land 0xF000 = 0 then (x := !x lsl 4; r := !r + 4); + if !x land 0xC000 = 0 then (x := !x lsl 2; r := !r + 2); + if !x land 0x8000 = 0 then (x := !x lsl 1; r := !r + 1); + if !x land 0x8000 = 0 then ( r := !r + 1); + !r;; + +let tail0 x = + let r = ref 0 in + let x = ref x in + if !x land 0xFFFF = 0 then (x := !x lsr 16; r := !r + 16); + if !x land 0xFF = 0 then (x := !x lsr 8; r := !r + 8); + if !x land 0xF = 0 then (x := !x lsr 4; r := !r + 4); + if !x land 0x3 = 0 then (x := !x lsr 2; r := !r + 2); + if !x land 0x1 = 0 then ( r := !r + 1); + !r + +let addc x y = + let s = add x y in + if lt s x then C1 s else C0 s + +let addcarryc x y = + let s = add (x+1) y in + if le s x then C1 s else C0 s + +let subc x y = + let s = sub x y in + if lt x y then C1 s else C0 s + +let subcarryc x y = + let s = sub (x-1) y in + if le x y then C1 s else C0 s + +let diveucl x y = div x y, rem x y + +let diveucl_21 = div21 + +let addmuldiv p i j = + let p' = to_int p in + of_uint (l_or + (l_sl i p) + (l_sr j (of_int (31 - p')))) + +let rec foldi_cont f min max cont a = + if lt min max then f min (foldi_cont f (add min 1) max cont) a + else if min = max then f min cont a + else cont a + +let rec foldi_down_cont f max min cont a = + if lt min max then + f max (foldi_down_cont f (sub max 1) min cont) a + else if min = max then f min cont a + else cont a + +let print_uint x = + Printf.fprintf stderr "%s" (to_string x); + flush stderr; + x + +(* Les Tableaux maintenant *) + +let max_array_length32 = 4194303 (* Sys.max_array_length on arch32 *) + +type 'a parray = ('a kind) ref +and 'a kind = + | Array of 'a array + (* | Matrix of 'a array array *) + | Updated of int * 'a * 'a parray + +let of_array t = ref (Array t) + +let parray_make n def = + let n = to_int n in + let n = + if 0 <= n && n < max_array_length32 then n + 1 + else max_array_length32 in + ref (Array (Array.make n def)) + +let rec get_updated p n = + match !p with + | Array t -> + let l = Array.length t in + if 0 <= n && n < l then Array.unsafe_get t n + else (Array.unsafe_get t (l-1)) + | Updated (k,e,p) -> if n = k then e else get_updated p n + +let parray_get p n = + let n = to_int n in + match !p with + | Array t -> + let l = Array.length t in + if 0 <= n && n < l then Array.unsafe_get t n + else (Array.unsafe_get t (l-1)) + | Updated _ -> get_updated p n + + +let rec default_updated p = + match !p with + | Array t -> Array.unsafe_get t (Array.length t - 1) + | Updated (_,_,p) -> default_updated p + +let parray_default p = + match !p with + | Array t -> Array.unsafe_get t (Array.length t - 1) + | Updated (_,_,p) -> default_updated p + +let rec length p = + match !p with + | Array t -> of_int (Array.length t - 1) (* The default value *) + | Updated (_, _, p) -> length p + +let parray_length p = + match !p with + | Array t -> of_int (Array.length t - 1) + | Updated (_, _, p) -> length p + +let parray_set p n e = + let kind = !p in + let n = to_int n in + match kind with + | Array t -> + if 0 <= n && n < Array.length t - 1 then + let res = ref kind in + p := Updated (n, Array.unsafe_get t n, res); + Array.unsafe_set t n e; + res + else p + | Updated _ -> + if 0 <= n && n < to_int (parray_length p) then + ref (Updated(n, e, p)) + else p + + +let rec copy_updated p = + match !p with + | Array t -> Array.copy t + | Updated (n,e,p) -> + let t = copy_updated p in + Array.unsafe_set t n e; t + +let parray_copy p = + let t = + match !p with + | Array t -> Array.copy t + | Updated _ -> copy_updated p in + ref (Array t) + +let rec rerootk t k = + match !t with + | Array _ -> k () + | Updated (i, v, t') -> + let k' () = + begin match !t' with + | Array a as n -> + let v' = a.(i) in + a.(i) <- v; + t := n; + t' := Updated (i, v', t) + | Updated _ -> assert false + end; k() in + rerootk t' k' + +let parray_reroot t = rerootk t (fun () -> t) + +let parray_init n f def = + let n = to_int n in + let n = + if 0 <= n && n < max_array_length32 then n + 1 + else max_array_length32 in + let t = Array.make n def in + for i = 0 to n - 2 do Array.unsafe_set t i (f i) done; + ref (Array t) + +let parray_map f p = + match !p with + | Array t -> ref (Array (Array.map f t)) + | _ -> + let len = to_int (length p) in + ref (Array + (Array.init (len + 1) + (fun i -> f (parray_get p (of_int i))))) + diff --git a/src/extraction/extrNative.mli b/src/extraction/extrNative.mli new file mode 100644 index 0000000..14eff5f --- /dev/null +++ b/src/extraction/extrNative.mli @@ -0,0 +1,67 @@ +type comparison = Eq | Lt | Gt +type 'a carry = C0 of 'a | C1 of 'a + +(*s Unsigned Int *) +type uint + +(* Conversion with int *) +val to_int : uint -> int +val of_int : int -> uint +val of_uint : int -> uint + +(* Conversion with string *) +val to_string : uint -> string +val of_string : string -> uint + +(* logical operations *) +val l_sl : uint -> uint -> uint +val l_sr : uint -> uint -> uint +val l_and : uint -> uint -> uint +val l_or : uint -> uint -> uint +val l_xor : uint -> uint -> uint + +(* arithmetic operations *) +val add : uint -> uint -> uint +val sub : uint -> uint -> uint +val mul : uint -> uint -> uint +val mulc : uint -> uint -> uint * uint +val div : uint -> uint -> uint +val rem : uint -> uint -> uint + +val lt : uint -> uint -> bool +val le : uint -> uint -> bool +val eq : uint -> uint -> bool +val compare : uint -> uint -> comparison + +val head0 : uint -> uint +val tail0 : uint -> uint + +val addc : uint -> uint -> uint carry +val addcarryc : uint -> uint -> uint carry +val subc : uint -> uint -> uint carry +val subcarryc : uint -> uint -> uint carry +val diveucl : uint -> uint -> uint * uint +val diveucl_21 : uint -> uint -> uint -> uint * uint +val addmuldiv : uint -> uint -> uint -> uint + +val foldi_cont : + (uint -> ('a -> 'b) -> 'a -> 'b) -> uint -> uint -> ('a -> 'b) -> 'a -> 'b +val foldi_down_cont : + (uint -> ('a -> 'b) -> 'a -> 'b) -> uint -> uint -> ('a -> 'b) -> 'a -> 'b +val print_uint : uint -> uint + + +(*s Persistant array *) + +type 'a parray + +val of_array : 'a array -> 'a parray + +val parray_make : uint -> 'a -> 'a parray +val parray_get : 'a parray -> uint -> 'a +val parray_default : 'a parray -> 'a +val parray_length : 'a parray -> uint +val parray_set : 'a parray -> uint -> 'a -> 'a parray +val parray_copy : 'a parray -> 'a parray +val parray_reroot : 'a parray -> 'a parray + diff --git a/src/extraction/sat_checker.ml b/src/extraction/sat_checker.ml new file mode 100644 index 0000000..59635e0 --- /dev/null +++ b/src/extraction/sat_checker.ml @@ -0,0 +1,431 @@ +(** val negb : bool -> bool **) + +let negb = function +| true -> false +| false -> true + +type 'a list = +| Nil +| Cons of 'a * 'a list + +(** val existsb : ('a1 -> bool) -> 'a1 list -> bool **) + +let rec existsb f = function +| Nil -> false +| Cons (a, l0) -> if f a then true else existsb f l0 + +type int = ExtrNative.uint + +(** val lsl0 : int -> int -> int **) + +let lsl0 = ExtrNative.l_sl + +(** val lsr0 : int -> int -> int **) + +let lsr0 = ExtrNative.l_sr + +(** val land0 : int -> int -> int **) + +let land0 = ExtrNative.l_and + +(** val lxor0 : int -> int -> int **) + +let lxor0 = ExtrNative.l_xor + +(** val sub : int -> int -> int **) + +let sub = ExtrNative.sub + +(** val eqb : int -> int -> bool **) + +let eqb = fun i j -> ExtrNative.compare i j = ExtrNative.Eq + +(** val foldi_cont : + (int -> ('a1 -> 'a2) -> 'a1 -> 'a2) -> int -> int -> ('a1 -> 'a2) -> 'a1 + -> 'a2 **) + +let foldi_cont = ExtrNative.foldi_cont + +(** val foldi_down_cont : + (int -> ('a1 -> 'a2) -> 'a1 -> 'a2) -> int -> int -> ('a1 -> 'a2) -> 'a1 + -> 'a2 **) + +let foldi_down_cont = ExtrNative.foldi_down_cont + +(** val is_zero : int -> bool **) + +let is_zero i = + eqb i (ExtrNative.of_uint(0)) + +(** val is_even : int -> bool **) + +let is_even i = + is_zero (land0 i (ExtrNative.of_uint(1))) + +(** val compare : int -> int -> ExtrNative.comparison **) + +let compare = ExtrNative.compare + +(** val foldi : (int -> 'a1 -> 'a1) -> int -> int -> 'a1 -> 'a1 **) + +let foldi f from to0 = + foldi_cont (fun i cont a -> cont (f i a)) from to0 (fun a -> a) + +(** val foldi_down : (int -> 'a1 -> 'a1) -> int -> int -> 'a1 -> 'a1 **) + +let foldi_down f from downto0 = + foldi_down_cont (fun i cont a -> cont (f i a)) from downto0 (fun a -> a) + +type 'a array = 'a ExtrNative.parray + +(** val make : int -> 'a1 -> 'a1 array **) + +let make = ExtrNative.parray_make + +module Coq__1 = struct + (** val get : 'a1 array -> int -> 'a1 **) + + let get = ExtrNative.parray_get +end +let get = Coq__1.get + +(** val set : 'a1 array -> int -> 'a1 -> 'a1 array **) + +let set = ExtrNative.parray_set + +(** val length : 'a1 array -> int **) + +let length = ExtrNative.parray_length + +(** val to_list : 'a1 array -> 'a1 list **) + +let to_list t0 = + let len = length t0 in + if eqb (ExtrNative.of_uint(0)) len + then Nil + else foldi_down (fun i l -> Cons ((get t0 i), l)) + (sub len (ExtrNative.of_uint(1))) (ExtrNative.of_uint(0)) Nil + +(** val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a1 -> 'a2 array -> 'a1 **) + +let fold_left f a t0 = + let len = length t0 in + if eqb (ExtrNative.of_uint(0)) len + then a + else foldi (fun i a0 -> f a0 (get t0 i)) (ExtrNative.of_uint(0)) + (sub (length t0) (ExtrNative.of_uint(1))) a + +(** val foldi_right : + (int -> 'a1 -> 'a2 -> 'a2) -> 'a1 array -> 'a2 -> 'a2 **) + +let foldi_right f t0 b = + let len = length t0 in + if eqb (ExtrNative.of_uint(0)) len + then b + else foldi_down (fun i b0 -> f i (get t0 i) b0) + (sub len (ExtrNative.of_uint(1))) (ExtrNative.of_uint(0)) b + +module Valuation = + struct + type t = int -> bool + end + +module Var = + struct + (** val _true : int **) + + let _true = + (ExtrNative.of_uint(0)) + + (** val _false : int **) + + let _false = + (ExtrNative.of_uint(1)) + + (** val interp : Valuation.t -> int -> bool **) + + let interp rho x = + rho x + end + +module Lit = + struct + (** val is_pos : int -> bool **) + + let is_pos l = + is_even l + + (** val blit : int -> int **) + + let blit l = + lsr0 l (ExtrNative.of_uint(1)) + + (** val lit : int -> int **) + + let lit x = + lsl0 x (ExtrNative.of_uint(1)) + + (** val neg : int -> int **) + + let neg l = + lxor0 l (ExtrNative.of_uint(1)) + + (** val nlit : int -> int **) + + let nlit x = + neg (lit x) + + (** val _true : int **) + + let _true = + (ExtrNative.of_uint(0)) + + (** val _false : int **) + + let _false = + (ExtrNative.of_uint(2)) + + (** val eqb : int -> int -> bool **) + + let eqb l l' = + eqb l l' + + (** val interp : Valuation.t -> int -> bool **) + + let interp rho l = + if is_pos l + then Var.interp rho (blit l) + else negb (Var.interp rho (blit l)) + end + +module C = + struct + type t = int list + + (** val interp : Valuation.t -> t -> bool **) + + let interp rho l = + existsb (Lit.interp rho) l + + (** val _true : t **) + + let _true = + Cons (Lit._true, Nil) + + (** val is_false : t -> bool **) + + let is_false = function + | Nil -> true + | Cons (i, l) -> false + + (** val or_aux : (t -> t -> t) -> int -> t -> t -> int list **) + + let rec or_aux or0 l1 c1 c2 = match c2 with + | Nil -> Cons (l1, c1) + | Cons (l2, c2') -> + (match compare l1 l2 with + | ExtrNative.Eq -> Cons (l1, (or0 c1 c2')) + | ExtrNative.Lt -> Cons (l1, (or0 c1 c2)) + | ExtrNative.Gt -> Cons (l2, (or_aux or0 l1 c1 c2'))) + + (** val coq_or : t -> t -> t **) + + let rec coq_or c1 c2 = + match c1 with + | Nil -> c2 + | Cons (l1, c3) -> + (match c2 with + | Nil -> c1 + | Cons (l2, c2') -> + (match compare l1 l2 with + | ExtrNative.Eq -> Cons (l1, (coq_or c3 c2')) + | ExtrNative.Lt -> Cons (l1, (coq_or c3 c2)) + | ExtrNative.Gt -> Cons (l2, (or_aux coq_or l1 c3 c2')))) + + (** val resolve_aux : (t -> t -> t) -> int -> t -> t -> t **) + + let rec resolve_aux resolve0 l1 c1 c2 = match c2 with + | Nil -> _true + | Cons (l2, c2') -> + (match compare l1 l2 with + | ExtrNative.Eq -> Cons (l1, (resolve0 c1 c2')) + | ExtrNative.Lt -> + if eqb (lxor0 l1 l2) (ExtrNative.of_uint(1)) + then coq_or c1 c2' + else Cons (l1, (resolve0 c1 c2)) + | ExtrNative.Gt -> + if eqb (lxor0 l1 l2) (ExtrNative.of_uint(1)) + then coq_or c1 c2' + else Cons (l2, (resolve_aux resolve0 l1 c1 c2'))) + + (** val resolve : t -> t -> t **) + + let rec resolve c1 c2 = + match c1 with + | Nil -> _true + | Cons (l1, c3) -> + (match c2 with + | Nil -> _true + | Cons (l2, c2') -> + (match compare l1 l2 with + | ExtrNative.Eq -> Cons (l1, (resolve c3 c2')) + | ExtrNative.Lt -> + if eqb (lxor0 l1 l2) (ExtrNative.of_uint(1)) + then coq_or c3 c2' + else Cons (l1, (resolve c3 c2)) + | ExtrNative.Gt -> + if eqb (lxor0 l1 l2) (ExtrNative.of_uint(1)) + then coq_or c3 c2' + else Cons (l2, (resolve_aux resolve l1 c3 c2')))) + end + +module S = + struct + type t = C.t array + + (** val get : t -> int -> C.t **) + + let get s cid = + get s cid + + (** val internal_set : t -> int -> C.t -> t **) + + let internal_set s cid c = + set s cid c + + (** val make : int -> t **) + + let make nclauses = + make nclauses C._true + + (** val insert : int -> int list -> int list **) + + let rec insert l1 c = match c with + | Nil -> Cons (l1, Nil) + | Cons (l2, c') -> + (match compare l1 l2 with + | ExtrNative.Eq -> c + | ExtrNative.Lt -> + if eqb (lxor0 l1 l2) (ExtrNative.of_uint(1)) + then C._true + else Cons (l1, c) + | ExtrNative.Gt -> + if eqb (lxor0 l1 l2) (ExtrNative.of_uint(1)) + then C._true + else Cons (l2, (insert l1 c'))) + + (** val sort_uniq : int list -> int list **) + + let rec sort_uniq = function + | Nil -> Nil + | Cons (l1, c0) -> insert l1 (sort_uniq c0) + + (** val set_clause : t -> int -> C.t -> t **) + + let set_clause s pos c = + set s pos (sort_uniq c) + + (** val set_resolve : t -> int -> int array -> t **) + + let set_resolve s pos r = + let len = length r in + if eqb len (ExtrNative.of_uint(0)) + then s + else let c = + foldi (fun i c -> C.resolve (get s (Coq__1.get r i)) c) + (ExtrNative.of_uint(1)) (sub len (ExtrNative.of_uint(1))) + (get s (Coq__1.get r (ExtrNative.of_uint(0)))) + in + internal_set s pos c + end + +(** val afold_left : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a2 -> 'a1) -> 'a2 array -> 'a1 **) + +let afold_left default oP f v = + let n = length v in + if eqb n (ExtrNative.of_uint(0)) + then default + else foldi (fun i a -> oP a (f (get v i))) (ExtrNative.of_uint(1)) + (sub n (ExtrNative.of_uint(1))) (f (get v (ExtrNative.of_uint(0)))) + +type 'step _trace_ = 'step array array + +(** val _checker_ : + (S.t -> 'a1 -> S.t) -> (C.t -> bool) -> S.t -> 'a1 _trace_ -> int -> bool **) + +let _checker_ check_step is_false0 s t0 confl = + let s' = fold_left (fun s0 a -> fold_left check_step s0 a) s t0 in + is_false0 (S.get s' confl) + +module Sat_Checker = + struct + type step = + | Res of int * int array + + (** val step_rect : (int -> int array -> 'a1) -> step -> 'a1 **) + + let step_rect f = function + | Res (x, x0) -> f x x0 + + (** val step_rec : (int -> int array -> 'a1) -> step -> 'a1 **) + + let step_rec f = function + | Res (x, x0) -> f x x0 + + (** val resolution_checker : + (C.t -> bool) -> S.t -> step _trace_ -> int -> bool **) + + let resolution_checker s t0 = + _checker_ (fun s0 st -> let Res (pos, r) = st in S.set_resolve s0 pos r) + s t0 + + type dimacs = int array array + + (** val coq_C_interp_or : Valuation.t -> int array -> bool **) + + let coq_C_interp_or rho c = + afold_left false (fun b1 b2 -> if b1 then true else b2) (Lit.interp rho) + c + + (** val valid : Valuation.t -> dimacs -> bool **) + + let valid rho d = + afold_left true (fun b1 b2 -> if b1 then b2 else false) + (coq_C_interp_or rho) d + + type certif = + | Certif of int * step _trace_ * int + + (** val certif_rect : + (int -> step _trace_ -> int -> 'a1) -> certif -> 'a1 **) + + let certif_rect f = function + | Certif (x, x0, x1) -> f x x0 x1 + + (** val certif_rec : + (int -> step _trace_ -> int -> 'a1) -> certif -> 'a1 **) + + let certif_rec f = function + | Certif (x, x0, x1) -> f x x0 x1 + + (** val add_roots : S.t -> dimacs -> S.t **) + + let add_roots s d = + foldi_right (fun i c s0 -> S.set_clause s0 i (to_list c)) d s + + (** val checker : dimacs -> certif -> bool **) + + let checker d = function + | Certif (nclauses, t0, confl_id) -> + resolution_checker C.is_false (add_roots (S.make nclauses) d) t0 confl_id + + (** val interp_var : (int -> bool) -> int -> bool **) + + let interp_var rho x = + match compare x (ExtrNative.of_uint(1)) with + | ExtrNative.Eq -> false + | ExtrNative.Lt -> true + | ExtrNative.Gt -> rho (sub x (ExtrNative.of_uint(1))) + end + diff --git a/src/extraction/sat_checker.mli b/src/extraction/sat_checker.mli new file mode 100644 index 0000000..5fa2757 --- /dev/null +++ b/src/extraction/sat_checker.mli @@ -0,0 +1,169 @@ +val negb : bool -> bool + +type 'a list = +| Nil +| Cons of 'a * 'a list + +val existsb : ('a1 -> bool) -> 'a1 list -> bool + +type int = ExtrNative.uint + +val lsl0 : int -> int -> int + +val lsr0 : int -> int -> int + +val land0 : int -> int -> int + +val lxor0 : int -> int -> int + +val sub : int -> int -> int + +val eqb : int -> int -> bool + +val foldi_cont : + (int -> ('a1 -> 'a2) -> 'a1 -> 'a2) -> int -> int -> ('a1 -> 'a2) -> 'a1 -> + 'a2 + +val foldi_down_cont : + (int -> ('a1 -> 'a2) -> 'a1 -> 'a2) -> int -> int -> ('a1 -> 'a2) -> 'a1 -> + 'a2 + +val is_zero : int -> bool + +val is_even : int -> bool + +val compare : int -> int -> ExtrNative.comparison + +val foldi : (int -> 'a1 -> 'a1) -> int -> int -> 'a1 -> 'a1 + +val foldi_down : (int -> 'a1 -> 'a1) -> int -> int -> 'a1 -> 'a1 + +type 'a array = 'a ExtrNative.parray + +val make : int -> 'a1 -> 'a1 array + +val get : 'a1 array -> int -> 'a1 + +val set : 'a1 array -> int -> 'a1 -> 'a1 array + +val length : 'a1 array -> int + +val to_list : 'a1 array -> 'a1 list + +val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a1 -> 'a2 array -> 'a1 + +val foldi_right : (int -> 'a1 -> 'a2 -> 'a2) -> 'a1 array -> 'a2 -> 'a2 + +module Valuation : + sig + type t = int -> bool + end + +module Var : + sig + val _true : int + + val _false : int + + val interp : Valuation.t -> int -> bool + end + +module Lit : + sig + val is_pos : int -> bool + + val blit : int -> int + + val lit : int -> int + + val neg : int -> int + + val nlit : int -> int + + val _true : int + + val _false : int + + val eqb : int -> int -> bool + + val interp : Valuation.t -> int -> bool + end + +module C : + sig + type t = int list + + val interp : Valuation.t -> t -> bool + + val _true : t + + val is_false : t -> bool + + val or_aux : (t -> t -> t) -> int -> t -> t -> int list + + val coq_or : t -> t -> t + + val resolve_aux : (t -> t -> t) -> int -> t -> t -> t + + val resolve : t -> t -> t + end + +module S : + sig + type t = C.t array + + val get : t -> int -> C.t + + val internal_set : t -> int -> C.t -> t + + val make : int -> t + + val insert : int -> int list -> int list + + val sort_uniq : int list -> int list + + val set_clause : t -> int -> C.t -> t + + val set_resolve : t -> int -> int array -> t + end + +val afold_left : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a2 -> 'a1) -> 'a2 array -> 'a1 + +type 'step _trace_ = 'step array array + +val _checker_ : + (S.t -> 'a1 -> S.t) -> (C.t -> bool) -> S.t -> 'a1 _trace_ -> int -> bool + +module Sat_Checker : + sig + type step = + | Res of int * int array + + val step_rect : (int -> int array -> 'a1) -> step -> 'a1 + + val step_rec : (int -> int array -> 'a1) -> step -> 'a1 + + val resolution_checker : + (C.t -> bool) -> S.t -> step _trace_ -> int -> bool + + type dimacs = int array array + + val coq_C_interp_or : Valuation.t -> int array -> bool + + val valid : Valuation.t -> dimacs -> bool + + type certif = + | Certif of int * step _trace_ * int + + val certif_rect : (int -> step _trace_ -> int -> 'a1) -> certif -> 'a1 + + val certif_rec : (int -> step _trace_ -> int -> 'a1) -> certif -> 'a1 + + val add_roots : S.t -> dimacs -> S.t + + val checker : dimacs -> certif -> bool + + val interp_var : (int -> bool) -> int -> bool + end + diff --git a/src/extraction/smt_checker.ml b/src/extraction/smt_checker.ml new file mode 100644 index 0000000..53aa130 --- /dev/null +++ b/src/extraction/smt_checker.ml @@ -0,0 +1,6849 @@ +type __ = Obj.t +let __ = let rec f _ = Obj.repr f in Obj.repr f + +type unit0 = +| Tt + +(** val implb : bool -> bool -> bool **) + +let implb b1 b2 = + if b1 then b2 else true + +(** val xorb : bool -> bool -> bool **) + +let xorb b1 b2 = + if b1 then if b2 then false else true else b2 + +(** val negb : bool -> bool **) + +let negb = function +| true -> false +| false -> true + +type nat = +| O +| S of nat + +type 'a option = +| Some of 'a +| None + +(** val option_map : ('a1 -> 'a2) -> 'a1 option -> 'a2 option **) + +let option_map f = function +| Some a -> Some (f a) +| None -> None + +(** val fst : ('a1*'a2) -> 'a1 **) + +let fst = function +| x,y -> x + +(** val snd : ('a1*'a2) -> 'a2 **) + +let snd = function +| x,y -> y + +type 'a list = +| Nil +| Cons of 'a * 'a list + +(** val app : 'a1 list -> 'a1 list -> 'a1 list **) + +let rec app l m = + match l with + | Nil -> m + | Cons (a, l1) -> Cons (a, (app l1 m)) + +(** val compOpp : ExtrNative.comparison -> ExtrNative.comparison **) + +let compOpp = function +| ExtrNative.Eq -> ExtrNative.Eq +| ExtrNative.Lt -> ExtrNative.Gt +| ExtrNative.Gt -> ExtrNative.Lt + +type compareSpecT = +| CompEqT +| CompLtT +| CompGtT + +(** val compareSpec2Type : ExtrNative.comparison -> compareSpecT **) + +let compareSpec2Type = function +| ExtrNative.Eq -> CompEqT +| ExtrNative.Lt -> CompLtT +| ExtrNative.Gt -> CompGtT + +type 'a compSpecT = compareSpecT + +(** val compSpec2Type : + 'a1 -> 'a1 -> ExtrNative.comparison -> 'a1 compSpecT **) + +let compSpec2Type x y c = + compareSpec2Type c + +type 'a sig0 = + 'a + (* singleton inductive, whose constructor was exist *) + +type sumbool = +| Left +| Right + +type 'a sumor = +| Inleft of 'a +| Inright + +(** val plus : nat -> nat -> nat **) + +let rec plus n0 m = + match n0 with + | O -> m + | S p -> S (plus p m) + +(** val nat_iter : nat -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) + +let rec nat_iter n0 f x = + match n0 with + | O -> x + | S n' -> f (nat_iter n' f x) + +type positive = +| XI of positive +| XO of positive +| XH + +type n = +| N0 +| Npos of positive + +type z = +| Z0 +| Zpos of positive +| Zneg of positive + +(** val eqb : bool -> bool -> bool **) + +let eqb b1 b2 = + if b1 then b2 else if b2 then false else true + +type reflect = +| ReflectT +| ReflectF + +(** val iff_reflect : bool -> reflect **) + +let iff_reflect = function +| true -> ReflectT +| false -> ReflectF + +module type TotalOrder' = + sig + type t + end + +module MakeOrderTac = + functor (O:TotalOrder') -> + struct + + end + +module MaxLogicalProperties = + functor (O:TotalOrder') -> + functor (M:sig + val max : O.t -> O.t -> O.t + end) -> + struct + module Private_Tac = MakeOrderTac(O) + end + +module Pos = + struct + type t = positive + + (** val succ : positive -> positive **) + + let rec succ = function + | XI p -> XO (succ p) + | XO p -> XI p + | XH -> XO XH + + (** val add : positive -> positive -> positive **) + + let rec add x y = + match x with + | XI p -> + (match y with + | XI q -> XO (add_carry p q) + | XO q -> XI (add p q) + | XH -> XO (succ p)) + | XO p -> + (match y with + | XI q -> XI (add p q) + | XO q -> XO (add p q) + | XH -> XI p) + | XH -> + (match y with + | XI q -> XO (succ q) + | XO q -> XI q + | XH -> XO XH) + + (** val add_carry : positive -> positive -> positive **) + + and add_carry x y = + match x with + | XI p -> + (match y with + | XI q -> XI (add_carry p q) + | XO q -> XO (add_carry p q) + | XH -> XI (succ p)) + | XO p -> + (match y with + | XI q -> XO (add_carry p q) + | XO q -> XI (add p q) + | XH -> XO (succ p)) + | XH -> + (match y with + | XI q -> XI (succ q) + | XO q -> XO (succ q) + | XH -> XI XH) + + (** val pred_double : positive -> positive **) + + let rec pred_double = function + | XI p -> XI (XO p) + | XO p -> XI (pred_double p) + | XH -> XH + + (** val pred : positive -> positive **) + + let pred = function + | XI p -> XO p + | XO p -> pred_double p + | XH -> XH + + (** val pred_N : positive -> n **) + + let pred_N = function + | XI p -> Npos (XO p) + | XO p -> Npos (pred_double p) + | XH -> N0 + + type mask = + | IsNul + | IsPos of positive + | IsNeg + + (** val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) + + let mask_rect f f0 f1 = function + | IsNul -> f + | IsPos x -> f0 x + | IsNeg -> f1 + + (** val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) + + let mask_rec f f0 f1 = function + | IsNul -> f + | IsPos x -> f0 x + | IsNeg -> f1 + + (** val succ_double_mask : mask -> mask **) + + let succ_double_mask = function + | IsNul -> IsPos XH + | IsPos p -> IsPos (XI p) + | IsNeg -> IsNeg + + (** val double_mask : mask -> mask **) + + let double_mask = function + | IsPos p -> IsPos (XO p) + | x0 -> x0 + + (** val double_pred_mask : positive -> mask **) + + let double_pred_mask = function + | XI p -> IsPos (XO (XO p)) + | XO p -> IsPos (XO (pred_double p)) + | XH -> IsNul + + (** val pred_mask : mask -> mask **) + + let pred_mask = function + | IsPos q -> + (match q with + | XH -> IsNul + | _ -> IsPos (pred q)) + | _ -> IsNeg + + (** val sub_mask : positive -> positive -> mask **) + + let rec sub_mask x y = + match x with + | XI p -> + (match y with + | XI q -> double_mask (sub_mask p q) + | XO q -> succ_double_mask (sub_mask p q) + | XH -> IsPos (XO p)) + | XO p -> + (match y with + | XI q -> succ_double_mask (sub_mask_carry p q) + | XO q -> double_mask (sub_mask p q) + | XH -> IsPos (pred_double p)) + | XH -> + (match y with + | XH -> IsNul + | _ -> IsNeg) + + (** val sub_mask_carry : positive -> positive -> mask **) + + and sub_mask_carry x y = + match x with + | XI p -> + (match y with + | XI q -> succ_double_mask (sub_mask_carry p q) + | XO q -> double_mask (sub_mask p q) + | XH -> IsPos (pred_double p)) + | XO p -> + (match y with + | XI q -> double_mask (sub_mask_carry p q) + | XO q -> succ_double_mask (sub_mask_carry p q) + | XH -> double_pred_mask p) + | XH -> IsNeg + + (** val sub : positive -> positive -> positive **) + + let sub x y = + match sub_mask x y with + | IsPos z0 -> z0 + | _ -> XH + + (** val mul : positive -> positive -> positive **) + + let rec mul x y = + match x with + | XI p -> add y (XO (mul p y)) + | XO p -> XO (mul p y) + | XH -> y + + (** val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) + + let rec iter n0 f x = + match n0 with + | XI n' -> f (iter n' f (iter n' f x)) + | XO n' -> iter n' f (iter n' f x) + | XH -> f x + + (** val pow : positive -> positive -> positive **) + + let pow x y = + iter y (mul x) XH + + (** val square : positive -> positive **) + + let rec square = function + | XI p2 -> XI (XO (add (square p2) p2)) + | XO p2 -> XO (XO (square p2)) + | XH -> XH + + (** val div2 : positive -> positive **) + + let div2 = function + | XI p2 -> p2 + | XO p2 -> p2 + | XH -> XH + + (** val div2_up : positive -> positive **) + + let div2_up = function + | XI p2 -> succ p2 + | XO p2 -> p2 + | XH -> XH + + (** val size_nat : positive -> nat **) + + let rec size_nat = function + | XI p2 -> S (size_nat p2) + | XO p2 -> S (size_nat p2) + | XH -> S O + + (** val size : positive -> positive **) + + let rec size = function + | XI p2 -> succ (size p2) + | XO p2 -> succ (size p2) + | XH -> XH + + (** val compare_cont : + positive -> positive -> ExtrNative.comparison -> ExtrNative.comparison **) + + let rec compare_cont x y r = + match x with + | XI p -> + (match y with + | XI q -> compare_cont p q r + | XO q -> compare_cont p q ExtrNative.Gt + | XH -> ExtrNative.Gt) + | XO p -> + (match y with + | XI q -> compare_cont p q ExtrNative.Lt + | XO q -> compare_cont p q r + | XH -> ExtrNative.Gt) + | XH -> + (match y with + | XH -> r + | _ -> ExtrNative.Lt) + + (** val compare : positive -> positive -> ExtrNative.comparison **) + + let compare x y = + compare_cont x y ExtrNative.Eq + + (** val min : positive -> positive -> positive **) + + let min p p' = + match compare p p' with + | ExtrNative.Gt -> p' + | _ -> p + + (** val max : positive -> positive -> positive **) + + let max p p' = + match compare p p' with + | ExtrNative.Gt -> p + | _ -> p' + + (** val eqb : positive -> positive -> bool **) + + let rec eqb p q = + match p with + | XI p2 -> + (match q with + | XI q0 -> eqb p2 q0 + | _ -> false) + | XO p2 -> + (match q with + | XO q0 -> eqb p2 q0 + | _ -> false) + | XH -> + (match q with + | XH -> true + | _ -> false) + + (** val leb : positive -> positive -> bool **) + + let leb x y = + match compare x y with + | ExtrNative.Gt -> false + | _ -> true + + (** val ltb : positive -> positive -> bool **) + + let ltb x y = + match compare x y with + | ExtrNative.Lt -> true + | _ -> false + + (** val sqrtrem_step : + (positive -> positive) -> (positive -> positive) -> (positive*mask) -> + positive*mask **) + + let sqrtrem_step f g = function + | s,y -> + (match y with + | IsPos r -> + let s' = XI (XO s) in + let r' = g (f r) in + if leb s' r' then (XI s),(sub_mask r' s') else (XO s),(IsPos r') + | _ -> (XO s),(sub_mask (g (f XH)) (XO (XO XH)))) + + (** val sqrtrem : positive -> positive*mask **) + + let rec sqrtrem = function + | XI p2 -> + (match p2 with + | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XI x) (sqrtrem p3) + | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XI x) (sqrtrem p3) + | XH -> XH,(IsPos (XO XH))) + | XO p2 -> + (match p2 with + | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XO x) (sqrtrem p3) + | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XO x) (sqrtrem p3) + | XH -> XH,(IsPos XH)) + | XH -> XH,IsNul + + (** val sqrt : positive -> positive **) + + let sqrt p = + fst (sqrtrem p) + + (** val gcdn : nat -> positive -> positive -> positive **) + + let rec gcdn n0 a b = + match n0 with + | O -> XH + | S n1 -> + (match a with + | XI a' -> + (match b with + | XI b' -> + (match compare a' b' with + | ExtrNative.Eq -> a + | ExtrNative.Lt -> gcdn n1 (sub b' a') a + | ExtrNative.Gt -> gcdn n1 (sub a' b') b) + | XO b0 -> gcdn n1 a b0 + | XH -> XH) + | XO a0 -> + (match b with + | XI p -> gcdn n1 a0 b + | XO b0 -> XO (gcdn n1 a0 b0) + | XH -> XH) + | XH -> XH) + + (** val gcd : positive -> positive -> positive **) + + let gcd a b = + gcdn (plus (size_nat a) (size_nat b)) a b + + (** val ggcdn : + nat -> positive -> positive -> positive*(positive*positive) **) + + let rec ggcdn n0 a b = + match n0 with + | O -> XH,(a,b) + | S n1 -> + (match a with + | XI a' -> + (match b with + | XI b' -> + (match compare a' b' with + | ExtrNative.Eq -> a,(XH,XH) + | ExtrNative.Lt -> + let g,p = ggcdn n1 (sub b' a') a in + let ba,aa = p in g,(aa,(add aa (XO ba))) + | ExtrNative.Gt -> + let g,p = ggcdn n1 (sub a' b') b in + let ab,bb = p in g,((add bb (XO ab)),bb)) + | XO b0 -> + let g,p = ggcdn n1 a b0 in let aa,bb = p in g,(aa,(XO bb)) + | XH -> XH,(a,XH)) + | XO a0 -> + (match b with + | XI p -> + let g,p2 = ggcdn n1 a0 b in let aa,bb = p2 in g,((XO aa),bb) + | XO b0 -> let g,p = ggcdn n1 a0 b0 in (XO g),p + | XH -> XH,(a,XH)) + | XH -> XH,(XH,b)) + + (** val ggcd : positive -> positive -> positive*(positive*positive) **) + + let ggcd a b = + ggcdn (plus (size_nat a) (size_nat b)) a b + + (** val coq_Nsucc_double : n -> n **) + + let coq_Nsucc_double = function + | N0 -> Npos XH + | Npos p -> Npos (XI p) + + (** val coq_Ndouble : n -> n **) + + let coq_Ndouble = function + | N0 -> N0 + | Npos p -> Npos (XO p) + + (** val coq_lor : positive -> positive -> positive **) + + let rec coq_lor p q = + match p with + | XI p2 -> + (match q with + | XI q0 -> XI (coq_lor p2 q0) + | XO q0 -> XI (coq_lor p2 q0) + | XH -> p) + | XO p2 -> + (match q with + | XI q0 -> XI (coq_lor p2 q0) + | XO q0 -> XO (coq_lor p2 q0) + | XH -> XI p2) + | XH -> + (match q with + | XO q0 -> XI q0 + | _ -> q) + + (** val coq_land : positive -> positive -> n **) + + let rec coq_land p q = + match p with + | XI p2 -> + (match q with + | XI q0 -> coq_Nsucc_double (coq_land p2 q0) + | XO q0 -> coq_Ndouble (coq_land p2 q0) + | XH -> Npos XH) + | XO p2 -> + (match q with + | XI q0 -> coq_Ndouble (coq_land p2 q0) + | XO q0 -> coq_Ndouble (coq_land p2 q0) + | XH -> N0) + | XH -> + (match q with + | XO q0 -> N0 + | _ -> Npos XH) + + (** val ldiff : positive -> positive -> n **) + + let rec ldiff p q = + match p with + | XI p2 -> + (match q with + | XI q0 -> coq_Ndouble (ldiff p2 q0) + | XO q0 -> coq_Nsucc_double (ldiff p2 q0) + | XH -> Npos (XO p2)) + | XO p2 -> + (match q with + | XI q0 -> coq_Ndouble (ldiff p2 q0) + | XO q0 -> coq_Ndouble (ldiff p2 q0) + | XH -> Npos p) + | XH -> + (match q with + | XO q0 -> Npos XH + | _ -> N0) + + (** val coq_lxor : positive -> positive -> n **) + + let rec coq_lxor p q = + match p with + | XI p2 -> + (match q with + | XI q0 -> coq_Ndouble (coq_lxor p2 q0) + | XO q0 -> coq_Nsucc_double (coq_lxor p2 q0) + | XH -> Npos (XO p2)) + | XO p2 -> + (match q with + | XI q0 -> coq_Nsucc_double (coq_lxor p2 q0) + | XO q0 -> coq_Ndouble (coq_lxor p2 q0) + | XH -> Npos (XI p2)) + | XH -> + (match q with + | XI q0 -> Npos (XO q0) + | XO q0 -> Npos (XI q0) + | XH -> N0) + + (** val shiftl_nat : positive -> nat -> positive **) + + let shiftl_nat p n0 = + nat_iter n0 (fun x -> XO x) p + + (** val shiftr_nat : positive -> nat -> positive **) + + let shiftr_nat p n0 = + nat_iter n0 div2 p + + (** val shiftl : positive -> n -> positive **) + + let shiftl p = function + | N0 -> p + | Npos n1 -> iter n1 (fun x -> XO x) p + + (** val shiftr : positive -> n -> positive **) + + let shiftr p = function + | N0 -> p + | Npos n1 -> iter n1 div2 p + + (** val testbit_nat : positive -> nat -> bool **) + + let rec testbit_nat p n0 = + match p with + | XI p2 -> + (match n0 with + | O -> true + | S n' -> testbit_nat p2 n') + | XO p2 -> + (match n0 with + | O -> false + | S n' -> testbit_nat p2 n') + | XH -> + (match n0 with + | O -> true + | S n1 -> false) + + (** val testbit : positive -> n -> bool **) + + let rec testbit p n0 = + match p with + | XI p2 -> + (match n0 with + | N0 -> true + | Npos n1 -> testbit p2 (pred_N n1)) + | XO p2 -> + (match n0 with + | N0 -> false + | Npos n1 -> testbit p2 (pred_N n1)) + | XH -> + (match n0 with + | N0 -> true + | Npos p2 -> false) + + (** val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 **) + + let rec iter_op op p a = + match p with + | XI p2 -> op a (iter_op op p2 (op a a)) + | XO p2 -> iter_op op p2 (op a a) + | XH -> a + + (** val to_nat : positive -> nat **) + + let to_nat x = + iter_op plus x (S O) + + (** val of_nat : nat -> positive **) + + let rec of_nat = function + | O -> XH + | S x -> + (match x with + | O -> XH + | S n1 -> succ (of_nat x)) + + (** val of_succ_nat : nat -> positive **) + + let rec of_succ_nat = function + | O -> XH + | S x -> succ (of_succ_nat x) + end + +module Coq_Pos = + struct + module Coq__1 = struct + type t = positive + end + type t = Coq__1.t + + (** val succ : positive -> positive **) + + let rec succ = function + | XI p -> XO (succ p) + | XO p -> XI p + | XH -> XO XH + + (** val add : positive -> positive -> positive **) + + let rec add x y = + match x with + | XI p -> + (match y with + | XI q -> XO (add_carry p q) + | XO q -> XI (add p q) + | XH -> XO (succ p)) + | XO p -> + (match y with + | XI q -> XI (add p q) + | XO q -> XO (add p q) + | XH -> XI p) + | XH -> + (match y with + | XI q -> XO (succ q) + | XO q -> XI q + | XH -> XO XH) + + (** val add_carry : positive -> positive -> positive **) + + and add_carry x y = + match x with + | XI p -> + (match y with + | XI q -> XI (add_carry p q) + | XO q -> XO (add_carry p q) + | XH -> XI (succ p)) + | XO p -> + (match y with + | XI q -> XO (add_carry p q) + | XO q -> XI (add p q) + | XH -> XO (succ p)) + | XH -> + (match y with + | XI q -> XI (succ q) + | XO q -> XO (succ q) + | XH -> XI XH) + + (** val pred_double : positive -> positive **) + + let rec pred_double = function + | XI p -> XI (XO p) + | XO p -> XI (pred_double p) + | XH -> XH + + (** val pred : positive -> positive **) + + let pred = function + | XI p -> XO p + | XO p -> pred_double p + | XH -> XH + + (** val pred_N : positive -> n **) + + let pred_N = function + | XI p -> Npos (XO p) + | XO p -> Npos (pred_double p) + | XH -> N0 + + type mask = Pos.mask = + | IsNul + | IsPos of positive + | IsNeg + + (** val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) + + let mask_rect f f0 f1 = function + | IsNul -> f + | IsPos x -> f0 x + | IsNeg -> f1 + + (** val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) + + let mask_rec f f0 f1 = function + | IsNul -> f + | IsPos x -> f0 x + | IsNeg -> f1 + + (** val succ_double_mask : mask -> mask **) + + let succ_double_mask = function + | IsNul -> IsPos XH + | IsPos p -> IsPos (XI p) + | IsNeg -> IsNeg + + (** val double_mask : mask -> mask **) + + let double_mask = function + | IsPos p -> IsPos (XO p) + | x0 -> x0 + + (** val double_pred_mask : positive -> mask **) + + let double_pred_mask = function + | XI p -> IsPos (XO (XO p)) + | XO p -> IsPos (XO (pred_double p)) + | XH -> IsNul + + (** val pred_mask : mask -> mask **) + + let pred_mask = function + | IsPos q -> + (match q with + | XH -> IsNul + | _ -> IsPos (pred q)) + | _ -> IsNeg + + (** val sub_mask : positive -> positive -> mask **) + + let rec sub_mask x y = + match x with + | XI p -> + (match y with + | XI q -> double_mask (sub_mask p q) + | XO q -> succ_double_mask (sub_mask p q) + | XH -> IsPos (XO p)) + | XO p -> + (match y with + | XI q -> succ_double_mask (sub_mask_carry p q) + | XO q -> double_mask (sub_mask p q) + | XH -> IsPos (pred_double p)) + | XH -> + (match y with + | XH -> IsNul + | _ -> IsNeg) + + (** val sub_mask_carry : positive -> positive -> mask **) + + and sub_mask_carry x y = + match x with + | XI p -> + (match y with + | XI q -> succ_double_mask (sub_mask_carry p q) + | XO q -> double_mask (sub_mask p q) + | XH -> IsPos (pred_double p)) + | XO p -> + (match y with + | XI q -> double_mask (sub_mask_carry p q) + | XO q -> succ_double_mask (sub_mask_carry p q) + | XH -> double_pred_mask p) + | XH -> IsNeg + + (** val sub : positive -> positive -> positive **) + + let sub x y = + match sub_mask x y with + | IsPos z0 -> z0 + | _ -> XH + + (** val mul : positive -> positive -> positive **) + + let rec mul x y = + match x with + | XI p -> add y (XO (mul p y)) + | XO p -> XO (mul p y) + | XH -> y + + (** val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) + + let rec iter n0 f x = + match n0 with + | XI n' -> f (iter n' f (iter n' f x)) + | XO n' -> iter n' f (iter n' f x) + | XH -> f x + + (** val pow : positive -> positive -> positive **) + + let pow x y = + iter y (mul x) XH + + (** val square : positive -> positive **) + + let rec square = function + | XI p2 -> XI (XO (add (square p2) p2)) + | XO p2 -> XO (XO (square p2)) + | XH -> XH + + (** val div2 : positive -> positive **) + + let div2 = function + | XI p2 -> p2 + | XO p2 -> p2 + | XH -> XH + + (** val div2_up : positive -> positive **) + + let div2_up = function + | XI p2 -> succ p2 + | XO p2 -> p2 + | XH -> XH + + (** val size_nat : positive -> nat **) + + let rec size_nat = function + | XI p2 -> S (size_nat p2) + | XO p2 -> S (size_nat p2) + | XH -> S O + + (** val size : positive -> positive **) + + let rec size = function + | XI p2 -> succ (size p2) + | XO p2 -> succ (size p2) + | XH -> XH + + (** val compare_cont : + positive -> positive -> ExtrNative.comparison -> ExtrNative.comparison **) + + let rec compare_cont x y r = + match x with + | XI p -> + (match y with + | XI q -> compare_cont p q r + | XO q -> compare_cont p q ExtrNative.Gt + | XH -> ExtrNative.Gt) + | XO p -> + (match y with + | XI q -> compare_cont p q ExtrNative.Lt + | XO q -> compare_cont p q r + | XH -> ExtrNative.Gt) + | XH -> + (match y with + | XH -> r + | _ -> ExtrNative.Lt) + + (** val compare : positive -> positive -> ExtrNative.comparison **) + + let compare x y = + compare_cont x y ExtrNative.Eq + + (** val min : positive -> positive -> positive **) + + let min p p' = + match compare p p' with + | ExtrNative.Gt -> p' + | _ -> p + + (** val max : positive -> positive -> positive **) + + let max p p' = + match compare p p' with + | ExtrNative.Gt -> p + | _ -> p' + + (** val eqb : positive -> positive -> bool **) + + let rec eqb p q = + match p with + | XI p2 -> + (match q with + | XI q0 -> eqb p2 q0 + | _ -> false) + | XO p2 -> + (match q with + | XO q0 -> eqb p2 q0 + | _ -> false) + | XH -> + (match q with + | XH -> true + | _ -> false) + + (** val leb : positive -> positive -> bool **) + + let leb x y = + match compare x y with + | ExtrNative.Gt -> false + | _ -> true + + (** val ltb : positive -> positive -> bool **) + + let ltb x y = + match compare x y with + | ExtrNative.Lt -> true + | _ -> false + + (** val sqrtrem_step : + (positive -> positive) -> (positive -> positive) -> (positive*mask) -> + positive*mask **) + + let sqrtrem_step f g = function + | s,y -> + (match y with + | IsPos r -> + let s' = XI (XO s) in + let r' = g (f r) in + if leb s' r' then (XI s),(sub_mask r' s') else (XO s),(IsPos r') + | _ -> (XO s),(sub_mask (g (f XH)) (XO (XO XH)))) + + (** val sqrtrem : positive -> positive*mask **) + + let rec sqrtrem = function + | XI p2 -> + (match p2 with + | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XI x) (sqrtrem p3) + | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XI x) (sqrtrem p3) + | XH -> XH,(IsPos (XO XH))) + | XO p2 -> + (match p2 with + | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XO x) (sqrtrem p3) + | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XO x) (sqrtrem p3) + | XH -> XH,(IsPos XH)) + | XH -> XH,IsNul + + (** val sqrt : positive -> positive **) + + let sqrt p = + fst (sqrtrem p) + + (** val gcdn : nat -> positive -> positive -> positive **) + + let rec gcdn n0 a b = + match n0 with + | O -> XH + | S n1 -> + (match a with + | XI a' -> + (match b with + | XI b' -> + (match compare a' b' with + | ExtrNative.Eq -> a + | ExtrNative.Lt -> gcdn n1 (sub b' a') a + | ExtrNative.Gt -> gcdn n1 (sub a' b') b) + | XO b0 -> gcdn n1 a b0 + | XH -> XH) + | XO a0 -> + (match b with + | XI p -> gcdn n1 a0 b + | XO b0 -> XO (gcdn n1 a0 b0) + | XH -> XH) + | XH -> XH) + + (** val gcd : positive -> positive -> positive **) + + let gcd a b = + gcdn (plus (size_nat a) (size_nat b)) a b + + (** val ggcdn : + nat -> positive -> positive -> positive*(positive*positive) **) + + let rec ggcdn n0 a b = + match n0 with + | O -> XH,(a,b) + | S n1 -> + (match a with + | XI a' -> + (match b with + | XI b' -> + (match compare a' b' with + | ExtrNative.Eq -> a,(XH,XH) + | ExtrNative.Lt -> + let g,p = ggcdn n1 (sub b' a') a in + let ba,aa = p in g,(aa,(add aa (XO ba))) + | ExtrNative.Gt -> + let g,p = ggcdn n1 (sub a' b') b in + let ab,bb = p in g,((add bb (XO ab)),bb)) + | XO b0 -> + let g,p = ggcdn n1 a b0 in let aa,bb = p in g,(aa,(XO bb)) + | XH -> XH,(a,XH)) + | XO a0 -> + (match b with + | XI p -> + let g,p2 = ggcdn n1 a0 b in let aa,bb = p2 in g,((XO aa),bb) + | XO b0 -> let g,p = ggcdn n1 a0 b0 in (XO g),p + | XH -> XH,(a,XH)) + | XH -> XH,(XH,b)) + + (** val ggcd : positive -> positive -> positive*(positive*positive) **) + + let ggcd a b = + ggcdn (plus (size_nat a) (size_nat b)) a b + + (** val coq_Nsucc_double : n -> n **) + + let coq_Nsucc_double = function + | N0 -> Npos XH + | Npos p -> Npos (XI p) + + (** val coq_Ndouble : n -> n **) + + let coq_Ndouble = function + | N0 -> N0 + | Npos p -> Npos (XO p) + + (** val coq_lor : positive -> positive -> positive **) + + let rec coq_lor p q = + match p with + | XI p2 -> + (match q with + | XI q0 -> XI (coq_lor p2 q0) + | XO q0 -> XI (coq_lor p2 q0) + | XH -> p) + | XO p2 -> + (match q with + | XI q0 -> XI (coq_lor p2 q0) + | XO q0 -> XO (coq_lor p2 q0) + | XH -> XI p2) + | XH -> + (match q with + | XO q0 -> XI q0 + | _ -> q) + + (** val coq_land : positive -> positive -> n **) + + let rec coq_land p q = + match p with + | XI p2 -> + (match q with + | XI q0 -> coq_Nsucc_double (coq_land p2 q0) + | XO q0 -> coq_Ndouble (coq_land p2 q0) + | XH -> Npos XH) + | XO p2 -> + (match q with + | XI q0 -> coq_Ndouble (coq_land p2 q0) + | XO q0 -> coq_Ndouble (coq_land p2 q0) + | XH -> N0) + | XH -> + (match q with + | XO q0 -> N0 + | _ -> Npos XH) + + (** val ldiff : positive -> positive -> n **) + + let rec ldiff p q = + match p with + | XI p2 -> + (match q with + | XI q0 -> coq_Ndouble (ldiff p2 q0) + | XO q0 -> coq_Nsucc_double (ldiff p2 q0) + | XH -> Npos (XO p2)) + | XO p2 -> + (match q with + | XI q0 -> coq_Ndouble (ldiff p2 q0) + | XO q0 -> coq_Ndouble (ldiff p2 q0) + | XH -> Npos p) + | XH -> + (match q with + | XO q0 -> Npos XH + | _ -> N0) + + (** val coq_lxor : positive -> positive -> n **) + + let rec coq_lxor p q = + match p with + | XI p2 -> + (match q with + | XI q0 -> coq_Ndouble (coq_lxor p2 q0) + | XO q0 -> coq_Nsucc_double (coq_lxor p2 q0) + | XH -> Npos (XO p2)) + | XO p2 -> + (match q with + | XI q0 -> coq_Nsucc_double (coq_lxor p2 q0) + | XO q0 -> coq_Ndouble (coq_lxor p2 q0) + | XH -> Npos (XI p2)) + | XH -> + (match q with + | XI q0 -> Npos (XO q0) + | XO q0 -> Npos (XI q0) + | XH -> N0) + + (** val shiftl_nat : positive -> nat -> positive **) + + let shiftl_nat p n0 = + nat_iter n0 (fun x -> XO x) p + + (** val shiftr_nat : positive -> nat -> positive **) + + let shiftr_nat p n0 = + nat_iter n0 div2 p + + (** val shiftl : positive -> n -> positive **) + + let shiftl p = function + | N0 -> p + | Npos n1 -> iter n1 (fun x -> XO x) p + + (** val shiftr : positive -> n -> positive **) + + let shiftr p = function + | N0 -> p + | Npos n1 -> iter n1 div2 p + + (** val testbit_nat : positive -> nat -> bool **) + + let rec testbit_nat p n0 = + match p with + | XI p2 -> + (match n0 with + | O -> true + | S n' -> testbit_nat p2 n') + | XO p2 -> + (match n0 with + | O -> false + | S n' -> testbit_nat p2 n') + | XH -> + (match n0 with + | O -> true + | S n1 -> false) + + (** val testbit : positive -> n -> bool **) + + let rec testbit p n0 = + match p with + | XI p2 -> + (match n0 with + | N0 -> true + | Npos n1 -> testbit p2 (pred_N n1)) + | XO p2 -> + (match n0 with + | N0 -> false + | Npos n1 -> testbit p2 (pred_N n1)) + | XH -> + (match n0 with + | N0 -> true + | Npos p2 -> false) + + (** val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 **) + + let rec iter_op op p a = + match p with + | XI p2 -> op a (iter_op op p2 (op a a)) + | XO p2 -> iter_op op p2 (op a a) + | XH -> a + + (** val to_nat : positive -> nat **) + + let to_nat x = + iter_op plus x (S O) + + (** val of_nat : nat -> positive **) + + let rec of_nat = function + | O -> XH + | S x -> + (match x with + | O -> XH + | S n1 -> succ (of_nat x)) + + (** val of_succ_nat : nat -> positive **) + + let rec of_succ_nat = function + | O -> XH + | S x -> succ (of_succ_nat x) + + (** val eq_dec : positive -> positive -> sumbool **) + + let rec eq_dec p y0 = + match p with + | XI p2 -> + (match y0 with + | XI p3 -> eq_dec p2 p3 + | _ -> Right) + | XO p2 -> + (match y0 with + | XO p3 -> eq_dec p2 p3 + | _ -> Right) + | XH -> + (match y0 with + | XH -> Left + | _ -> Right) + + (** val peano_rect : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 **) + + let rec peano_rect a f p = + let f2 = peano_rect (f XH a) (fun p2 x -> f (succ (XO p2)) (f (XO p2) x)) + in + (match p with + | XI q -> f (XO q) (f2 q) + | XO q -> f2 q + | XH -> a) + + (** val peano_rec : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 **) + + let peano_rec = + peano_rect + + type coq_PeanoView = + | PeanoOne + | PeanoSucc of positive * coq_PeanoView + + (** val coq_PeanoView_rect : + 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> + coq_PeanoView -> 'a1 **) + + let rec coq_PeanoView_rect f f0 p = function + | PeanoOne -> f + | PeanoSucc (p3, p4) -> f0 p3 p4 (coq_PeanoView_rect f f0 p3 p4) + + (** val coq_PeanoView_rec : + 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> + coq_PeanoView -> 'a1 **) + + let rec coq_PeanoView_rec f f0 p = function + | PeanoOne -> f + | PeanoSucc (p3, p4) -> f0 p3 p4 (coq_PeanoView_rec f f0 p3 p4) + + (** val peanoView_xO : positive -> coq_PeanoView -> coq_PeanoView **) + + let rec peanoView_xO p = function + | PeanoOne -> PeanoSucc (XH, PeanoOne) + | PeanoSucc (p2, q0) -> + PeanoSucc ((succ (XO p2)), (PeanoSucc ((XO p2), (peanoView_xO p2 q0)))) + + (** val peanoView_xI : positive -> coq_PeanoView -> coq_PeanoView **) + + let rec peanoView_xI p = function + | PeanoOne -> PeanoSucc ((succ XH), (PeanoSucc (XH, PeanoOne))) + | PeanoSucc (p2, q0) -> + PeanoSucc ((succ (XI p2)), (PeanoSucc ((XI p2), (peanoView_xI p2 q0)))) + + (** val peanoView : positive -> coq_PeanoView **) + + let rec peanoView = function + | XI p2 -> peanoView_xI p2 (peanoView p2) + | XO p2 -> peanoView_xO p2 (peanoView p2) + | XH -> PeanoOne + + (** val coq_PeanoView_iter : + 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1 **) + + let rec coq_PeanoView_iter a f p = function + | PeanoOne -> a + | PeanoSucc (p2, q0) -> f p2 (coq_PeanoView_iter a f p2 q0) + + (** val eqb_spec : positive -> positive -> reflect **) + + let eqb_spec x y = + iff_reflect (eqb x y) + + (** val switch_Eq : + ExtrNative.comparison -> ExtrNative.comparison -> ExtrNative.comparison **) + + let switch_Eq c = function + | ExtrNative.Eq -> c + | x -> x + + (** val mask2cmp : mask -> ExtrNative.comparison **) + + let mask2cmp = function + | IsNul -> ExtrNative.Eq + | IsPos p2 -> ExtrNative.Gt + | IsNeg -> ExtrNative.Lt + + (** val leb_spec0 : positive -> positive -> reflect **) + + let leb_spec0 x y = + iff_reflect (leb x y) + + (** val ltb_spec0 : positive -> positive -> reflect **) + + let ltb_spec0 x y = + iff_reflect (ltb x y) + + module Private_Tac = + struct + + end + + module Private_Rev = + struct + module ORev = + struct + type t = Coq__1.t + end + + module MRev = + struct + (** val max : t -> t -> t **) + + let max x y = + min y x + end + + module MPRev = MaxLogicalProperties(ORev)(MRev) + end + + module Private_Dec = + struct + (** val max_case_strong : + t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> 'a1 **) + + let max_case_strong n0 m compat hl hr = + let c = compSpec2Type n0 m (compare n0 m) in + (match c with + | CompGtT -> compat n0 (max n0 m) __ (hl __) + | _ -> compat m (max n0 m) __ (hr __)) + + (** val max_case : + t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) + + let max_case n0 m x x0 x1 = + max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) + + (** val max_dec : t -> t -> sumbool **) + + let max_dec n0 m = + max_case n0 m (fun x y _ h0 -> h0) Left Right + + (** val min_case_strong : + t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> 'a1 **) + + let min_case_strong n0 m compat hl hr = + let c = compSpec2Type n0 m (compare n0 m) in + (match c with + | CompGtT -> compat m (min n0 m) __ (hr __) + | _ -> compat n0 (min n0 m) __ (hl __)) + + (** val min_case : + t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) + + let min_case n0 m x x0 x1 = + min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) + + (** val min_dec : t -> t -> sumbool **) + + let min_dec n0 m = + min_case n0 m (fun x y _ h0 -> h0) Left Right + end + + (** val max_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) + + let max_case_strong n0 m x x0 = + Private_Dec.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 + + (** val max_case : t -> t -> 'a1 -> 'a1 -> 'a1 **) + + let max_case n0 m x x0 = + max_case_strong n0 m (fun _ -> x) (fun _ -> x0) + + (** val max_dec : t -> t -> sumbool **) + + let max_dec = + Private_Dec.max_dec + + (** val min_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) + + let min_case_strong n0 m x x0 = + Private_Dec.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 + + (** val min_case : t -> t -> 'a1 -> 'a1 -> 'a1 **) + + let min_case n0 m x x0 = + min_case_strong n0 m (fun _ -> x) (fun _ -> x0) + + (** val min_dec : t -> t -> sumbool **) + + let min_dec = + Private_Dec.min_dec + end + +module N = + struct + type t = n + + (** val zero : n **) + + let zero = + N0 + + (** val one : n **) + + let one = + Npos XH + + (** val two : n **) + + let two = + Npos (XO XH) + + (** val succ_double : n -> n **) + + let succ_double = function + | N0 -> Npos XH + | Npos p -> Npos (XI p) + + (** val double : n -> n **) + + let double = function + | N0 -> N0 + | Npos p -> Npos (XO p) + + (** val succ : n -> n **) + + let succ = function + | N0 -> Npos XH + | Npos p -> Npos (Coq_Pos.succ p) + + (** val pred : n -> n **) + + let pred = function + | N0 -> N0 + | Npos p -> Coq_Pos.pred_N p + + (** val succ_pos : n -> positive **) + + let succ_pos = function + | N0 -> XH + | Npos p -> Coq_Pos.succ p + + (** val add : n -> n -> n **) + + let add n0 m = + match n0 with + | N0 -> m + | Npos p -> + (match m with + | N0 -> n0 + | Npos q -> Npos (Coq_Pos.add p q)) + + (** val sub : n -> n -> n **) + + let sub n0 m = + match n0 with + | N0 -> N0 + | Npos n' -> + (match m with + | N0 -> n0 + | Npos m' -> + (match Coq_Pos.sub_mask n' m' with + | Coq_Pos.IsPos p -> Npos p + | _ -> N0)) + + (** val mul : n -> n -> n **) + + let mul n0 m = + match n0 with + | N0 -> N0 + | Npos p -> + (match m with + | N0 -> N0 + | Npos q -> Npos (Coq_Pos.mul p q)) + + (** val compare : n -> n -> ExtrNative.comparison **) + + let compare n0 m = + match n0 with + | N0 -> + (match m with + | N0 -> ExtrNative.Eq + | Npos m' -> ExtrNative.Lt) + | Npos n' -> + (match m with + | N0 -> ExtrNative.Gt + | Npos m' -> Coq_Pos.compare n' m') + + (** val eqb : n -> n -> bool **) + + let rec eqb n0 m = + match n0 with + | N0 -> + (match m with + | N0 -> true + | Npos p -> false) + | Npos p -> + (match m with + | N0 -> false + | Npos q -> Coq_Pos.eqb p q) + + (** val leb : n -> n -> bool **) + + let leb x y = + match compare x y with + | ExtrNative.Gt -> false + | _ -> true + + (** val ltb : n -> n -> bool **) + + let ltb x y = + match compare x y with + | ExtrNative.Lt -> true + | _ -> false + + (** val min : n -> n -> n **) + + let min n0 n' = + match compare n0 n' with + | ExtrNative.Gt -> n' + | _ -> n0 + + (** val max : n -> n -> n **) + + let max n0 n' = + match compare n0 n' with + | ExtrNative.Gt -> n0 + | _ -> n' + + (** val div2 : n -> n **) + + let div2 = function + | N0 -> N0 + | Npos p2 -> + (match p2 with + | XI p -> Npos p + | XO p -> Npos p + | XH -> N0) + + (** val even : n -> bool **) + + let even = function + | N0 -> true + | Npos p -> + (match p with + | XO p2 -> true + | _ -> false) + + (** val odd : n -> bool **) + + let odd n0 = + negb (even n0) + + (** val pow : n -> n -> n **) + + let pow n0 = function + | N0 -> Npos XH + | Npos p2 -> + (match n0 with + | N0 -> N0 + | Npos q -> Npos (Coq_Pos.pow q p2)) + + (** val square : n -> n **) + + let square = function + | N0 -> N0 + | Npos p -> Npos (Coq_Pos.square p) + + (** val log2 : n -> n **) + + let log2 = function + | N0 -> N0 + | Npos p2 -> + (match p2 with + | XI p -> Npos (Coq_Pos.size p) + | XO p -> Npos (Coq_Pos.size p) + | XH -> N0) + + (** val size : n -> n **) + + let size = function + | N0 -> N0 + | Npos p -> Npos (Coq_Pos.size p) + + (** val size_nat : n -> nat **) + + let size_nat = function + | N0 -> O + | Npos p -> Coq_Pos.size_nat p + + (** val pos_div_eucl : positive -> n -> n*n **) + + let rec pos_div_eucl a b = + match a with + | XI a' -> + let q,r = pos_div_eucl a' b in + let r' = succ_double r in + if leb b r' then (succ_double q),(sub r' b) else (double q),r' + | XO a' -> + let q,r = pos_div_eucl a' b in + let r' = double r in + if leb b r' then (succ_double q),(sub r' b) else (double q),r' + | XH -> + (match b with + | N0 -> N0,(Npos XH) + | Npos p -> + (match p with + | XH -> (Npos XH),N0 + | _ -> N0,(Npos XH))) + + (** val div_eucl : n -> n -> n*n **) + + let div_eucl a b = + match a with + | N0 -> N0,N0 + | Npos na -> + (match b with + | N0 -> N0,a + | Npos p -> pos_div_eucl na b) + + (** val div : n -> n -> n **) + + let div a b = + fst (div_eucl a b) + + (** val modulo : n -> n -> n **) + + let modulo a b = + snd (div_eucl a b) + + (** val gcd : n -> n -> n **) + + let gcd a b = + match a with + | N0 -> b + | Npos p -> + (match b with + | N0 -> a + | Npos q -> Npos (Coq_Pos.gcd p q)) + + (** val ggcd : n -> n -> n*(n*n) **) + + let ggcd a b = + match a with + | N0 -> b,(N0,(Npos XH)) + | Npos p -> + (match b with + | N0 -> a,((Npos XH),N0) + | Npos q -> + let g,p2 = Coq_Pos.ggcd p q in + let aa,bb = p2 in (Npos g),((Npos aa),(Npos bb))) + + (** val sqrtrem : n -> n*n **) + + let sqrtrem = function + | N0 -> N0,N0 + | Npos p -> + let s,m = Coq_Pos.sqrtrem p in + (match m with + | Coq_Pos.IsPos r -> (Npos s),(Npos r) + | _ -> (Npos s),N0) + + (** val sqrt : n -> n **) + + let sqrt = function + | N0 -> N0 + | Npos p -> Npos (Coq_Pos.sqrt p) + + (** val coq_lor : n -> n -> n **) + + let coq_lor n0 m = + match n0 with + | N0 -> m + | Npos p -> + (match m with + | N0 -> n0 + | Npos q -> Npos (Coq_Pos.coq_lor p q)) + + (** val coq_land : n -> n -> n **) + + let coq_land n0 m = + match n0 with + | N0 -> N0 + | Npos p -> + (match m with + | N0 -> N0 + | Npos q -> Coq_Pos.coq_land p q) + + (** val ldiff : n -> n -> n **) + + let rec ldiff n0 m = + match n0 with + | N0 -> N0 + | Npos p -> + (match m with + | N0 -> n0 + | Npos q -> Coq_Pos.ldiff p q) + + (** val coq_lxor : n -> n -> n **) + + let coq_lxor n0 m = + match n0 with + | N0 -> m + | Npos p -> + (match m with + | N0 -> n0 + | Npos q -> Coq_Pos.coq_lxor p q) + + (** val shiftl_nat : n -> nat -> n **) + + let shiftl_nat a n0 = + nat_iter n0 double a + + (** val shiftr_nat : n -> nat -> n **) + + let shiftr_nat a n0 = + nat_iter n0 div2 a + + (** val shiftl : n -> n -> n **) + + let shiftl a n0 = + match a with + | N0 -> N0 + | Npos a0 -> Npos (Coq_Pos.shiftl a0 n0) + + (** val shiftr : n -> n -> n **) + + let shiftr a = function + | N0 -> a + | Npos p -> Coq_Pos.iter p div2 a + + (** val testbit_nat : n -> nat -> bool **) + + let testbit_nat = function + | N0 -> (fun x -> false) + | Npos p -> Coq_Pos.testbit_nat p + + (** val testbit : n -> n -> bool **) + + let testbit a n0 = + match a with + | N0 -> false + | Npos p -> Coq_Pos.testbit p n0 + + (** val to_nat : n -> nat **) + + let to_nat = function + | N0 -> O + | Npos p -> Coq_Pos.to_nat p + + (** val of_nat : nat -> n **) + + let of_nat = function + | O -> N0 + | S n' -> Npos (Coq_Pos.of_succ_nat n') + + (** val iter : n -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) + + let iter n0 f x = + match n0 with + | N0 -> x + | Npos p -> Coq_Pos.iter p f x + + (** val eq_dec : n -> n -> sumbool **) + + let eq_dec n0 m = + match n0 with + | N0 -> + (match m with + | N0 -> Left + | Npos p -> Right) + | Npos x -> + (match m with + | N0 -> Right + | Npos p2 -> Coq_Pos.eq_dec x p2) + + (** val discr : n -> positive sumor **) + + let discr = function + | N0 -> Inright + | Npos p -> Inleft p + + (** val binary_rect : + 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) + + let binary_rect f0 f2 fS2 n0 = + let f2' = fun p -> f2 (Npos p) in + let fS2' = fun p -> fS2 (Npos p) in + (match n0 with + | N0 -> f0 + | Npos p -> + let rec f = function + | XI p3 -> fS2' p3 (f p3) + | XO p3 -> f2' p3 (f p3) + | XH -> fS2 N0 f0 + in f p) + + (** val binary_rec : + 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) + + let binary_rec = + binary_rect + + (** val peano_rect : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) + + let peano_rect f0 f n0 = + let f' = fun p -> f (Npos p) in + (match n0 with + | N0 -> f0 + | Npos p -> Coq_Pos.peano_rect (f N0 f0) f' p) + + (** val peano_rec : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) + + let peano_rec = + peano_rect + + (** val leb_spec0 : n -> n -> reflect **) + + let leb_spec0 x y = + iff_reflect (leb x y) + + (** val ltb_spec0 : n -> n -> reflect **) + + let ltb_spec0 x y = + iff_reflect (ltb x y) + + module Private_BootStrap = + struct + + end + + (** val recursion : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) + + let recursion x = + peano_rect x + + module Private_OrderTac = + struct + module Elts = + struct + type t = n + end + + module Tac = MakeOrderTac(Elts) + end + + module Private_NZPow = + struct + + end + + module Private_NZSqrt = + struct + + end + + (** val sqrt_up : n -> n **) + + let sqrt_up a = + match compare N0 a with + | ExtrNative.Lt -> succ (sqrt (pred a)) + | _ -> N0 + + (** val log2_up : n -> n **) + + let log2_up a = + match compare (Npos XH) a with + | ExtrNative.Lt -> succ (log2 (pred a)) + | _ -> N0 + + module Private_NZDiv = + struct + + end + + (** val lcm : n -> n -> n **) + + let lcm a b = + mul a (div b (gcd a b)) + + (** val eqb_spec : n -> n -> reflect **) + + let eqb_spec x y = + iff_reflect (eqb x y) + + (** val b2n : bool -> n **) + + let b2n = function + | true -> Npos XH + | false -> N0 + + (** val setbit : n -> n -> n **) + + let setbit a n0 = + coq_lor a (shiftl (Npos XH) n0) + + (** val clearbit : n -> n -> n **) + + let clearbit a n0 = + ldiff a (shiftl (Npos XH) n0) + + (** val ones : n -> n **) + + let ones n0 = + pred (shiftl (Npos XH) n0) + + (** val lnot : n -> n -> n **) + + let lnot a n0 = + coq_lxor a (ones n0) + + module Private_Tac = + struct + + end + + module Private_Rev = + struct + module ORev = + struct + type t = n + end + + module MRev = + struct + (** val max : n -> n -> n **) + + let max x y = + min y x + end + + module MPRev = MaxLogicalProperties(ORev)(MRev) + end + + module Private_Dec = + struct + (** val max_case_strong : + n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> 'a1 **) + + let max_case_strong n0 m compat hl hr = + let c = compSpec2Type n0 m (compare n0 m) in + (match c with + | CompGtT -> compat n0 (max n0 m) __ (hl __) + | _ -> compat m (max n0 m) __ (hr __)) + + (** val max_case : + n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) + + let max_case n0 m x x0 x1 = + max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) + + (** val max_dec : n -> n -> sumbool **) + + let max_dec n0 m = + max_case n0 m (fun x y _ h0 -> h0) Left Right + + (** val min_case_strong : + n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> 'a1 **) + + let min_case_strong n0 m compat hl hr = + let c = compSpec2Type n0 m (compare n0 m) in + (match c with + | CompGtT -> compat m (min n0 m) __ (hr __) + | _ -> compat n0 (min n0 m) __ (hl __)) + + (** val min_case : + n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) + + let min_case n0 m x x0 x1 = + min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) + + (** val min_dec : n -> n -> sumbool **) + + let min_dec n0 m = + min_case n0 m (fun x y _ h0 -> h0) Left Right + end + + (** val max_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) + + let max_case_strong n0 m x x0 = + Private_Dec.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 + + (** val max_case : n -> n -> 'a1 -> 'a1 -> 'a1 **) + + let max_case n0 m x x0 = + max_case_strong n0 m (fun _ -> x) (fun _ -> x0) + + (** val max_dec : n -> n -> sumbool **) + + let max_dec = + Private_Dec.max_dec + + (** val min_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) + + let min_case_strong n0 m x x0 = + Private_Dec.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 + + (** val min_case : n -> n -> 'a1 -> 'a1 -> 'a1 **) + + let min_case n0 m x x0 = + min_case_strong n0 m (fun _ -> x) (fun _ -> x0) + + (** val min_dec : n -> n -> sumbool **) + + let min_dec = + Private_Dec.min_dec + end + +module Z = + struct + type t = z + + (** val zero : z **) + + let zero = + Z0 + + (** val one : z **) + + let one = + Zpos XH + + (** val two : z **) + + let two = + Zpos (XO XH) + + (** val double : z -> z **) + + let double = function + | Z0 -> Z0 + | Zpos p -> Zpos (XO p) + | Zneg p -> Zneg (XO p) + + (** val succ_double : z -> z **) + + let succ_double = function + | Z0 -> Zpos XH + | Zpos p -> Zpos (XI p) + | Zneg p -> Zneg (Coq_Pos.pred_double p) + + (** val pred_double : z -> z **) + + let pred_double = function + | Z0 -> Zneg XH + | Zpos p -> Zpos (Coq_Pos.pred_double p) + | Zneg p -> Zneg (XI p) + + (** val pos_sub : positive -> positive -> z **) + + let rec pos_sub x y = + match x with + | XI p -> + (match y with + | XI q -> double (pos_sub p q) + | XO q -> succ_double (pos_sub p q) + | XH -> Zpos (XO p)) + | XO p -> + (match y with + | XI q -> pred_double (pos_sub p q) + | XO q -> double (pos_sub p q) + | XH -> Zpos (Coq_Pos.pred_double p)) + | XH -> + (match y with + | XI q -> Zneg (XO q) + | XO q -> Zneg (Coq_Pos.pred_double q) + | XH -> Z0) + + (** val add : z -> z -> z **) + + let add x y = + match x with + | Z0 -> y + | Zpos x' -> + (match y with + | Z0 -> x + | Zpos y' -> Zpos (Coq_Pos.add x' y') + | Zneg y' -> pos_sub x' y') + | Zneg x' -> + (match y with + | Z0 -> x + | Zpos y' -> pos_sub y' x' + | Zneg y' -> Zneg (Coq_Pos.add x' y')) + + (** val opp : z -> z **) + + let opp = function + | Z0 -> Z0 + | Zpos x0 -> Zneg x0 + | Zneg x0 -> Zpos x0 + + (** val succ : z -> z **) + + let succ x = + add x (Zpos XH) + + (** val pred : z -> z **) + + let pred x = + add x (Zneg XH) + + (** val sub : z -> z -> z **) + + let sub m n0 = + add m (opp n0) + + (** val mul : z -> z -> z **) + + let mul x y = + match x with + | Z0 -> Z0 + | Zpos x' -> + (match y with + | Z0 -> Z0 + | Zpos y' -> Zpos (Coq_Pos.mul x' y') + | Zneg y' -> Zneg (Coq_Pos.mul x' y')) + | Zneg x' -> + (match y with + | Z0 -> Z0 + | Zpos y' -> Zneg (Coq_Pos.mul x' y') + | Zneg y' -> Zpos (Coq_Pos.mul x' y')) + + (** val pow_pos : z -> positive -> z **) + + let pow_pos z0 n0 = + Coq_Pos.iter n0 (mul z0) (Zpos XH) + + (** val pow : z -> z -> z **) + + let pow x = function + | Z0 -> Zpos XH + | Zpos p -> pow_pos x p + | Zneg p -> Z0 + + (** val square : z -> z **) + + let square = function + | Z0 -> Z0 + | Zpos p -> Zpos (Coq_Pos.square p) + | Zneg p -> Zpos (Coq_Pos.square p) + + (** val compare : z -> z -> ExtrNative.comparison **) + + let compare x y = + match x with + | Z0 -> + (match y with + | Z0 -> ExtrNative.Eq + | Zpos y' -> ExtrNative.Lt + | Zneg y' -> ExtrNative.Gt) + | Zpos x' -> + (match y with + | Zpos y' -> Coq_Pos.compare x' y' + | _ -> ExtrNative.Gt) + | Zneg x' -> + (match y with + | Zneg y' -> compOpp (Coq_Pos.compare x' y') + | _ -> ExtrNative.Lt) + + (** val sgn : z -> z **) + + let sgn = function + | Z0 -> Z0 + | Zpos p -> Zpos XH + | Zneg p -> Zneg XH + + (** val leb : z -> z -> bool **) + + let leb x y = + match compare x y with + | ExtrNative.Gt -> false + | _ -> true + + (** val ltb : z -> z -> bool **) + + let ltb x y = + match compare x y with + | ExtrNative.Lt -> true + | _ -> false + + (** val geb : z -> z -> bool **) + + let geb x y = + match compare x y with + | ExtrNative.Lt -> false + | _ -> true + + (** val gtb : z -> z -> bool **) + + let gtb x y = + match compare x y with + | ExtrNative.Gt -> true + | _ -> false + + (** val eqb : z -> z -> bool **) + + let rec eqb x y = + match x with + | Z0 -> + (match y with + | Z0 -> true + | _ -> false) + | Zpos p -> + (match y with + | Zpos q -> Coq_Pos.eqb p q + | _ -> false) + | Zneg p -> + (match y with + | Zneg q -> Coq_Pos.eqb p q + | _ -> false) + + (** val max : z -> z -> z **) + + let max n0 m = + match compare n0 m with + | ExtrNative.Lt -> m + | _ -> n0 + + (** val min : z -> z -> z **) + + let min n0 m = + match compare n0 m with + | ExtrNative.Gt -> m + | _ -> n0 + + (** val abs : z -> z **) + + let abs = function + | Zneg p -> Zpos p + | x -> x + + (** val abs_nat : z -> nat **) + + let abs_nat = function + | Z0 -> O + | Zpos p -> Coq_Pos.to_nat p + | Zneg p -> Coq_Pos.to_nat p + + (** val abs_N : z -> n **) + + let abs_N = function + | Z0 -> N0 + | Zpos p -> Npos p + | Zneg p -> Npos p + + (** val to_nat : z -> nat **) + + let to_nat = function + | Zpos p -> Coq_Pos.to_nat p + | _ -> O + + (** val to_N : z -> n **) + + let to_N = function + | Zpos p -> Npos p + | _ -> N0 + + (** val of_nat : nat -> z **) + + let of_nat = function + | O -> Z0 + | S n1 -> Zpos (Coq_Pos.of_succ_nat n1) + + (** val of_N : n -> z **) + + let of_N = function + | N0 -> Z0 + | Npos p -> Zpos p + + (** val iter : z -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) + + let iter n0 f x = + match n0 with + | Zpos p -> Coq_Pos.iter p f x + | _ -> x + + (** val pos_div_eucl : positive -> z -> z*z **) + + let rec pos_div_eucl a b = + match a with + | XI a' -> + let q,r = pos_div_eucl a' b in + let r' = add (mul (Zpos (XO XH)) r) (Zpos XH) in + if ltb r' b + then (mul (Zpos (XO XH)) q),r' + else (add (mul (Zpos (XO XH)) q) (Zpos XH)),(sub r' b) + | XO a' -> + let q,r = pos_div_eucl a' b in + let r' = mul (Zpos (XO XH)) r in + if ltb r' b + then (mul (Zpos (XO XH)) q),r' + else (add (mul (Zpos (XO XH)) q) (Zpos XH)),(sub r' b) + | XH -> if leb (Zpos (XO XH)) b then Z0,(Zpos XH) else (Zpos XH),Z0 + + (** val div_eucl : z -> z -> z*z **) + + let div_eucl a b = + match a with + | Z0 -> Z0,Z0 + | Zpos a' -> + (match b with + | Z0 -> Z0,Z0 + | Zpos p -> pos_div_eucl a' b + | Zneg b' -> + let q,r = pos_div_eucl a' (Zpos b') in + (match r with + | Z0 -> (opp q),Z0 + | _ -> (opp (add q (Zpos XH))),(add b r))) + | Zneg a' -> + (match b with + | Z0 -> Z0,Z0 + | Zpos p -> + let q,r = pos_div_eucl a' b in + (match r with + | Z0 -> (opp q),Z0 + | _ -> (opp (add q (Zpos XH))),(sub b r)) + | Zneg b' -> let q,r = pos_div_eucl a' (Zpos b') in q,(opp r)) + + (** val div : z -> z -> z **) + + let div a b = + let q,x = div_eucl a b in q + + (** val modulo : z -> z -> z **) + + let modulo a b = + let x,r = div_eucl a b in r + + (** val quotrem : z -> z -> z*z **) + + let quotrem a b = + match a with + | Z0 -> Z0,Z0 + | Zpos a0 -> + (match b with + | Z0 -> Z0,a + | Zpos b0 -> + let q,r = N.pos_div_eucl a0 (Npos b0) in (of_N q),(of_N r) + | Zneg b0 -> + let q,r = N.pos_div_eucl a0 (Npos b0) in (opp (of_N q)),(of_N r)) + | Zneg a0 -> + (match b with + | Z0 -> Z0,a + | Zpos b0 -> + let q,r = N.pos_div_eucl a0 (Npos b0) in + (opp (of_N q)),(opp (of_N r)) + | Zneg b0 -> + let q,r = N.pos_div_eucl a0 (Npos b0) in (of_N q),(opp (of_N r))) + + (** val quot : z -> z -> z **) + + let quot a b = + fst (quotrem a b) + + (** val rem : z -> z -> z **) + + let rem a b = + snd (quotrem a b) + + (** val even : z -> bool **) + + let even = function + | Z0 -> true + | Zpos p -> + (match p with + | XO p2 -> true + | _ -> false) + | Zneg p -> + (match p with + | XO p2 -> true + | _ -> false) + + (** val odd : z -> bool **) + + let odd = function + | Z0 -> false + | Zpos p -> + (match p with + | XO p2 -> false + | _ -> true) + | Zneg p -> + (match p with + | XO p2 -> false + | _ -> true) + + (** val div2 : z -> z **) + + let div2 = function + | Z0 -> Z0 + | Zpos p -> + (match p with + | XH -> Z0 + | _ -> Zpos (Coq_Pos.div2 p)) + | Zneg p -> Zneg (Coq_Pos.div2_up p) + + (** val quot2 : z -> z **) + + let quot2 = function + | Z0 -> Z0 + | Zpos p -> + (match p with + | XH -> Z0 + | _ -> Zpos (Coq_Pos.div2 p)) + | Zneg p -> + (match p with + | XH -> Z0 + | _ -> Zneg (Coq_Pos.div2 p)) + + (** val log2 : z -> z **) + + let log2 = function + | Zpos p2 -> + (match p2 with + | XI p -> Zpos (Coq_Pos.size p) + | XO p -> Zpos (Coq_Pos.size p) + | XH -> Z0) + | _ -> Z0 + + (** val sqrtrem : z -> z*z **) + + let sqrtrem = function + | Zpos p -> + let s,m = Coq_Pos.sqrtrem p in + (match m with + | Coq_Pos.IsPos r -> (Zpos s),(Zpos r) + | _ -> (Zpos s),Z0) + | _ -> Z0,Z0 + + (** val sqrt : z -> z **) + + let sqrt = function + | Zpos p -> Zpos (Coq_Pos.sqrt p) + | _ -> Z0 + + (** val gcd : z -> z -> z **) + + let gcd a b = + match a with + | Z0 -> abs b + | Zpos a0 -> + (match b with + | Z0 -> abs a + | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0) + | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0)) + | Zneg a0 -> + (match b with + | Z0 -> abs a + | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0) + | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0)) + + (** val ggcd : z -> z -> z*(z*z) **) + + let ggcd a b = + match a with + | Z0 -> (abs b),(Z0,(sgn b)) + | Zpos a0 -> + (match b with + | Z0 -> (abs a),((sgn a),Z0) + | Zpos b0 -> + let g,p = Coq_Pos.ggcd a0 b0 in + let aa,bb = p in (Zpos g),((Zpos aa),(Zpos bb)) + | Zneg b0 -> + let g,p = Coq_Pos.ggcd a0 b0 in + let aa,bb = p in (Zpos g),((Zpos aa),(Zneg bb))) + | Zneg a0 -> + (match b with + | Z0 -> (abs a),((sgn a),Z0) + | Zpos b0 -> + let g,p = Coq_Pos.ggcd a0 b0 in + let aa,bb = p in (Zpos g),((Zneg aa),(Zpos bb)) + | Zneg b0 -> + let g,p = Coq_Pos.ggcd a0 b0 in + let aa,bb = p in (Zpos g),((Zneg aa),(Zneg bb))) + + (** val testbit : z -> z -> bool **) + + let testbit a = function + | Z0 -> odd a + | Zpos p -> + (match a with + | Z0 -> false + | Zpos a0 -> Coq_Pos.testbit a0 (Npos p) + | Zneg a0 -> negb (N.testbit (Coq_Pos.pred_N a0) (Npos p))) + | Zneg p -> false + + (** val shiftl : z -> z -> z **) + + let shiftl a = function + | Z0 -> a + | Zpos p -> Coq_Pos.iter p (mul (Zpos (XO XH))) a + | Zneg p -> Coq_Pos.iter p div2 a + + (** val shiftr : z -> z -> z **) + + let shiftr a n0 = + shiftl a (opp n0) + + (** val coq_lor : z -> z -> z **) + + let coq_lor a b = + match a with + | Z0 -> b + | Zpos a0 -> + (match b with + | Z0 -> a + | Zpos b0 -> Zpos (Coq_Pos.coq_lor a0 b0) + | Zneg b0 -> Zneg (N.succ_pos (N.ldiff (Coq_Pos.pred_N b0) (Npos a0)))) + | Zneg a0 -> + (match b with + | Z0 -> a + | Zpos b0 -> Zneg (N.succ_pos (N.ldiff (Coq_Pos.pred_N a0) (Npos b0))) + | Zneg b0 -> + Zneg + (N.succ_pos (N.coq_land (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0)))) + + (** val coq_land : z -> z -> z **) + + let coq_land a b = + match a with + | Z0 -> Z0 + | Zpos a0 -> + (match b with + | Z0 -> Z0 + | Zpos b0 -> of_N (Coq_Pos.coq_land a0 b0) + | Zneg b0 -> of_N (N.ldiff (Npos a0) (Coq_Pos.pred_N b0))) + | Zneg a0 -> + (match b with + | Z0 -> Z0 + | Zpos b0 -> of_N (N.ldiff (Npos b0) (Coq_Pos.pred_N a0)) + | Zneg b0 -> + Zneg + (N.succ_pos (N.coq_lor (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0)))) + + (** val ldiff : z -> z -> z **) + + let ldiff a b = + match a with + | Z0 -> Z0 + | Zpos a0 -> + (match b with + | Z0 -> a + | Zpos b0 -> of_N (Coq_Pos.ldiff a0 b0) + | Zneg b0 -> of_N (N.coq_land (Npos a0) (Coq_Pos.pred_N b0))) + | Zneg a0 -> + (match b with + | Z0 -> a + | Zpos b0 -> + Zneg (N.succ_pos (N.coq_lor (Coq_Pos.pred_N a0) (Npos b0))) + | Zneg b0 -> of_N (N.ldiff (Coq_Pos.pred_N b0) (Coq_Pos.pred_N a0))) + + (** val coq_lxor : z -> z -> z **) + + let coq_lxor a b = + match a with + | Z0 -> b + | Zpos a0 -> + (match b with + | Z0 -> a + | Zpos b0 -> of_N (Coq_Pos.coq_lxor a0 b0) + | Zneg b0 -> + Zneg (N.succ_pos (N.coq_lxor (Npos a0) (Coq_Pos.pred_N b0)))) + | Zneg a0 -> + (match b with + | Z0 -> a + | Zpos b0 -> + Zneg (N.succ_pos (N.coq_lxor (Coq_Pos.pred_N a0) (Npos b0))) + | Zneg b0 -> of_N (N.coq_lxor (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0))) + + (** val eq_dec : z -> z -> sumbool **) + + let eq_dec x y = + match x with + | Z0 -> + (match y with + | Z0 -> Left + | _ -> Right) + | Zpos x0 -> + (match y with + | Zpos p2 -> Coq_Pos.eq_dec x0 p2 + | _ -> Right) + | Zneg x0 -> + (match y with + | Zneg p2 -> Coq_Pos.eq_dec x0 p2 + | _ -> Right) + + module Private_BootStrap = + struct + + end + + (** val leb_spec0 : z -> z -> reflect **) + + let leb_spec0 x y = + iff_reflect (leb x y) + + (** val ltb_spec0 : z -> z -> reflect **) + + let ltb_spec0 x y = + iff_reflect (ltb x y) + + module Private_OrderTac = + struct + module Elts = + struct + type t = z + end + + module Tac = MakeOrderTac(Elts) + end + + (** val sqrt_up : z -> z **) + + let sqrt_up a = + match compare Z0 a with + | ExtrNative.Lt -> succ (sqrt (pred a)) + | _ -> Z0 + + (** val log2_up : z -> z **) + + let log2_up a = + match compare (Zpos XH) a with + | ExtrNative.Lt -> succ (log2 (pred a)) + | _ -> Z0 + + module Private_NZDiv = + struct + + end + + module Private_Div = + struct + module Quot2Div = + struct + (** val div : z -> z -> z **) + + let div = + quot + + (** val modulo : z -> z -> z **) + + let modulo = + rem + end + + module NZQuot = + struct + + end + end + + (** val lcm : z -> z -> z **) + + let lcm a b = + abs (mul a (div b (gcd a b))) + + (** val eqb_spec : z -> z -> reflect **) + + let eqb_spec x y = + iff_reflect (eqb x y) + + (** val b2z : bool -> z **) + + let b2z = function + | true -> Zpos XH + | false -> Z0 + + (** val setbit : z -> z -> z **) + + let setbit a n0 = + coq_lor a (shiftl (Zpos XH) n0) + + (** val clearbit : z -> z -> z **) + + let clearbit a n0 = + ldiff a (shiftl (Zpos XH) n0) + + (** val lnot : z -> z **) + + let lnot a = + pred (opp a) + + (** val ones : z -> z **) + + let ones n0 = + pred (shiftl (Zpos XH) n0) + + module Private_Tac = + struct + + end + + module Private_Rev = + struct + module ORev = + struct + type t = z + end + + module MRev = + struct + (** val max : z -> z -> z **) + + let max x y = + min y x + end + + module MPRev = MaxLogicalProperties(ORev)(MRev) + end + + module Private_Dec = + struct + (** val max_case_strong : + z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> 'a1 **) + + let max_case_strong n0 m compat hl hr = + let c = compSpec2Type n0 m (compare n0 m) in + (match c with + | CompGtT -> compat n0 (max n0 m) __ (hl __) + | _ -> compat m (max n0 m) __ (hr __)) + + (** val max_case : + z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) + + let max_case n0 m x x0 x1 = + max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) + + (** val max_dec : z -> z -> sumbool **) + + let max_dec n0 m = + max_case n0 m (fun x y _ h0 -> h0) Left Right + + (** val min_case_strong : + z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> 'a1 **) + + let min_case_strong n0 m compat hl hr = + let c = compSpec2Type n0 m (compare n0 m) in + (match c with + | CompGtT -> compat m (min n0 m) __ (hr __) + | _ -> compat n0 (min n0 m) __ (hl __)) + + (** val min_case : + z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) + + let min_case n0 m x x0 x1 = + min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) + + (** val min_dec : z -> z -> sumbool **) + + let min_dec n0 m = + min_case n0 m (fun x y _ h0 -> h0) Left Right + end + + (** val max_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) + + let max_case_strong n0 m x x0 = + Private_Dec.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 + + (** val max_case : z -> z -> 'a1 -> 'a1 -> 'a1 **) + + let max_case n0 m x x0 = + max_case_strong n0 m (fun _ -> x) (fun _ -> x0) + + (** val max_dec : z -> z -> sumbool **) + + let max_dec = + Private_Dec.max_dec + + (** val min_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) + + let min_case_strong n0 m x x0 = + Private_Dec.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 + + (** val min_case : z -> z -> 'a1 -> 'a1 -> 'a1 **) + + let min_case n0 m x x0 = + min_case_strong n0 m (fun _ -> x) (fun _ -> x0) + + (** val min_dec : z -> z -> sumbool **) + + let min_dec = + Private_Dec.min_dec + end + +(** val zeq_bool : z -> z -> bool **) + +let zeq_bool x y = + match Z.compare x y with + | ExtrNative.Eq -> true + | _ -> false + +(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **) + +let rec nth n0 l default0 = + match n0 with + | O -> + (match l with + | Nil -> default0 + | Cons (x, l') -> x) + | S m -> + (match l with + | Nil -> default0 + | Cons (x, t0) -> nth m t0 default0) + +(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) + +let rec map f = function +| Nil -> Nil +| Cons (a, t0) -> Cons ((f a), (map f t0)) + +(** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **) + +let rec fold_right f a0 = function +| Nil -> a0 +| Cons (b, t0) -> f b (fold_right f a0 t0) + +(** val existsb : ('a1 -> bool) -> 'a1 list -> bool **) + +let rec existsb f = function +| Nil -> false +| Cons (a, l0) -> if f a then true else existsb f l0 + +(** val forallb : ('a1 -> bool) -> 'a1 list -> bool **) + +let rec forallb f = function +| Nil -> true +| Cons (a, l0) -> if f a then forallb f l0 else false + +type int = ExtrNative.uint + +(** val lsl0 : int -> int -> int **) + +let lsl0 = ExtrNative.l_sl + +(** val lsr0 : int -> int -> int **) + +let lsr0 = ExtrNative.l_sr + +(** val land0 : int -> int -> int **) + +let land0 = ExtrNative.l_and + +(** val lxor0 : int -> int -> int **) + +let lxor0 = ExtrNative.l_xor + +(** val sub0 : int -> int -> int **) + +let sub0 = ExtrNative.sub + +(** val eqb0 : int -> int -> bool **) + +let eqb0 = fun i j -> ExtrNative.compare i j = ExtrNative.Eq + +(** val ltb0 : int -> int -> bool **) + +let ltb0 = ExtrNative.lt + +(** val leb0 : int -> int -> bool **) + +let leb0 = ExtrNative.le + +(** val foldi_cont : + (int -> ('a1 -> 'a2) -> 'a1 -> 'a2) -> int -> int -> ('a1 -> 'a2) -> 'a1 + -> 'a2 **) + +let foldi_cont = ExtrNative.foldi_cont + +(** val foldi_down_cont : + (int -> ('a1 -> 'a2) -> 'a1 -> 'a2) -> int -> int -> ('a1 -> 'a2) -> 'a1 + -> 'a2 **) + +let foldi_down_cont = ExtrNative.foldi_down_cont + +(** val is_zero : int -> bool **) + +let is_zero i = + eqb0 i (ExtrNative.of_uint(0)) + +(** val is_even : int -> bool **) + +let is_even i = + is_zero (land0 i (ExtrNative.of_uint(1))) + +(** val compare0 : int -> int -> ExtrNative.comparison **) + +let compare0 = ExtrNative.compare + +(** val foldi : (int -> 'a1 -> 'a1) -> int -> int -> 'a1 -> 'a1 **) + +let foldi f from to0 = + foldi_cont (fun i cont a -> cont (f i a)) from to0 (fun a -> a) + +(** val fold : ('a1 -> 'a1) -> int -> int -> 'a1 -> 'a1 **) + +let fold f from to0 = + foldi_cont (fun i cont a -> cont (f a)) from to0 (fun a -> a) + +(** val foldi_down : (int -> 'a1 -> 'a1) -> int -> int -> 'a1 -> 'a1 **) + +let foldi_down f from downto0 = + foldi_down_cont (fun i cont a -> cont (f i a)) from downto0 (fun a -> a) + +(** val forallb0 : (int -> bool) -> int -> int -> bool **) + +let forallb0 f from to0 = + foldi_cont (fun i cont x -> if f i then cont Tt else false) from to0 + (fun x -> true) Tt + +(** val existsb0 : (int -> bool) -> int -> int -> bool **) + +let existsb0 f from to0 = + foldi_cont (fun i cont x -> if f i then true else cont Tt) from to0 + (fun x -> false) Tt + +(** val cast : int -> int -> (__ -> __ -> __) option **) + +let cast i j = + if eqb0 i j then Some (fun _ hi -> hi) else None + +(** val reflect_eqb : int -> int -> reflect **) + +let reflect_eqb i j = + iff_reflect (eqb0 i j) + +type 'a array = 'a ExtrNative.parray + +(** val make : int -> 'a1 -> 'a1 array **) + +let make = ExtrNative.parray_make + +module Coq__2 = struct + (** val get : 'a1 array -> int -> 'a1 **) + + let get = ExtrNative.parray_get +end +let get = Coq__2.get + +(** val default : 'a1 array -> 'a1 **) + +let default = ExtrNative.parray_default + +(** val set : 'a1 array -> int -> 'a1 -> 'a1 array **) + +let set = ExtrNative.parray_set + +(** val length : 'a1 array -> int **) + +let length = ExtrNative.parray_length + +(** val to_list : 'a1 array -> 'a1 list **) + +let to_list t0 = + let len = length t0 in + if eqb0 (ExtrNative.of_uint(0)) len + then Nil + else foldi_down (fun i l -> Cons ((get t0 i), l)) + (sub0 len (ExtrNative.of_uint(1))) (ExtrNative.of_uint(0)) Nil + +(** val forallbi : (int -> 'a1 -> bool) -> 'a1 array -> bool **) + +let forallbi f t0 = + let len = length t0 in + if eqb0 (ExtrNative.of_uint(0)) len + then true + else forallb0 (fun i -> f i (get t0 i)) (ExtrNative.of_uint(0)) + (sub0 len (ExtrNative.of_uint(1))) + +(** val forallb1 : ('a1 -> bool) -> 'a1 array -> bool **) + +let forallb1 f t0 = + let len = length t0 in + if eqb0 (ExtrNative.of_uint(0)) len + then true + else forallb0 (fun i -> f (get t0 i)) (ExtrNative.of_uint(0)) + (sub0 len (ExtrNative.of_uint(1))) + +(** val existsb1 : ('a1 -> bool) -> 'a1 array -> bool **) + +let existsb1 f t0 = + let len = length t0 in + if eqb0 (ExtrNative.of_uint(0)) len + then false + else existsb0 (fun i -> f (get t0 i)) (ExtrNative.of_uint(0)) + (sub0 len (ExtrNative.of_uint(1))) + +(** val mapi : (int -> 'a1 -> 'a2) -> 'a1 array -> 'a2 array **) + +let mapi f t0 = + let size0 = length t0 in + let def = f size0 (default t0) in + let tb = make size0 def in + if eqb0 size0 (ExtrNative.of_uint(0)) + then tb + else foldi (fun i tb0 -> set tb0 i (f i (get t0 i))) + (ExtrNative.of_uint(0)) (sub0 size0 (ExtrNative.of_uint(1))) tb + +(** val foldi_left : + (int -> 'a1 -> 'a2 -> 'a1) -> 'a1 -> 'a2 array -> 'a1 **) + +let foldi_left f a t0 = + let len = length t0 in + if eqb0 (ExtrNative.of_uint(0)) len + then a + else foldi (fun i a0 -> f i a0 (get t0 i)) (ExtrNative.of_uint(0)) + (sub0 len (ExtrNative.of_uint(1))) a + +(** val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a1 -> 'a2 array -> 'a1 **) + +let fold_left f a t0 = + let len = length t0 in + if eqb0 (ExtrNative.of_uint(0)) len + then a + else foldi (fun i a0 -> f a0 (get t0 i)) (ExtrNative.of_uint(0)) + (sub0 (length t0) (ExtrNative.of_uint(1))) a + +(** val foldi_right : + (int -> 'a1 -> 'a2 -> 'a2) -> 'a1 array -> 'a2 -> 'a2 **) + +let foldi_right f t0 b = + let len = length t0 in + if eqb0 (ExtrNative.of_uint(0)) len + then b + else foldi_down (fun i b0 -> f i (get t0 i) b0) + (sub0 len (ExtrNative.of_uint(1))) (ExtrNative.of_uint(0)) b + +module Valuation = + struct + type t = int -> bool + end + +module Var = + struct + (** val _true : int **) + + let _true = + (ExtrNative.of_uint(0)) + + (** val _false : int **) + + let _false = + (ExtrNative.of_uint(1)) + + (** val interp : Valuation.t -> int -> bool **) + + let interp rho x = + rho x + end + +module Lit = + struct + (** val is_pos : int -> bool **) + + let is_pos l = + is_even l + + (** val blit : int -> int **) + + let blit l = + lsr0 l (ExtrNative.of_uint(1)) + + (** val lit : int -> int **) + + let lit x = + lsl0 x (ExtrNative.of_uint(1)) + + (** val neg : int -> int **) + + let neg l = + lxor0 l (ExtrNative.of_uint(1)) + + (** val nlit : int -> int **) + + let nlit x = + neg (lit x) + + (** val _true : int **) + + let _true = + (ExtrNative.of_uint(0)) + + (** val _false : int **) + + let _false = + (ExtrNative.of_uint(2)) + + (** val eqb : int -> int -> bool **) + + let eqb l l' = + eqb0 l l' + + (** val interp : Valuation.t -> int -> bool **) + + let interp rho l = + if is_pos l + then Var.interp rho (blit l) + else negb (Var.interp rho (blit l)) + end + +module C = + struct + type t = int list + + (** val interp : Valuation.t -> t -> bool **) + + let interp rho l = + existsb (Lit.interp rho) l + + (** val _true : t **) + + let _true = + Cons (Lit._true, Nil) + + (** val is_false : t -> bool **) + + let is_false = function + | Nil -> true + | Cons (i, l) -> false + + (** val or_aux : (t -> t -> t) -> int -> t -> t -> int list **) + + let rec or_aux or0 l1 c1 c2 = match c2 with + | Nil -> Cons (l1, c1) + | Cons (l2, c2') -> + (match compare0 l1 l2 with + | ExtrNative.Eq -> Cons (l1, (or0 c1 c2')) + | ExtrNative.Lt -> Cons (l1, (or0 c1 c2)) + | ExtrNative.Gt -> Cons (l2, (or_aux or0 l1 c1 c2'))) + + (** val coq_or : t -> t -> t **) + + let rec coq_or c1 c2 = + match c1 with + | Nil -> c2 + | Cons (l1, c3) -> + (match c2 with + | Nil -> c1 + | Cons (l2, c2') -> + (match compare0 l1 l2 with + | ExtrNative.Eq -> Cons (l1, (coq_or c3 c2')) + | ExtrNative.Lt -> Cons (l1, (coq_or c3 c2)) + | ExtrNative.Gt -> Cons (l2, (or_aux coq_or l1 c3 c2')))) + + (** val resolve_aux : (t -> t -> t) -> int -> t -> t -> t **) + + let rec resolve_aux resolve0 l1 c1 c2 = match c2 with + | Nil -> _true + | Cons (l2, c2') -> + (match compare0 l1 l2 with + | ExtrNative.Eq -> Cons (l1, (resolve0 c1 c2')) + | ExtrNative.Lt -> + if eqb0 (lxor0 l1 l2) (ExtrNative.of_uint(1)) + then coq_or c1 c2' + else Cons (l1, (resolve0 c1 c2)) + | ExtrNative.Gt -> + if eqb0 (lxor0 l1 l2) (ExtrNative.of_uint(1)) + then coq_or c1 c2' + else Cons (l2, (resolve_aux resolve0 l1 c1 c2'))) + + (** val resolve : t -> t -> t **) + + let rec resolve c1 c2 = + match c1 with + | Nil -> _true + | Cons (l1, c3) -> + (match c2 with + | Nil -> _true + | Cons (l2, c2') -> + (match compare0 l1 l2 with + | ExtrNative.Eq -> Cons (l1, (resolve c3 c2')) + | ExtrNative.Lt -> + if eqb0 (lxor0 l1 l2) (ExtrNative.of_uint(1)) + then coq_or c3 c2' + else Cons (l1, (resolve c3 c2)) + | ExtrNative.Gt -> + if eqb0 (lxor0 l1 l2) (ExtrNative.of_uint(1)) + then coq_or c3 c2' + else Cons (l2, (resolve_aux resolve l1 c3 c2')))) + end + +module S = + struct + type t = C.t array + + (** val get : t -> int -> C.t **) + + let get s cid = + get s cid + + (** val internal_set : t -> int -> C.t -> t **) + + let internal_set s cid c = + set s cid c + + (** val make : int -> t **) + + let make nclauses = + make nclauses C._true + + (** val insert : int -> int list -> int list **) + + let rec insert l1 c = match c with + | Nil -> Cons (l1, Nil) + | Cons (l2, c') -> + (match compare0 l1 l2 with + | ExtrNative.Eq -> c + | ExtrNative.Lt -> + if eqb0 (lxor0 l1 l2) (ExtrNative.of_uint(1)) + then C._true + else Cons (l1, c) + | ExtrNative.Gt -> + if eqb0 (lxor0 l1 l2) (ExtrNative.of_uint(1)) + then C._true + else Cons (l2, (insert l1 c'))) + + (** val sort_uniq : int list -> int list **) + + let rec sort_uniq = function + | Nil -> Nil + | Cons (l1, c0) -> insert l1 (sort_uniq c0) + + (** val set_clause : t -> int -> C.t -> t **) + + let set_clause s pos c = + set s pos (sort_uniq c) + + (** val set_resolve : t -> int -> int array -> t **) + + let set_resolve s pos r = + let len = length r in + if eqb0 len (ExtrNative.of_uint(0)) + then s + else let c = + foldi (fun i c -> C.resolve (get s (Coq__2.get r i)) c) + (ExtrNative.of_uint(1)) (sub0 len (ExtrNative.of_uint(1))) + (get s (Coq__2.get r (ExtrNative.of_uint(0)))) + in + internal_set s pos c + end + +(** val afold_left : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a2 -> 'a1) -> 'a2 array -> 'a1 **) + +let afold_left default0 oP f v = + let n0 = length v in + if eqb0 n0 (ExtrNative.of_uint(0)) + then default0 + else foldi (fun i a -> oP a (f (get v i))) (ExtrNative.of_uint(1)) + (sub0 n0 (ExtrNative.of_uint(1))) + (f (get v (ExtrNative.of_uint(0)))) + +(** val afold_right : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a2 -> 'a1) -> 'a2 array -> 'a1 **) + +let afold_right default0 oP f v = + let n0 = length v in + if eqb0 n0 (ExtrNative.of_uint(0)) + then default0 + else if leb0 n0 (ExtrNative.of_uint(1)) + then f (get v (ExtrNative.of_uint(0))) + else foldi_down (fun i b -> oP (f (get v i)) b) + (sub0 n0 (ExtrNative.of_uint(2))) (ExtrNative.of_uint(0)) + (f (get v (sub0 n0 (ExtrNative.of_uint(1))))) + +(** val rev_aux : 'a1 list -> 'a1 list -> 'a1 list **) + +let rec rev_aux acc = function +| Nil -> acc +| Cons (t0, q) -> rev_aux (Cons (t0, acc)) q + +(** val rev : 'a1 list -> 'a1 list **) + +let rev l = + rev_aux Nil l + +(** val distinct_aux2 : + ('a1 -> 'a1 -> bool) -> bool -> 'a1 -> 'a1 list -> bool **) + +let rec distinct_aux2 eq acc ref = function +| Nil -> acc +| Cons (t0, q) -> + distinct_aux2 eq (if acc then negb (eq ref t0) else false) ref q + +(** val distinct_aux : ('a1 -> 'a1 -> bool) -> bool -> 'a1 list -> bool **) + +let rec distinct_aux eq acc = function +| Nil -> acc +| Cons (t0, q) -> + let acc' = distinct_aux2 eq acc t0 q in distinct_aux eq acc' q + +(** val distinct : ('a1 -> 'a1 -> bool) -> 'a1 list -> bool **) + +let distinct eq = + distinct_aux eq true + +(** val forallb2 : ('a1 -> 'a2 -> bool) -> 'a1 list -> 'a2 list -> bool **) + +let rec forallb2 f l1 l2 = + match l1 with + | Nil -> + (match l2 with + | Nil -> true + | Cons (y, l) -> false) + | Cons (a, l3) -> + (match l2 with + | Nil -> false + | Cons (b, l4) -> if f a b then forallb2 f l3 l4 else false) + +module Form = + struct + type form = + | Fatom of int + | Ftrue + | Ffalse + | Fnot2 of int * int + | Fand of int array + | For of int array + | Fimp of int array + | Fxor of int * int + | Fiff of int * int + | Fite of int * int * int + + (** val form_rect : + (int -> 'a1) -> 'a1 -> 'a1 -> (int -> int -> 'a1) -> (int array -> 'a1) + -> (int array -> 'a1) -> (int array -> 'a1) -> (int -> int -> 'a1) -> + (int -> int -> 'a1) -> (int -> int -> int -> 'a1) -> form -> 'a1 **) + + let form_rect f f0 f1 f2 f3 f4 f5 f6 f7 f8 = function + | Fatom x -> f x + | Ftrue -> f0 + | Ffalse -> f1 + | Fnot2 (x, x0) -> f2 x x0 + | Fand x -> f3 x + | For x -> f4 x + | Fimp x -> f5 x + | Fxor (x, x0) -> f6 x x0 + | Fiff (x, x0) -> f7 x x0 + | Fite (x, x0, x1) -> f8 x x0 x1 + + (** val form_rec : + (int -> 'a1) -> 'a1 -> 'a1 -> (int -> int -> 'a1) -> (int array -> 'a1) + -> (int array -> 'a1) -> (int array -> 'a1) -> (int -> int -> 'a1) -> + (int -> int -> 'a1) -> (int -> int -> int -> 'a1) -> form -> 'a1 **) + + let form_rec f f0 f1 f2 f3 f4 f5 f6 f7 f8 = function + | Fatom x -> f x + | Ftrue -> f0 + | Ffalse -> f1 + | Fnot2 (x, x0) -> f2 x x0 + | Fand x -> f3 x + | For x -> f4 x + | Fimp x -> f5 x + | Fxor (x, x0) -> f6 x x0 + | Fiff (x, x0) -> f7 x x0 + | Fite (x, x0, x1) -> f8 x x0 x1 + + (** val is_Ftrue : form -> bool **) + + let is_Ftrue = function + | Ftrue -> true + | _ -> false + + (** val is_Ffalse : form -> bool **) + + let is_Ffalse = function + | Ffalse -> true + | _ -> false + + (** val interp_aux : (int -> bool) -> (int -> bool) -> form -> bool **) + + let interp_aux interp_atom interp_var = function + | Fatom a -> interp_atom a + | Ftrue -> true + | Ffalse -> false + | Fnot2 (i, l) -> + fold (fun b -> negb (negb b)) (ExtrNative.of_uint(1)) i + (Lit.interp interp_var l) + | Fand args -> + afold_left true (fun b1 b2 -> if b1 then b2 else false) + (Lit.interp interp_var) args + | For args -> + afold_left false (fun b1 b2 -> if b1 then true else b2) + (Lit.interp interp_var) args + | Fimp args -> afold_right true implb (Lit.interp interp_var) args + | Fxor (a, b) -> xorb (Lit.interp interp_var a) (Lit.interp interp_var b) + | Fiff (a, b) -> eqb (Lit.interp interp_var a) (Lit.interp interp_var b) + | Fite (a, b, c) -> + if Lit.interp interp_var a + then Lit.interp interp_var b + else Lit.interp interp_var c + + (** val t_interp : (int -> bool) -> form array -> bool array **) + + let t_interp interp_atom t_form = + foldi_left (fun i t_b hf -> + set t_b i (interp_aux interp_atom (get t_b) hf)) + (make (length t_form) true) t_form + + (** val lt_form : int -> form -> bool **) + + let rec lt_form i = function + | Fnot2 (i0, l) -> ltb0 (Lit.blit l) i + | Fand args -> forallb1 (fun l -> ltb0 (Lit.blit l) i) args + | For args -> forallb1 (fun l -> ltb0 (Lit.blit l) i) args + | Fimp args -> forallb1 (fun l -> ltb0 (Lit.blit l) i) args + | Fxor (a, b) -> if ltb0 (Lit.blit a) i then ltb0 (Lit.blit b) i else false + | Fiff (a, b) -> if ltb0 (Lit.blit a) i then ltb0 (Lit.blit b) i else false + | Fite (a, b, c) -> + if if ltb0 (Lit.blit a) i then ltb0 (Lit.blit b) i else false + then ltb0 (Lit.blit c) i + else false + | _ -> true + + (** val wf : form array -> bool **) + + let wf t_form = + forallbi lt_form t_form + + (** val interp_state_var : (int -> bool) -> form array -> int -> bool **) + + let interp_state_var interp_atom t_form = + let t_interp0 = t_interp interp_atom t_form in get t_interp0 + + (** val interp : (int -> bool) -> form array -> form -> bool **) + + let interp interp_atom t_form = + interp_aux interp_atom (interp_state_var interp_atom t_form) + + (** val check_form : form array -> bool **) + + let check_form t_form = + if if if is_Ftrue (default t_form) + then is_Ftrue (get t_form (ExtrNative.of_uint(0))) + else false + then is_Ffalse (get t_form (ExtrNative.of_uint(1))) + else false + then wf t_form + else false + end + +type typ_eqb = { te_eqb : (__ -> __ -> bool); + te_reflect : (__ -> __ -> reflect) } + +type te_carrier = __ + +(** val te_eqb : typ_eqb -> te_carrier -> te_carrier -> bool **) + +let te_eqb x = x.te_eqb + +module Typ = + struct + type coq_type = + | Tindex of int + | TZ + | Tbool + | Tpositive + + (** val type_rect : + (int -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> coq_type -> 'a1 **) + + let type_rect f f0 f1 f2 = function + | Tindex x -> f x + | TZ -> f0 + | Tbool -> f1 + | Tpositive -> f2 + + (** val type_rec : (int -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> coq_type -> 'a1 **) + + let type_rec f f0 f1 f2 = function + | Tindex x -> f x + | TZ -> f0 + | Tbool -> f1 + | Tpositive -> f2 + + type ftype = coq_type list*coq_type + + type interp = __ + + type interp_ftype = __ + + (** val i_eqb : typ_eqb array -> coq_type -> interp -> interp -> bool **) + + let i_eqb t_i = function + | Tindex i -> (get t_i i).te_eqb + | TZ -> Obj.magic zeq_bool + | Tbool -> Obj.magic eqb + | Tpositive -> Obj.magic Coq_Pos.eqb + + (** val reflect_i_eqb : + typ_eqb array -> coq_type -> interp -> interp -> reflect **) + + let reflect_i_eqb t_i t0 x y = + iff_reflect (i_eqb t_i t0 x y) + + type cast_result = + | Cast of (__ -> __ -> __) + | NoCast + + (** val cast_result_rect : + coq_type -> coq_type -> ((__ -> __ -> __) -> 'a1) -> 'a1 -> cast_result + -> 'a1 **) + + let cast_result_rect a b f f0 = function + | Cast x -> f x + | NoCast -> f0 + + (** val cast_result_rec : + coq_type -> coq_type -> ((__ -> __ -> __) -> 'a1) -> 'a1 -> cast_result + -> 'a1 **) + + let cast_result_rec a b f f0 = function + | Cast x -> f x + | NoCast -> f0 + + (** val cast : coq_type -> coq_type -> cast_result **) + + let cast a b = + match a with + | Tindex i -> + (match b with + | Tindex j -> + (match cast i j with + | Some k -> Cast (fun _ -> k __) + | None -> NoCast) + | _ -> NoCast) + | TZ -> + (match b with + | TZ -> Cast (fun _ x -> x) + | _ -> NoCast) + | Tbool -> + (match b with + | Tbool -> Cast (fun _ x -> x) + | _ -> NoCast) + | Tpositive -> + (match b with + | Tpositive -> Cast (fun _ x -> x) + | _ -> NoCast) + + (** val eqb : coq_type -> coq_type -> bool **) + + let eqb a b = + match a with + | Tindex i -> + (match b with + | Tindex j -> eqb0 i j + | _ -> false) + | TZ -> + (match b with + | TZ -> true + | _ -> false) + | Tbool -> + (match b with + | Tbool -> true + | _ -> false) + | Tpositive -> + (match b with + | Tpositive -> true + | _ -> false) + + (** val reflect_eqb : coq_type -> coq_type -> reflect **) + + let reflect_eqb x y = + match x with + | Tindex i -> + (match y with + | Tindex i0 -> iff_reflect (eqb0 i i0) + | _ -> ReflectF) + | TZ -> + (match y with + | TZ -> ReflectT + | _ -> ReflectF) + | Tbool -> + (match y with + | Tbool -> ReflectT + | _ -> ReflectF) + | Tpositive -> + (match y with + | Tpositive -> ReflectT + | _ -> ReflectF) + end + +(** val list_beq : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list -> bool **) + +let rec list_beq eq_A x y = + match x with + | Nil -> + (match y with + | Nil -> true + | Cons (a, l) -> false) + | Cons (x0, x1) -> + (match y with + | Nil -> false + | Cons (x2, x3) -> if eq_A x0 x2 then list_beq eq_A x1 x3 else false) + +(** val reflect_list_beq : + ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> reflect) -> 'a1 list -> 'a1 list + -> reflect **) + +let rec reflect_list_beq beq hbeq x y = + match x with + | Nil -> + (match y with + | Nil -> ReflectT + | Cons (a, y0) -> ReflectF) + | Cons (y0, l) -> + (match y with + | Nil -> ReflectF + | Cons (a0, y1) -> + let r = hbeq y0 a0 in + (match r with + | ReflectT -> reflect_list_beq beq hbeq l y1 + | ReflectF -> ReflectF)) + +module Atom = + struct + type cop = + | CO_xH + | CO_Z0 + + (** val cop_rect : 'a1 -> 'a1 -> cop -> 'a1 **) + + let cop_rect f f0 = function + | CO_xH -> f + | CO_Z0 -> f0 + + (** val cop_rec : 'a1 -> 'a1 -> cop -> 'a1 **) + + let cop_rec f f0 = function + | CO_xH -> f + | CO_Z0 -> f0 + + type unop = + | UO_xO + | UO_xI + | UO_Zpos + | UO_Zneg + | UO_Zopp + + (** val unop_rect : 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> unop -> 'a1 **) + + let unop_rect f f0 f1 f2 f3 = function + | UO_xO -> f + | UO_xI -> f0 + | UO_Zpos -> f1 + | UO_Zneg -> f2 + | UO_Zopp -> f3 + + (** val unop_rec : 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> unop -> 'a1 **) + + let unop_rec f f0 f1 f2 f3 = function + | UO_xO -> f + | UO_xI -> f0 + | UO_Zpos -> f1 + | UO_Zneg -> f2 + | UO_Zopp -> f3 + + type binop = + | BO_Zplus + | BO_Zminus + | BO_Zmult + | BO_Zlt + | BO_Zle + | BO_Zge + | BO_Zgt + | BO_eq of Typ.coq_type + + (** val binop_rect : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> (Typ.coq_type -> 'a1) + -> binop -> 'a1 **) + + let binop_rect f f0 f1 f2 f3 f4 f5 f6 = function + | BO_Zplus -> f + | BO_Zminus -> f0 + | BO_Zmult -> f1 + | BO_Zlt -> f2 + | BO_Zle -> f3 + | BO_Zge -> f4 + | BO_Zgt -> f5 + | BO_eq x -> f6 x + + (** val binop_rec : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> (Typ.coq_type -> 'a1) + -> binop -> 'a1 **) + + let binop_rec f f0 f1 f2 f3 f4 f5 f6 = function + | BO_Zplus -> f + | BO_Zminus -> f0 + | BO_Zmult -> f1 + | BO_Zlt -> f2 + | BO_Zle -> f3 + | BO_Zge -> f4 + | BO_Zgt -> f5 + | BO_eq x -> f6 x + + type nop = + Typ.coq_type + (* singleton inductive, whose constructor was NO_distinct *) + + (** val nop_rect : (Typ.coq_type -> 'a1) -> nop -> 'a1 **) + + let nop_rect f n0 = + f n0 + + (** val nop_rec : (Typ.coq_type -> 'a1) -> nop -> 'a1 **) + + let nop_rec f n0 = + f n0 + + type atom = + | Acop of cop + | Auop of unop * int + | Abop of binop * int * int + | Anop of nop * int list + | Aapp of int * int list + + (** val atom_rect : + (cop -> 'a1) -> (unop -> int -> 'a1) -> (binop -> int -> int -> 'a1) -> + (nop -> int list -> 'a1) -> (int -> int list -> 'a1) -> atom -> 'a1 **) + + let atom_rect f f0 f1 f2 f3 = function + | Acop x -> f x + | Auop (x, x0) -> f0 x x0 + | Abop (x, x0, x1) -> f1 x x0 x1 + | Anop (x, x0) -> f2 x x0 + | Aapp (x, x0) -> f3 x x0 + + (** val atom_rec : + (cop -> 'a1) -> (unop -> int -> 'a1) -> (binop -> int -> int -> 'a1) -> + (nop -> int list -> 'a1) -> (int -> int list -> 'a1) -> atom -> 'a1 **) + + let atom_rec f f0 f1 f2 f3 = function + | Acop x -> f x + | Auop (x, x0) -> f0 x x0 + | Abop (x, x0, x1) -> f1 x x0 x1 + | Anop (x, x0) -> f2 x x0 + | Aapp (x, x0) -> f3 x x0 + + (** val cop_eqb : cop -> cop -> bool **) + + let cop_eqb o o' = + match o with + | CO_xH -> + (match o' with + | CO_xH -> true + | CO_Z0 -> false) + | CO_Z0 -> + (match o' with + | CO_xH -> false + | CO_Z0 -> true) + + (** val uop_eqb : unop -> unop -> bool **) + + let uop_eqb o o' = + match o with + | UO_xO -> + (match o' with + | UO_xO -> true + | _ -> false) + | UO_xI -> + (match o' with + | UO_xI -> true + | _ -> false) + | UO_Zpos -> + (match o' with + | UO_Zpos -> true + | _ -> false) + | UO_Zneg -> + (match o' with + | UO_Zneg -> true + | _ -> false) + | UO_Zopp -> + (match o' with + | UO_Zopp -> true + | _ -> false) + + (** val bop_eqb : binop -> binop -> bool **) + + let bop_eqb o o' = + match o with + | BO_Zplus -> + (match o' with + | BO_Zplus -> true + | _ -> false) + | BO_Zminus -> + (match o' with + | BO_Zminus -> true + | _ -> false) + | BO_Zmult -> + (match o' with + | BO_Zmult -> true + | _ -> false) + | BO_Zlt -> + (match o' with + | BO_Zlt -> true + | _ -> false) + | BO_Zle -> + (match o' with + | BO_Zle -> true + | _ -> false) + | BO_Zge -> + (match o' with + | BO_Zge -> true + | _ -> false) + | BO_Zgt -> + (match o' with + | BO_Zgt -> true + | _ -> false) + | BO_eq t0 -> + (match o' with + | BO_eq t' -> Typ.eqb t0 t' + | _ -> false) + + (** val nop_eqb : nop -> nop -> bool **) + + let nop_eqb o o' = + Typ.eqb o o' + + (** val eqb : atom -> atom -> bool **) + + let eqb t0 t' = + match t0 with + | Acop o -> + (match t' with + | Acop o' -> cop_eqb o o' + | _ -> false) + | Auop (o, t1) -> + (match t' with + | Auop (o', t'0) -> if uop_eqb o o' then eqb0 t1 t'0 else false + | _ -> false) + | Abop (o, t1, t2) -> + (match t' with + | Abop (o', t1', t2') -> + if if bop_eqb o o' then eqb0 t1 t1' else false + then eqb0 t2 t2' + else false + | _ -> false) + | Anop (o, t1) -> + (match t' with + | Anop (o', t'0) -> + if nop_eqb o o' then list_beq eqb0 t1 t'0 else false + | _ -> false) + | Aapp (a, la) -> + (match t' with + | Aapp (b, lb) -> if eqb0 a b then list_beq eqb0 la lb else false + | _ -> false) + + (** val reflect_cop_eqb : cop -> cop -> reflect **) + + let reflect_cop_eqb o1 o2 = + match o1 with + | CO_xH -> + (match o2 with + | CO_xH -> ReflectT + | CO_Z0 -> ReflectF) + | CO_Z0 -> + (match o2 with + | CO_xH -> ReflectF + | CO_Z0 -> ReflectT) + + (** val reflect_uop_eqb : unop -> unop -> reflect **) + + let reflect_uop_eqb o1 o2 = + match o1 with + | UO_xO -> + (match o2 with + | UO_xO -> ReflectT + | _ -> ReflectF) + | UO_xI -> + (match o2 with + | UO_xI -> ReflectT + | _ -> ReflectF) + | UO_Zpos -> + (match o2 with + | UO_Zpos -> ReflectT + | _ -> ReflectF) + | UO_Zneg -> + (match o2 with + | UO_Zneg -> ReflectT + | _ -> ReflectF) + | UO_Zopp -> + (match o2 with + | UO_Zopp -> ReflectT + | _ -> ReflectF) + + (** val reflect_bop_eqb : binop -> binop -> reflect **) + + let reflect_bop_eqb o1 o2 = + match o1 with + | BO_Zplus -> + (match o2 with + | BO_Zplus -> ReflectT + | _ -> ReflectF) + | BO_Zminus -> + (match o2 with + | BO_Zminus -> ReflectT + | _ -> ReflectF) + | BO_Zmult -> + (match o2 with + | BO_Zmult -> ReflectT + | _ -> ReflectF) + | BO_Zlt -> + (match o2 with + | BO_Zlt -> ReflectT + | _ -> ReflectF) + | BO_Zle -> + (match o2 with + | BO_Zle -> ReflectT + | _ -> ReflectF) + | BO_Zge -> + (match o2 with + | BO_Zge -> ReflectT + | _ -> ReflectF) + | BO_Zgt -> + (match o2 with + | BO_Zgt -> ReflectT + | _ -> ReflectF) + | BO_eq t0 -> + (match o2 with + | BO_eq t1 -> Typ.reflect_eqb t0 t1 + | _ -> ReflectF) + + (** val reflect_nop_eqb : nop -> nop -> reflect **) + + let reflect_nop_eqb o1 o2 = + Typ.reflect_eqb o1 o2 + + (** val reflect_eqb : atom -> atom -> reflect **) + + let reflect_eqb t1 t2 = + match t1 with + | Acop c -> + (match t2 with + | Acop c0 -> reflect_cop_eqb c c0 + | _ -> ReflectF) + | Auop (u, i) -> + (match t2 with + | Auop (u0, i0) -> + let r = reflect_uop_eqb u u0 in + (match r with + | ReflectT -> reflect_eqb i i0 + | ReflectF -> ReflectF) + | _ -> ReflectF) + | Abop (b, i, i0) -> + (match t2 with + | Abop (b0, i1, i2) -> + let r = reflect_bop_eqb b b0 in + (match r with + | ReflectT -> + let r0 = reflect_eqb i i1 in + (match r0 with + | ReflectT -> reflect_eqb i0 i2 + | ReflectF -> ReflectF) + | ReflectF -> ReflectF) + | _ -> ReflectF) + | Anop (n0, l) -> + (match t2 with + | Anop (n1, l0) -> + let r = reflect_nop_eqb n0 n1 in + (match r with + | ReflectT -> reflect_list_beq eqb0 reflect_eqb l l0 + | ReflectF -> ReflectF) + | _ -> ReflectF) + | Aapp (i, l) -> + (match t2 with + | Aapp (i0, l0) -> + let r = reflect_eqb i i0 in + (match r with + | ReflectT -> reflect_list_beq eqb0 reflect_eqb l l0 + | ReflectF -> ReflectF) + | _ -> ReflectF) + + type ('t, 'i) coq_val = { v_type : 't; v_val : 'i } + + (** val val_rect : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) coq_val -> 'a3 **) + + let val_rect f v = + let { v_type = x; v_val = x0 } = v in f x x0 + + (** val val_rec : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) coq_val -> 'a3 **) + + let val_rec f v = + let { v_type = x; v_val = x0 } = v in f x x0 + + (** val v_type : ('a1, 'a2) coq_val -> 'a1 **) + + let v_type x = x.v_type + + (** val v_val : ('a1, 'a2) coq_val -> 'a2 **) + + let v_val x = x.v_val + + type bval = (Typ.coq_type, Typ.interp) coq_val + + (** val coq_Bval : + typ_eqb array -> Typ.coq_type -> Typ.interp -> (Typ.coq_type, + Typ.interp) coq_val **) + + let coq_Bval t_i x x0 = + { v_type = x; v_val = x0 } + + type tval = (Typ.ftype, Typ.interp_ftype) coq_val + + (** val coq_Tval : + typ_eqb array -> Typ.ftype -> Typ.interp_ftype -> (Typ.ftype, + Typ.interp_ftype) coq_val **) + + let coq_Tval t_i x x0 = + { v_type = x; v_val = x0 } + + (** val bvtrue : typ_eqb array -> bval **) + + let bvtrue t_i = + coq_Bval t_i Typ.Tbool (Obj.magic true) + + (** val bvfalse : typ_eqb array -> bval **) + + let bvfalse t_i = + coq_Bval t_i Typ.Tbool (Obj.magic false) + + (** val typ_cop : cop -> Typ.coq_type **) + + let typ_cop = function + | CO_xH -> Typ.Tpositive + | CO_Z0 -> Typ.TZ + + (** val typ_uop : unop -> Typ.coq_type*Typ.coq_type **) + + let typ_uop = function + | UO_xO -> Typ.Tpositive,Typ.Tpositive + | UO_xI -> Typ.Tpositive,Typ.Tpositive + | UO_Zopp -> Typ.TZ,Typ.TZ + | _ -> Typ.Tpositive,Typ.TZ + + (** val typ_bop : binop -> (Typ.coq_type*Typ.coq_type)*Typ.coq_type **) + + let typ_bop = function + | BO_Zplus -> (Typ.TZ,Typ.TZ),Typ.TZ + | BO_Zminus -> (Typ.TZ,Typ.TZ),Typ.TZ + | BO_Zmult -> (Typ.TZ,Typ.TZ),Typ.TZ + | BO_eq t0 -> (t0,t0),Typ.Tbool + | _ -> (Typ.TZ,Typ.TZ),Typ.Tbool + + (** val typ_nop : nop -> Typ.coq_type*Typ.coq_type **) + + let typ_nop o = + o,Typ.Tbool + + (** val check_args : + (int -> Typ.coq_type) -> int list -> Typ.coq_type list -> bool **) + + let rec check_args get_type0 args targs = + match args with + | Nil -> + (match targs with + | Nil -> true + | Cons (t0, l) -> false) + | Cons (a, args0) -> + (match targs with + | Nil -> false + | Cons (t0, targs0) -> + if Typ.eqb (get_type0 a) t0 + then check_args get_type0 args0 targs0 + else false) + + (** val check_aux : + typ_eqb array -> tval array -> (int -> Typ.coq_type) -> atom -> + Typ.coq_type -> bool **) + + let check_aux t_i t_func get_type0 a t0 = + match a with + | Acop o -> Typ.eqb (typ_cop o) t0 + | Auop (o, a0) -> + let ta,t' = typ_uop o in + if Typ.eqb t' t0 then Typ.eqb (get_type0 a0) ta else false + | Abop (o, a1, a2) -> + let ta,t' = typ_bop o in + let ta1,ta2 = ta in + if if Typ.eqb t' t0 then Typ.eqb (get_type0 a1) ta1 else false + then Typ.eqb (get_type0 a2) ta2 + else false + | Anop (o, a0) -> + let ta,t' = typ_nop o in + if Typ.eqb t' t0 + then forallb (fun t1 -> Typ.eqb (get_type0 t1) ta) a0 + else false + | Aapp (f, args) -> + let targs,tr = (get t_func f).v_type in + if check_args get_type0 args targs then Typ.eqb tr t0 else false + + (** val check_args_dec : + (int -> Typ.coq_type) -> Typ.coq_type -> int list -> Typ.coq_type list + -> sumbool **) + + let rec check_args_dec get_type0 a args targs = + match args with + | Nil -> + (match targs with + | Nil -> Left + | Cons (t0, l) -> Right) + | Cons (y, l) -> + (match targs with + | Nil -> Right + | Cons (b, targs0) -> + if Typ.eqb (get_type0 y) b + then check_args_dec get_type0 a l targs0 + else Right) + + (** val check_aux_dec : + typ_eqb array -> tval array -> (int -> Typ.coq_type) -> atom -> sumbool **) + + let check_aux_dec t_i t_func get_type0 = function + | Acop op -> Left + | Auop (op, h) -> + (match op with + | UO_Zopp -> if Typ.eqb (get_type0 h) Typ.TZ then Left else Right + | _ -> if Typ.eqb (get_type0 h) Typ.Tpositive then Left else Right) + | Abop (op, h1, h2) -> + (match op with + | BO_eq t0 -> + if Typ.eqb (get_type0 h1) t0 + then if Typ.eqb (get_type0 h2) t0 then Left else Right + else Right + | _ -> + if Typ.eqb (get_type0 h1) Typ.TZ + then if Typ.eqb (get_type0 h2) Typ.TZ then Left else Right + else Right) + | Anop (op, ha) -> + if forallb (fun t1 -> Typ.eqb (get_type0 t1) op) ha then Left else Right + | Aapp (f, args) -> + let l,t0 = (get t_func f).v_type in check_args_dec get_type0 t0 args l + + (** val apply_unop : + typ_eqb array -> Typ.coq_type -> Typ.coq_type -> (Typ.interp -> + Typ.interp) -> bval -> (Typ.coq_type, Typ.interp) coq_val **) + + let apply_unop t_i t0 r op tv = + let { v_type = t'; v_val = v } = tv in + (match Typ.cast t' t0 with + | Typ.Cast k -> coq_Bval t_i r (op (k __ v)) + | Typ.NoCast -> bvtrue t_i) + + (** val apply_binop : + typ_eqb array -> Typ.coq_type -> Typ.coq_type -> Typ.coq_type -> + (Typ.interp -> Typ.interp -> Typ.interp) -> bval -> bval -> + (Typ.coq_type, Typ.interp) coq_val **) + + let apply_binop t_i t1 t2 r op tv1 tv2 = + let { v_type = t1'; v_val = v1 } = tv1 in + let { v_type = t2'; v_val = v2 } = tv2 in + (match Typ.cast t1' t1 with + | Typ.Cast k1 -> + (match Typ.cast t2' t2 with + | Typ.Cast k2 -> coq_Bval t_i r (op (k1 __ v1) (k2 __ v2)) + | Typ.NoCast -> bvtrue t_i) + | Typ.NoCast -> bvtrue t_i) + + (** val apply_func : + typ_eqb array -> Typ.coq_type list -> Typ.coq_type -> Typ.interp_ftype + -> bval list -> bval **) + + let rec apply_func t_i targs tr f lv = + match targs with + | Nil -> + (match lv with + | Nil -> coq_Bval t_i tr f + | Cons (b, l) -> bvtrue t_i) + | Cons (t0, targs0) -> + (match lv with + | Nil -> bvtrue t_i + | Cons (v, lv0) -> + let { v_type = tv; v_val = v0 } = v in + (match Typ.cast tv t0 with + | Typ.Cast k -> + let f0 = Obj.magic f (k __ v0) in apply_func t_i targs0 tr f0 lv0 + | Typ.NoCast -> bvtrue t_i)) + + (** val interp_cop : + typ_eqb array -> cop -> (Typ.coq_type, Typ.interp) coq_val **) + + let interp_cop t_i = function + | CO_xH -> coq_Bval t_i Typ.Tpositive (Obj.magic XH) + | CO_Z0 -> coq_Bval t_i Typ.TZ (Obj.magic Z0) + + (** val interp_uop : + typ_eqb array -> unop -> bval -> (Typ.coq_type, Typ.interp) coq_val **) + + let interp_uop t_i = function + | UO_xO -> + apply_unop t_i Typ.Tpositive Typ.Tpositive (Obj.magic (fun x -> XO x)) + | UO_xI -> + apply_unop t_i Typ.Tpositive Typ.Tpositive (Obj.magic (fun x -> XI x)) + | UO_Zpos -> + apply_unop t_i Typ.Tpositive Typ.TZ (Obj.magic (fun x -> Zpos x)) + | UO_Zneg -> + apply_unop t_i Typ.Tpositive Typ.TZ (Obj.magic (fun x -> Zneg x)) + | UO_Zopp -> apply_unop t_i Typ.TZ Typ.TZ (Obj.magic Z.opp) + + (** val interp_bop : + typ_eqb array -> binop -> bval -> bval -> (Typ.coq_type, Typ.interp) + coq_val **) + + let interp_bop t_i = function + | BO_Zplus -> apply_binop t_i Typ.TZ Typ.TZ Typ.TZ (Obj.magic Z.add) + | BO_Zminus -> apply_binop t_i Typ.TZ Typ.TZ Typ.TZ (Obj.magic Z.sub) + | BO_Zmult -> apply_binop t_i Typ.TZ Typ.TZ Typ.TZ (Obj.magic Z.mul) + | BO_Zlt -> apply_binop t_i Typ.TZ Typ.TZ Typ.Tbool (Obj.magic Z.ltb) + | BO_Zle -> apply_binop t_i Typ.TZ Typ.TZ Typ.Tbool (Obj.magic Z.leb) + | BO_Zge -> apply_binop t_i Typ.TZ Typ.TZ Typ.Tbool (Obj.magic Z.geb) + | BO_Zgt -> apply_binop t_i Typ.TZ Typ.TZ Typ.Tbool (Obj.magic Z.gtb) + | BO_eq t0 -> + apply_binop t_i t0 t0 Typ.Tbool (Obj.magic (Typ.i_eqb t_i t0)) + + (** val compute_interp : + typ_eqb array -> (int -> bval) -> Typ.coq_type -> Typ.interp list -> + int list -> Typ.interp list option **) + + let rec compute_interp t_i interp_hatom0 ty acc = function + | Nil -> Some acc + | Cons (a, q) -> + let { v_type = ta; v_val = va } = interp_hatom0 a in + (match Typ.cast ta ty with + | Typ.Cast ka -> + compute_interp t_i interp_hatom0 ty (Cons ((ka __ va), acc)) q + | Typ.NoCast -> None) + + (** val interp_aux : + typ_eqb array -> tval array -> (int -> bval) -> atom -> bval **) + + let interp_aux t_i t_func interp_hatom0 = function + | Acop o -> interp_cop t_i o + | Auop (o, a0) -> interp_uop t_i o (interp_hatom0 a0) + | Abop (o, a1, a2) -> + interp_bop t_i o (interp_hatom0 a1) (interp_hatom0 a2) + | Anop (n0, a0) -> + (match compute_interp t_i interp_hatom0 n0 Nil a0 with + | Some l -> + coq_Bval t_i Typ.Tbool + (Obj.magic (distinct (Typ.i_eqb t_i n0) (rev l))) + | None -> bvtrue t_i) + | Aapp (f, args) -> + let { v_type = tf; v_val = f0 } = get t_func f in + let lv = map interp_hatom0 args in apply_func t_i (fst tf) (snd tf) f0 lv + + (** val interp_bool : typ_eqb array -> bval -> bool **) + + let interp_bool t_i v = + let { v_type = t0; v_val = v0 } = v in + (match Typ.cast t0 Typ.Tbool with + | Typ.Cast k -> Obj.magic k __ v0 + | Typ.NoCast -> true) + + (** val t_interp : + typ_eqb array -> tval array -> atom array -> bval array **) + + let t_interp t_i t_func t_atom = + foldi_left (fun i t_a a -> set t_a i (interp_aux t_i t_func (get t_a) a)) + (make (length t_atom) (interp_cop t_i CO_xH)) t_atom + + (** val lt_atom : int -> atom -> bool **) + + let lt_atom i = function + | Acop c -> true + | Auop (u, h) -> ltb0 h i + | Abop (b, h1, h2) -> if ltb0 h1 i then ltb0 h2 i else false + | Anop (n0, ha) -> forallb (fun h -> ltb0 h i) ha + | Aapp (f, args) -> forallb (fun h -> ltb0 h i) args + + (** val wf : atom array -> bool **) + + let wf t_atom = + forallbi lt_atom t_atom + + (** val get_type' : typ_eqb array -> bval array -> int -> Typ.coq_type **) + + let get_type' t_i t_interp' i = + (get t_interp' i).v_type + + (** val get_type : + typ_eqb array -> tval array -> atom array -> int -> Typ.coq_type **) + + let get_type t_i t_func t_atom = + get_type' t_i (t_interp t_i t_func t_atom) + + (** val wt : typ_eqb array -> tval array -> atom array -> bool **) + + let wt t_i t_func t_atom = + let t_interp0 = t_interp t_i t_func t_atom in + let get_type0 = get_type' t_i t_interp0 in + forallbi (fun i h -> check_aux t_i t_func get_type0 h (get_type0 i)) + t_atom + + (** val interp_hatom : + typ_eqb array -> tval array -> atom array -> int -> bval **) + + let interp_hatom t_i t_func t_atom = + let t_a = t_interp t_i t_func t_atom in get t_a + + (** val interp : + typ_eqb array -> tval array -> atom array -> atom -> bval **) + + let interp t_i t_func t_atom = + interp_aux t_i t_func (interp_hatom t_i t_func t_atom) + + (** val interp_form_hatom : + typ_eqb array -> tval array -> atom array -> int -> bool **) + + let interp_form_hatom t_i t_func t_atom = + let interp0 = interp_hatom t_i t_func t_atom in + (fun a -> interp_bool t_i (interp0 a)) + + (** val check_atom : atom array -> bool **) + + let check_atom t_atom = + match default t_atom with + | Acop c -> + (match c with + | CO_xH -> wf t_atom + | CO_Z0 -> false) + | _ -> false + end + +(** val or_of_imp : int array -> int array **) + +let or_of_imp args = + let last = sub0 (length args) (ExtrNative.of_uint(1)) in + mapi (fun i l -> if eqb0 i last then l else Lit.neg l) args + +(** val check_True : C.t **) + +let check_True = + C._true + +(** val check_False : int list **) + +let check_False = + Cons ((Lit.neg Lit._false), Nil) + +(** val check_BuildDef : Form.form array -> int -> C.t **) + +let check_BuildDef t_form l = + match get t_form (Lit.blit l) with + | Form.Fand args -> + if Lit.is_pos l then Cons (l, (map Lit.neg (to_list args))) else C._true + | Form.For args -> + if Lit.is_pos l then C._true else Cons (l, (to_list args)) + | Form.Fimp args -> + if Lit.is_pos l + then C._true + else let args0 = or_of_imp args in Cons (l, (to_list args0)) + | Form.Fxor (a, b) -> + if Lit.is_pos l + then Cons (l, (Cons (a, (Cons ((Lit.neg b), Nil))))) + else Cons (l, (Cons (a, (Cons (b, Nil))))) + | Form.Fiff (a, b) -> + if Lit.is_pos l + then Cons (l, (Cons ((Lit.neg a), (Cons ((Lit.neg b), Nil))))) + else Cons (l, (Cons (a, (Cons ((Lit.neg b), Nil))))) + | Form.Fite (a, b, c) -> + if Lit.is_pos l + then Cons (l, (Cons (a, (Cons ((Lit.neg c), Nil))))) + else Cons (l, (Cons (a, (Cons (c, Nil))))) + | _ -> C._true + +(** val check_ImmBuildDef : Form.form array -> S.t -> int -> C.t **) + +let check_ImmBuildDef t_form s pos = + match S.get s pos with + | Nil -> C._true + | Cons (l, l0) -> + (match l0 with + | Nil -> + (match get t_form (Lit.blit l) with + | Form.Fand args -> + if Lit.is_pos l then C._true else map Lit.neg (to_list args) + | Form.For args -> if Lit.is_pos l then to_list args else C._true + | Form.Fimp args -> + if Lit.is_pos l + then let args0 = or_of_imp args in to_list args0 + else C._true + | Form.Fxor (a, b) -> + if Lit.is_pos l + then Cons (a, (Cons (b, Nil))) + else Cons (a, (Cons ((Lit.neg b), Nil))) + | Form.Fiff (a, b) -> + if Lit.is_pos l + then Cons (a, (Cons ((Lit.neg b), Nil))) + else Cons ((Lit.neg a), (Cons ((Lit.neg b), Nil))) + | Form.Fite (a, b, c) -> + if Lit.is_pos l + then Cons (a, (Cons (c, Nil))) + else Cons (a, (Cons ((Lit.neg c), Nil))) + | _ -> C._true) + | Cons (i, l1) -> C._true) + +(** val check_BuildDef2 : Form.form array -> int -> C.t **) + +let check_BuildDef2 t_form l = + match get t_form (Lit.blit l) with + | Form.Fxor (a, b) -> + if Lit.is_pos l + then Cons (l, (Cons ((Lit.neg a), (Cons (b, Nil))))) + else Cons (l, (Cons ((Lit.neg a), (Cons ((Lit.neg b), Nil))))) + | Form.Fiff (a, b) -> + if Lit.is_pos l + then Cons (l, (Cons (a, (Cons (b, Nil))))) + else Cons (l, (Cons ((Lit.neg a), (Cons (b, Nil))))) + | Form.Fite (a, b, c) -> + if Lit.is_pos l + then Cons (l, (Cons ((Lit.neg a), (Cons ((Lit.neg b), Nil))))) + else Cons (l, (Cons ((Lit.neg a), (Cons (b, Nil))))) + | _ -> C._true + +(** val check_ImmBuildDef2 : Form.form array -> S.t -> int -> C.t **) + +let check_ImmBuildDef2 t_form s pos = + match S.get s pos with + | Nil -> C._true + | Cons (l, l0) -> + (match l0 with + | Nil -> + (match get t_form (Lit.blit l) with + | Form.Fxor (a, b) -> + if Lit.is_pos l + then Cons ((Lit.neg a), (Cons ((Lit.neg b), Nil))) + else Cons ((Lit.neg a), (Cons (b, Nil))) + | Form.Fiff (a, b) -> + if Lit.is_pos l + then Cons ((Lit.neg a), (Cons (b, Nil))) + else Cons (a, (Cons (b, Nil))) + | Form.Fite (a, b, c) -> + if Lit.is_pos l + then Cons ((Lit.neg a), (Cons (b, Nil))) + else Cons ((Lit.neg a), (Cons ((Lit.neg b), Nil))) + | _ -> C._true) + | Cons (i, l1) -> C._true) + +(** val check_BuildProj : Form.form array -> int -> int -> C.t **) + +let check_BuildProj t_form l i = + let x = Lit.blit l in + (match get t_form x with + | Form.Fand args -> + if ltb0 i (length args) + then Cons ((Lit.nlit x), (Cons ((get args i), Nil))) + else C._true + | Form.For args -> + if ltb0 i (length args) + then Cons ((Lit.lit x), (Cons ((Lit.neg (get args i)), Nil))) + else C._true + | Form.Fimp args -> + let len = length args in + if ltb0 i len + then if eqb0 i (sub0 len (ExtrNative.of_uint(1))) + then Cons ((Lit.lit x), (Cons ((Lit.neg (get args i)), Nil))) + else Cons ((Lit.lit x), (Cons ((get args i), Nil))) + else C._true + | _ -> C._true) + +(** val check_ImmBuildProj : Form.form array -> S.t -> int -> int -> C.t **) + +let check_ImmBuildProj t_form s pos i = + match S.get s pos with + | Nil -> C._true + | Cons (l, l0) -> + (match l0 with + | Nil -> + let x = Lit.blit l in + (match get t_form x with + | Form.Fand args -> + if if ltb0 i (length args) then Lit.is_pos l else false + then Cons ((get args i), Nil) + else C._true + | Form.For args -> + if if ltb0 i (length args) then negb (Lit.is_pos l) else false + then Cons ((Lit.neg (get args i)), Nil) + else C._true + | Form.Fimp args -> + let len = length args in + if if ltb0 i len then negb (Lit.is_pos l) else false + then if eqb0 i (sub0 len (ExtrNative.of_uint(1))) + then Cons ((Lit.neg (get args i)), Nil) + else Cons ((get args i), Nil) + else C._true + | _ -> C._true) + | Cons (i0, l1) -> C._true) + +(** val get_eq : + Form.form array -> Atom.atom array -> int -> (int -> int -> C.t) -> C.t **) + +let get_eq t_form t_atom x f = + match get t_form x with + | Form.Fatom xa -> + (match get t_atom xa with + | Atom.Abop (b0, a, b) -> + (match b0 with + | Atom.BO_eq t0 -> f a b + | _ -> C._true) + | _ -> C._true) + | _ -> C._true + +(** val check_trans_aux : + Form.form array -> Atom.atom array -> int -> int -> int list -> int -> + C.t -> C.t **) + +let rec check_trans_aux t_form t_atom t1 t2 eqs res clause0 = + match eqs with + | Nil -> + let xres = Lit.blit res in + get_eq t_form t_atom xres (fun t1' t2' -> + if if if eqb0 t1 t1' then eqb0 t2 t2' else false + then true + else if eqb0 t1 t2' then eqb0 t2 t1' else false + then Cons ((Lit.lit xres), clause0) + else C._true) + | Cons (leq, eqs0) -> + let xeq = Lit.blit leq in + get_eq t_form t_atom xeq (fun t0 t' -> + if eqb0 t2 t' + then check_trans_aux t_form t_atom t1 t0 eqs0 res (Cons + ((Lit.nlit xeq), clause0)) + else if eqb0 t2 t0 + then check_trans_aux t_form t_atom t1 t' eqs0 res (Cons + ((Lit.nlit xeq), clause0)) + else if eqb0 t1 t' + then check_trans_aux t_form t_atom t0 t2 eqs0 res (Cons + ((Lit.nlit xeq), clause0)) + else if eqb0 t1 t0 + then check_trans_aux t_form t_atom t' t2 eqs0 res (Cons + ((Lit.nlit xeq), clause0)) + else C._true) + +(** val check_trans : + Form.form array -> Atom.atom array -> int -> int list -> C.t **) + +let check_trans t_form t_atom res = function +| Nil -> + let xres = Lit.blit res in + get_eq t_form t_atom xres (fun t1 t2 -> + if eqb0 t1 t2 then Cons ((Lit.lit xres), Nil) else C._true) +| Cons (leq, eqs0) -> + let xeq = Lit.blit leq in + get_eq t_form t_atom xeq (fun t1 t2 -> + check_trans_aux t_form t_atom t1 t2 eqs0 res (Cons ((Lit.nlit xeq), Nil))) + +(** val build_congr : + Form.form array -> Atom.atom array -> int option list -> int list -> int + list -> C.t -> C.t **) + +let rec build_congr t_form t_atom eqs l r c = + match eqs with + | Nil -> + (match l with + | Nil -> + (match r with + | Nil -> c + | Cons (i, l0) -> C._true) + | Cons (i, l0) -> C._true) + | Cons (eq, eqs0) -> + (match l with + | Nil -> C._true + | Cons (t1, l0) -> + (match r with + | Nil -> C._true + | Cons (t2, r0) -> + (match eq with + | Some leq -> + let xeq = Lit.blit leq in + get_eq t_form t_atom xeq (fun t1' t2' -> + if if if eqb0 t1 t1' then eqb0 t2 t2' else false + then true + else if eqb0 t1 t2' then eqb0 t2 t1' else false + then build_congr t_form t_atom eqs0 l0 r0 (Cons + ((Lit.nlit xeq), c)) + else C._true) + | None -> + if eqb0 t1 t2 + then build_congr t_form t_atom eqs0 l0 r0 c + else C._true))) + +(** val check_congr : + Form.form array -> Atom.atom array -> int -> int option list -> C.t **) + +let check_congr t_form t_atom leq eqs = + let xeq = Lit.blit leq in + get_eq t_form t_atom xeq (fun t1 t2 -> + match get t_atom t1 with + | Atom.Auop (o1, a) -> + (match get t_atom t2 with + | Atom.Auop (o2, b) -> + if Atom.uop_eqb o1 o2 + then build_congr t_form t_atom eqs (Cons (a, Nil)) (Cons (b, Nil)) + (Cons ((Lit.lit xeq), Nil)) + else C._true + | _ -> C._true) + | Atom.Abop (o1, a1, a2) -> + (match get t_atom t2 with + | Atom.Abop (o2, b1, b2) -> + if Atom.bop_eqb o1 o2 + then build_congr t_form t_atom eqs (Cons (a1, (Cons (a2, Nil)))) + (Cons (b1, (Cons (b2, Nil)))) (Cons ((Lit.lit xeq), Nil)) + else C._true + | _ -> C._true) + | Atom.Aapp (f1, args1) -> + (match get t_atom t2 with + | Atom.Aapp (f2, args2) -> + if eqb0 f1 f2 + then build_congr t_form t_atom eqs args1 args2 (Cons ((Lit.lit xeq), + Nil)) + else C._true + | _ -> C._true) + | _ -> C._true) + +(** val check_congr_pred : + Form.form array -> Atom.atom array -> int -> int -> int option list -> + C.t **) + +let check_congr_pred t_form t_atom pA pB eqs = + let xPA = Lit.blit pA in + let xPB = Lit.blit pB in + (match get t_form xPA with + | Form.Fatom pa -> + (match get t_form xPB with + | Form.Fatom pb -> + (match get t_atom pa with + | Atom.Auop (o1, a) -> + (match get t_atom pb with + | Atom.Auop (o2, b) -> + if Atom.uop_eqb o1 o2 + then build_congr t_form t_atom eqs (Cons (a, Nil)) (Cons (b, + Nil)) (Cons ((Lit.nlit xPA), (Cons ((Lit.lit xPB), + Nil)))) + else C._true + | _ -> C._true) + | Atom.Abop (o1, a1, a2) -> + (match get t_atom pb with + | Atom.Abop (o2, b1, b2) -> + if Atom.bop_eqb o1 o2 + then build_congr t_form t_atom eqs (Cons (a1, (Cons (a2, + Nil)))) (Cons (b1, (Cons (b2, Nil)))) (Cons + ((Lit.nlit xPA), (Cons ((Lit.lit xPB), Nil)))) + else C._true + | _ -> C._true) + | Atom.Aapp (p, a) -> + (match get t_atom pb with + | Atom.Aapp (p', b) -> + if eqb0 p p' + then build_congr t_form t_atom eqs a b (Cons ((Lit.nlit xPA), + (Cons ((Lit.lit xPB), Nil)))) + else C._true + | _ -> C._true) + | _ -> C._true) + | _ -> C._true) + | _ -> C._true) + +type 'c pol = +| Pc of 'c +| Pinj of positive * 'c pol +| PX of 'c pol * positive * 'c pol + +(** val p0 : 'a1 -> 'a1 pol **) + +let p0 cO = + Pc cO + +(** val p1 : 'a1 -> 'a1 pol **) + +let p1 cI = + Pc cI + +(** val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool **) + +let rec peq ceqb p p' = + match p with + | Pc c -> + (match p' with + | Pc c' -> ceqb c c' + | _ -> false) + | Pinj (j, q) -> + (match p' with + | Pinj (j', q') -> + (match Coq_Pos.compare j j' with + | ExtrNative.Eq -> peq ceqb q q' + | _ -> false) + | _ -> false) + | PX (p2, i, q) -> + (match p' with + | PX (p'0, i', q') -> + (match Coq_Pos.compare i i' with + | ExtrNative.Eq -> if peq ceqb p2 p'0 then peq ceqb q q' else false + | _ -> false) + | _ -> false) + +(** val mkPinj : positive -> 'a1 pol -> 'a1 pol **) + +let mkPinj j p = match p with +| Pc c -> p +| Pinj (j', q) -> Pinj ((Coq_Pos.add j j'), q) +| PX (p2, p3, p4) -> Pinj (j, p) + +(** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **) + +let mkPinj_pred j p = + match j with + | XI j0 -> Pinj ((XO j0), p) + | XO j0 -> Pinj ((Coq_Pos.pred_double j0), p) + | XH -> p + +(** val mkPX : + 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) + +let mkPX cO ceqb p i q = + match p with + | Pc c -> if ceqb c cO then mkPinj XH q else PX (p, i, q) + | Pinj (p2, p3) -> PX (p, i, q) + | PX (p', i', q') -> + if peq ceqb q' (p0 cO) + then PX (p', (Coq_Pos.add i' i), q) + else PX (p, i, q) + +(** val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol **) + +let mkXi cO cI i = + PX ((p1 cI), i, (p0 cO)) + +(** val mkX : 'a1 -> 'a1 -> 'a1 pol **) + +let mkX cO cI = + mkXi cO cI XH + +(** val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **) + +let rec popp copp = function +| Pc c -> Pc (copp c) +| Pinj (j, q) -> Pinj (j, (popp copp q)) +| PX (p2, i, q) -> PX ((popp copp p2), i, (popp copp q)) + +(** val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) + +let rec paddC cadd p c = + match p with + | Pc c1 -> Pc (cadd c1 c) + | Pinj (j, q) -> Pinj (j, (paddC cadd q c)) + | PX (p2, i, q) -> PX (p2, i, (paddC cadd q c)) + +(** val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) + +let rec psubC csub p c = + match p with + | Pc c1 -> Pc (csub c1 c) + | Pinj (j, q) -> Pinj (j, (psubC csub q c)) + | PX (p2, i, q) -> PX (p2, i, (psubC csub q c)) + +(** val paddI : + ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> + positive -> 'a1 pol -> 'a1 pol **) + +let rec paddI cadd pop q j = function +| Pc c -> mkPinj j (paddC cadd q c) +| Pinj (j', q') -> + (match Z.pos_sub j' j with + | Z0 -> mkPinj j (pop q' q) + | Zpos k -> mkPinj j (pop (Pinj (k, q')) q) + | Zneg k -> mkPinj j' (paddI cadd pop q k q')) +| PX (p2, i, q') -> + (match j with + | XI j0 -> PX (p2, i, (paddI cadd pop q (XO j0) q')) + | XO j0 -> PX (p2, i, (paddI cadd pop q (Coq_Pos.pred_double j0) q')) + | XH -> PX (p2, i, (pop q' q))) + +(** val psubI : + ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> + 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) + +let rec psubI cadd copp pop q j = function +| Pc c -> mkPinj j (paddC cadd (popp copp q) c) +| Pinj (j', q') -> + (match Z.pos_sub j' j with + | Z0 -> mkPinj j (pop q' q) + | Zpos k -> mkPinj j (pop (Pinj (k, q')) q) + | Zneg k -> mkPinj j' (psubI cadd copp pop q k q')) +| PX (p2, i, q') -> + (match j with + | XI j0 -> PX (p2, i, (psubI cadd copp pop q (XO j0) q')) + | XO j0 -> PX (p2, i, (psubI cadd copp pop q (Coq_Pos.pred_double j0) q')) + | XH -> PX (p2, i, (pop q' q))) + +(** val paddX : + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol + -> positive -> 'a1 pol -> 'a1 pol **) + +let rec paddX cO ceqb pop p' i' p = match p with +| Pc c -> PX (p', i', p) +| Pinj (j, q') -> + (match j with + | XI j0 -> PX (p', i', (Pinj ((XO j0), q'))) + | XO j0 -> PX (p', i', (Pinj ((Coq_Pos.pred_double j0), q'))) + | XH -> PX (p', i', q')) +| PX (p2, i, q') -> + (match Z.pos_sub i i' with + | Z0 -> mkPX cO ceqb (pop p2 p') i q' + | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' + | Zneg k -> mkPX cO ceqb (paddX cO ceqb pop p' k p2) i q') + +(** val psubX : + 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 + pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) + +let rec psubX cO copp ceqb pop p' i' p = match p with +| Pc c -> PX ((popp copp p'), i', p) +| Pinj (j, q') -> + (match j with + | XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q'))) + | XO j0 -> PX ((popp copp p'), i', (Pinj ((Coq_Pos.pred_double j0), q'))) + | XH -> PX ((popp copp p'), i', q')) +| PX (p2, i, q') -> + (match Z.pos_sub i i' with + | Z0 -> mkPX cO ceqb (pop p2 p') i q' + | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' + | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb pop p' k p2) i q') + +(** val padd : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol + -> 'a1 pol **) + +let rec padd cO cadd ceqb p = function +| Pc c' -> paddC cadd p c' +| Pinj (j', q') -> paddI cadd (padd cO cadd ceqb) q' j' p +| PX (p'0, i', q') -> + (match p with + | Pc c -> PX (p'0, i', (paddC cadd q' c)) + | Pinj (j, q) -> + (match j with + | XI j0 -> PX (p'0, i', (padd cO cadd ceqb (Pinj ((XO j0), q)) q')) + | XO j0 -> + PX (p'0, i', + (padd cO cadd ceqb (Pinj ((Coq_Pos.pred_double j0), q)) q')) + | XH -> PX (p'0, i', (padd cO cadd ceqb q q'))) + | PX (p2, i, q) -> + (match Z.pos_sub i i' with + | Z0 -> + mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i (padd cO cadd ceqb q q') + | Zpos k -> + mkPX cO ceqb (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i' + (padd cO cadd ceqb q q') + | Zneg k -> + mkPX cO ceqb (paddX cO ceqb (padd cO cadd ceqb) p'0 k p2) i + (padd cO cadd ceqb q q'))) + +(** val psub : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 + -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) + +let rec psub cO cadd csub copp ceqb p = function +| Pc c' -> psubC csub p c' +| Pinj (j', q') -> psubI cadd copp (psub cO cadd csub copp ceqb) q' j' p +| PX (p'0, i', q') -> + (match p with + | Pc c -> PX ((popp copp p'0), i', (paddC cadd (popp copp q') c)) + | Pinj (j, q) -> + (match j with + | XI j0 -> + PX ((popp copp p'0), i', + (psub cO cadd csub copp ceqb (Pinj ((XO j0), q)) q')) + | XO j0 -> + PX ((popp copp p'0), i', + (psub cO cadd csub copp ceqb (Pinj ((Coq_Pos.pred_double j0), q)) + q')) + | XH -> PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb q q'))) + | PX (p2, i, q) -> + (match Z.pos_sub i i' with + | Z0 -> + mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i + (psub cO cadd csub copp ceqb q q') + | Zpos k -> + mkPX cO ceqb (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0) + i' (psub cO cadd csub copp ceqb q q') + | Zneg k -> + mkPX cO ceqb + (psubX cO copp ceqb (psub cO cadd csub copp ceqb) p'0 k p2) i + (psub cO cadd csub copp ceqb q q'))) + +(** val pmulC_aux : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> + 'a1 pol **) + +let rec pmulC_aux cO cmul ceqb p c = + match p with + | Pc c' -> Pc (cmul c' c) + | Pinj (j, q) -> mkPinj j (pmulC_aux cO cmul ceqb q c) + | PX (p2, i, q) -> + mkPX cO ceqb (pmulC_aux cO cmul ceqb p2 c) i (pmulC_aux cO cmul ceqb q c) + +(** val pmulC : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> + 'a1 -> 'a1 pol **) + +let pmulC cO cI cmul ceqb p c = + if ceqb c cO + then p0 cO + else if ceqb c cI then p else pmulC_aux cO cmul ceqb p c + +(** val pmulI : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> + 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) + +let rec pmulI cO cI cmul ceqb pmul0 q j = function +| Pc c -> mkPinj j (pmulC cO cI cmul ceqb q c) +| Pinj (j', q') -> + (match Z.pos_sub j' j with + | Z0 -> mkPinj j (pmul0 q' q) + | Zpos k -> mkPinj j (pmul0 (Pinj (k, q')) q) + | Zneg k -> mkPinj j' (pmulI cO cI cmul ceqb pmul0 q k q')) +| PX (p', i', q') -> + (match j with + | XI j' -> + mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q j p') i' + (pmulI cO cI cmul ceqb pmul0 q (XO j') q') + | XO j' -> + mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q j p') i' + (pmulI cO cI cmul ceqb pmul0 q (Coq_Pos.pred_double j') q') + | XH -> mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q XH p') i' (pmul0 q' q)) + +(** val pmul : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) + +let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with +| Pc c -> pmulC cO cI cmul ceqb p c +| Pinj (j', q') -> pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' j' p +| PX (p', i', q') -> + (match p with + | Pc c -> pmulC cO cI cmul ceqb p'' c + | Pinj (j, q) -> + let qQ' = + match j with + | XI j0 -> pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q)) q' + | XO j0 -> + pmul cO cI cadd cmul ceqb (Pinj ((Coq_Pos.pred_double j0), q)) q' + | XH -> pmul cO cI cadd cmul ceqb q q' + in + mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i' qQ' + | PX (p2, i, q) -> + let qQ' = pmul cO cI cadd cmul ceqb q q' in + let pQ' = pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' XH p2 in + let qP' = pmul cO cI cadd cmul ceqb (mkPinj XH q) p' in + let pP' = pmul cO cI cadd cmul ceqb p2 p' in + padd cO cadd ceqb + (mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb pP' i (p0 cO)) qP') i' + (p0 cO)) (mkPX cO ceqb pQ' i qQ')) + +(** val psquare : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> 'a1 pol -> 'a1 pol **) + +let rec psquare cO cI cadd cmul ceqb = function +| Pc c -> Pc (cmul c c) +| Pinj (j, q) -> Pinj (j, (psquare cO cI cadd cmul ceqb q)) +| PX (p2, i, q) -> + let twoPQ = + pmul cO cI cadd cmul ceqb p2 + (mkPinj XH (pmulC cO cI cmul ceqb q (cadd cI cI))) + in + let q2 = psquare cO cI cadd cmul ceqb q in + let p3 = psquare cO cI cadd cmul ceqb p2 in + mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb p3 i (p0 cO)) twoPQ) i q2 + +type 'c pExpr = +| PEc of 'c +| PEX of positive +| PEadd of 'c pExpr * 'c pExpr +| PEsub of 'c pExpr * 'c pExpr +| PEmul of 'c pExpr * 'c pExpr +| PEopp of 'c pExpr +| PEpow of 'c pExpr * n + +(** val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol **) + +let mk_X cO cI j = + mkPinj_pred j (mkX cO cI) + +(** val ppow_pos : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 + pol **) + +let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function +| XI p3 -> + subst_l + (pmul cO cI cadd cmul ceqb + (ppow_pos cO cI cadd cmul ceqb subst_l + (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3) p) +| XO p3 -> + ppow_pos cO cI cadd cmul ceqb subst_l + (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3 +| XH -> subst_l (pmul cO cI cadd cmul ceqb res p) + +(** val ppow_N : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol **) + +let ppow_N cO cI cadd cmul ceqb subst_l p = function +| N0 -> p1 cI +| Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2 + +(** val norm_aux : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) + +let rec norm_aux cO cI cadd cmul csub copp ceqb = function +| PEc c -> Pc c +| PEX j -> mk_X cO cI j +| PEadd (pe1, pe2) -> + (match pe1 with + | PEopp pe3 -> + psub cO cadd csub copp ceqb + (norm_aux cO cI cadd cmul csub copp ceqb pe2) + (norm_aux cO cI cadd cmul csub copp ceqb pe3) + | _ -> + (match pe2 with + | PEopp pe3 -> + psub cO cadd csub copp ceqb + (norm_aux cO cI cadd cmul csub copp ceqb pe1) + (norm_aux cO cI cadd cmul csub copp ceqb pe3) + | _ -> + padd cO cadd ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) + (norm_aux cO cI cadd cmul csub copp ceqb pe2))) +| PEsub (pe1, pe2) -> + psub cO cadd csub copp ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) + (norm_aux cO cI cadd cmul csub copp ceqb pe2) +| PEmul (pe1, pe2) -> + pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) + (norm_aux cO cI cadd cmul csub copp ceqb pe2) +| PEopp pe1 -> popp copp (norm_aux cO cI cadd cmul csub copp ceqb pe1) +| PEpow (pe1, n0) -> + ppow_N cO cI cadd cmul ceqb (fun p -> p) + (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0 + +type 'a bFormula = +| TT +| FF +| X +| A of 'a +| Cj of 'a bFormula * 'a bFormula +| D of 'a bFormula * 'a bFormula +| N of 'a bFormula +| I of 'a bFormula * 'a bFormula + +type 'term' clause = 'term' list + +type 'term' cnf = 'term' clause list + +(** val tt : 'a1 cnf **) + +let tt = + Nil + +(** val ff : 'a1 cnf **) + +let ff = + Cons (Nil, Nil) + +(** val add_term : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 + clause option **) + +let rec add_term unsat deduce t0 = function +| Nil -> + (match deduce t0 t0 with + | Some u -> if unsat u then None else Some (Cons (t0, Nil)) + | None -> Some (Cons (t0, Nil))) +| Cons (t', cl0) -> + (match deduce t0 t' with + | Some u -> + if unsat u + then None + else (match add_term unsat deduce t0 cl0 with + | Some cl' -> Some (Cons (t', cl')) + | None -> None) + | None -> + (match add_term unsat deduce t0 cl0 with + | Some cl' -> Some (Cons (t', cl')) + | None -> None)) + +(** val or_clause : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause + -> 'a1 clause option **) + +let rec or_clause unsat deduce cl1 cl2 = + match cl1 with + | Nil -> Some cl2 + | Cons (t0, cl) -> + (match add_term unsat deduce t0 cl2 with + | Some cl' -> or_clause unsat deduce cl cl' + | None -> None) + +(** val or_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> + 'a1 cnf **) + +let or_clause_cnf unsat deduce t0 f = + fold_right (fun e acc -> + match or_clause unsat deduce t0 e with + | Some cl -> Cons (cl, acc) + | None -> acc) Nil f + +(** val or_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 + cnf **) + +let rec or_cnf unsat deduce f f' = + match f with + | Nil -> tt + | Cons (e, rst) -> + app (or_cnf unsat deduce rst f') (or_clause_cnf unsat deduce e f') + +(** val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **) + +let and_cnf f1 f2 = + app f1 f2 + +(** val xcnf : + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 + -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **) + +let rec xcnf unsat deduce normalise0 negate0 pol0 = function +| TT -> if pol0 then tt else ff +| FF -> if pol0 then ff else tt +| X -> ff +| A x -> if pol0 then normalise0 x else negate0 x +| Cj (e1, e2) -> + if pol0 + then and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) + (xcnf unsat deduce normalise0 negate0 pol0 e2) + else or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 pol0 e1) + (xcnf unsat deduce normalise0 negate0 pol0 e2) +| D (e1, e2) -> + if pol0 + then or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 pol0 e1) + (xcnf unsat deduce normalise0 negate0 pol0 e2) + else and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) + (xcnf unsat deduce normalise0 negate0 pol0 e2) +| N e -> xcnf unsat deduce normalise0 negate0 (negb pol0) e +| I (e1, e2) -> + if pol0 + then or_cnf unsat deduce + (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) + (xcnf unsat deduce normalise0 negate0 pol0 e2) + else and_cnf (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) + (xcnf unsat deduce normalise0 negate0 pol0 e2) + +(** val cnf_checker : + ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool **) + +let rec cnf_checker checker0 f l = + match f with + | Nil -> true + | Cons (e, f0) -> + (match l with + | Nil -> false + | Cons (c, l0) -> + if checker0 e c then cnf_checker checker0 f0 l0 else false) + +(** val tauto_checker : + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 + -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> + bool **) + +let tauto_checker unsat deduce normalise0 negate0 checker0 f w = + cnf_checker checker0 (xcnf unsat deduce normalise0 negate0 true f) w + +(** val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) + +let cneqb ceqb x y = + negb (ceqb x y) + +(** val cltb : + ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) + +let cltb ceqb cleb x y = + if cleb x y then cneqb ceqb x y else false + +type 'c polC = 'c pol + +type op1 = +| Equal +| NonEqual +| Strict +| NonStrict + +type 'c nFormula = 'c polC*op1 + +(** val opMult : op1 -> op1 -> op1 option **) + +let opMult o o' = + match o with + | Equal -> Some Equal + | NonEqual -> + (match o' with + | Strict -> None + | NonStrict -> None + | x -> Some x) + | Strict -> + (match o' with + | NonEqual -> None + | _ -> Some o') + | NonStrict -> + (match o' with + | NonEqual -> None + | Strict -> Some NonStrict + | x -> Some x) + +(** val opAdd : op1 -> op1 -> op1 option **) + +let opAdd o o' = + match o with + | Equal -> Some o' + | NonEqual -> + (match o' with + | Equal -> Some NonEqual + | _ -> None) + | Strict -> + (match o' with + | NonEqual -> None + | _ -> Some Strict) + | NonStrict -> + (match o' with + | Equal -> Some NonStrict + | NonEqual -> None + | x -> Some x) + +type 'c psatz = +| PsatzIn of nat +| PsatzSquare of 'c polC +| PsatzMulC of 'c polC * 'c psatz +| PsatzMulE of 'c psatz * 'c psatz +| PsatzAdd of 'c psatz * 'c psatz +| PsatzC of 'c +| PsatzZ + +(** val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option **) + +let map_option f = function +| Some x -> f x +| None -> None + +(** val map_option2 : + ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option **) + +let map_option2 f o o' = + match o with + | Some x -> + (match o' with + | Some x' -> f x x' + | None -> None) + | None -> None + +(** val pexpr_times_nformula : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option **) + +let pexpr_times_nformula cO cI cplus ctimes ceqb e = function +| ef,o -> + (match o with + | Equal -> Some ((pmul cO cI cplus ctimes ceqb e ef),Equal) + | _ -> None) + +(** val nformula_times_nformula : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **) + +let nformula_times_nformula cO cI cplus ctimes ceqb f1 f2 = + let e1,o1 = f1 in + let e2,o2 = f2 in + map_option (fun x -> Some ((pmul cO cI cplus ctimes ceqb e1 e2),x)) + (opMult o1 o2) + +(** val nformula_plus_nformula : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 + nFormula -> 'a1 nFormula option **) + +let nformula_plus_nformula cO cplus ceqb f1 f2 = + let e1,o1 = f1 in + let e2,o2 = f2 in + map_option (fun x -> Some ((padd cO cplus ceqb e1 e2),x)) (opAdd o1 o2) + +(** val eval_Psatz : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 + nFormula option **) + +let rec eval_Psatz cO cI cplus ctimes ceqb cleb l = function +| PsatzIn n0 -> Some (nth n0 l ((Pc cO),Equal)) +| PsatzSquare e0 -> Some ((psquare cO cI cplus ctimes ceqb e0),NonStrict) +| PsatzMulC (re, e0) -> + map_option (pexpr_times_nformula cO cI cplus ctimes ceqb re) + (eval_Psatz cO cI cplus ctimes ceqb cleb l e0) +| PsatzMulE (f1, f2) -> + map_option2 (nformula_times_nformula cO cI cplus ctimes ceqb) + (eval_Psatz cO cI cplus ctimes ceqb cleb l f1) + (eval_Psatz cO cI cplus ctimes ceqb cleb l f2) +| PsatzAdd (f1, f2) -> + map_option2 (nformula_plus_nformula cO cplus ceqb) + (eval_Psatz cO cI cplus ctimes ceqb cleb l f1) + (eval_Psatz cO cI cplus ctimes ceqb cleb l f2) +| PsatzC c -> if cltb ceqb cleb cO c then Some ((Pc c),Strict) else None +| PsatzZ -> Some ((Pc cO),Equal) + +(** val check_inconsistent : + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> + bool **) + +let check_inconsistent cO ceqb cleb = function +| e,op -> + (match e with + | Pc c -> + (match op with + | Equal -> cneqb ceqb c cO + | NonEqual -> ceqb c cO + | Strict -> cleb c cO + | NonStrict -> cltb ceqb cleb c cO) + | _ -> false) + +type op2 = +| OpEq +| OpNEq +| OpLe +| OpGe +| OpLt +| OpGt + +type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } + +(** val norm : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) + +let norm cO cI cplus ctimes cminus copp ceqb = + norm_aux cO cI cplus ctimes cminus copp ceqb + +(** val psub0 : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 + -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) + +let psub0 cO cplus cminus copp ceqb = + psub cO cplus cminus copp ceqb + +(** val padd0 : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol + -> 'a1 pol **) + +let padd0 cO cplus ceqb = + padd cO cplus ceqb + +type zWitness = z psatz + +(** val psub1 : z pol -> z pol -> z pol **) + +let psub1 = + psub0 Z0 Z.add Z.sub Z.opp zeq_bool + +(** val padd1 : z pol -> z pol -> z pol **) + +let padd1 = + padd0 Z0 Z.add zeq_bool + +(** val norm0 : z pExpr -> z pol **) + +let norm0 = + norm Z0 (Zpos XH) Z.add Z.mul Z.sub Z.opp zeq_bool + +(** val xnormalise : z formula -> z nFormula list **) + +let xnormalise t0 = + let { flhs = lhs; fop = o; frhs = rhs } = t0 in + let lhs0 = norm0 lhs in + let rhs0 = norm0 rhs in + (match o with + | OpEq -> + Cons (((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict), (Cons + (((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict), Nil))) + | OpNEq -> Cons (((psub1 lhs0 rhs0),Equal), Nil) + | OpLe -> Cons (((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict), Nil) + | OpGe -> Cons (((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict), Nil) + | OpLt -> Cons (((psub1 lhs0 rhs0),NonStrict), Nil) + | OpGt -> Cons (((psub1 rhs0 lhs0),NonStrict), Nil)) + +(** val normalise : z formula -> z nFormula cnf **) + +let normalise t0 = + map (fun x -> Cons (x, Nil)) (xnormalise t0) + +(** val xnegate : z formula -> z nFormula list **) + +let xnegate t0 = + let { flhs = lhs; fop = o; frhs = rhs } = t0 in + let lhs0 = norm0 lhs in + let rhs0 = norm0 rhs in + (match o with + | OpEq -> Cons (((psub1 lhs0 rhs0),Equal), Nil) + | OpNEq -> + Cons (((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict), (Cons + (((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict), Nil))) + | OpLe -> Cons (((psub1 rhs0 lhs0),NonStrict), Nil) + | OpGe -> Cons (((psub1 lhs0 rhs0),NonStrict), Nil) + | OpLt -> Cons (((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict), Nil) + | OpGt -> Cons (((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict), Nil)) + +(** val negate : z formula -> z nFormula cnf **) + +let negate t0 = + map (fun x -> Cons (x, Nil)) (xnegate t0) + +(** val zunsat : z nFormula -> bool **) + +let zunsat = + check_inconsistent Z0 zeq_bool Z.leb + +(** val zdeduce : z nFormula -> z nFormula -> z nFormula option **) + +let zdeduce = + nformula_plus_nformula Z0 Z.add zeq_bool + +(** val ceiling : z -> z -> z **) + +let ceiling a b = + let q,r = Z.div_eucl a b in + (match r with + | Z0 -> q + | _ -> Z.add q (Zpos XH)) + +type zArithProof = +| DoneProof +| RatProof of zWitness * zArithProof +| CutProof of zWitness * zArithProof +| EnumProof of zWitness * zWitness * zArithProof list + +(** val zgcdM : z -> z -> z **) + +let zgcdM x y = + Z.max (Z.gcd x y) (Zpos XH) + +(** val zgcd_pol : z polC -> z*z **) + +let rec zgcd_pol = function +| Pc c -> Z0,c +| Pinj (p2, p3) -> zgcd_pol p3 +| PX (p2, p3, q) -> + let g1,c1 = zgcd_pol p2 in + let g2,c2 = zgcd_pol q in (zgcdM (zgcdM g1 c1) g2),c2 + +(** val zdiv_pol : z polC -> z -> z polC **) + +let rec zdiv_pol p x = + match p with + | Pc c -> Pc (Z.div c x) + | Pinj (j, p2) -> Pinj (j, (zdiv_pol p2 x)) + | PX (p2, j, q) -> PX ((zdiv_pol p2 x), j, (zdiv_pol q x)) + +(** val makeCuttingPlane : z polC -> z polC*z **) + +let makeCuttingPlane p = + let g,c = zgcd_pol p in + if Z.gtb g Z0 + then (zdiv_pol (psubC Z.sub p c) g),(Z.opp (ceiling (Z.opp c) g)) + else p,Z0 + +(** val genCuttingPlane : z nFormula -> ((z polC*z)*op1) option **) + +let genCuttingPlane = function +| e,op -> + (match op with + | Equal -> + let g,c = zgcd_pol e in + if if Z.gtb g Z0 + then if negb (zeq_bool c Z0) + then negb (zeq_bool (Z.gcd g c) g) + else false + else false + then None + else Some ((makeCuttingPlane e),Equal) + | NonEqual -> Some ((e,Z0),op) + | Strict -> Some ((makeCuttingPlane (psubC Z.sub e (Zpos XH))),NonStrict) + | NonStrict -> Some ((makeCuttingPlane e),NonStrict)) + +(** val nformula_of_cutting_plane : ((z polC*z)*op1) -> z nFormula **) + +let nformula_of_cutting_plane = function +| e_z,o -> let e,z0 = e_z in (padd1 e (Pc z0)),o + +(** val is_pol_Z0 : z polC -> bool **) + +let is_pol_Z0 = function +| Pc z0 -> + (match z0 with + | Z0 -> true + | _ -> false) +| _ -> false + +(** val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option **) + +let eval_Psatz0 = + eval_Psatz Z0 (Zpos XH) Z.add Z.mul zeq_bool Z.leb + +(** val valid_cut_sign : op1 -> bool **) + +let valid_cut_sign = function +| Equal -> true +| NonStrict -> true +| _ -> false + +(** val zChecker : z nFormula list -> zArithProof -> bool **) + +let rec zChecker l = function +| DoneProof -> false +| RatProof (w, pf0) -> + (match eval_Psatz0 l w with + | Some f -> if zunsat f then true else zChecker (Cons (f, l)) pf0 + | None -> false) +| CutProof (w, pf0) -> + (match eval_Psatz0 l w with + | Some f -> + (match genCuttingPlane f with + | Some cp -> zChecker (Cons ((nformula_of_cutting_plane cp), l)) pf0 + | None -> true) + | None -> false) +| EnumProof (w1, w2, pf0) -> + (match eval_Psatz0 l w1 with + | Some f1 -> + (match eval_Psatz0 l w2 with + | Some f2 -> + (match genCuttingPlane f1 with + | Some p -> + let p2,op3 = p in + let e1,z1 = p2 in + (match genCuttingPlane f2 with + | Some p3 -> + let p4,op4 = p3 in + let e2,z2 = p4 in + if if if valid_cut_sign op3 then valid_cut_sign op4 else false + then is_pol_Z0 (padd1 e1 e2) + else false + then let rec label pfs lb ub = + match pfs with + | Nil -> Z.gtb lb ub + | Cons (pf1, rsr) -> + if zChecker (Cons (((psub1 e1 (Pc lb)),Equal), l)) pf1 + then label rsr (Z.add lb (Zpos XH)) ub + else false + in label pf0 (Z.opp z1) z2 + else false + | None -> true) + | None -> true) + | None -> false) + | None -> false) + +(** val zTautoChecker : z formula bFormula -> zArithProof list -> bool **) + +let zTautoChecker f w = + tauto_checker zunsat zdeduce normalise negate zChecker f w + +(** val build_positive_atom_aux : + (int -> positive option) -> Atom.atom -> positive option **) + +let build_positive_atom_aux build_positive0 = function +| Atom.Acop c -> + (match c with + | Atom.CO_xH -> Some XH + | Atom.CO_Z0 -> None) +| Atom.Auop (u, a0) -> + (match u with + | Atom.UO_xO -> option_map (fun x -> XO x) (build_positive0 a0) + | Atom.UO_xI -> option_map (fun x -> XI x) (build_positive0 a0) + | _ -> None) +| _ -> None + +(** val build_positive : Atom.atom array -> int -> positive option **) + +let build_positive t_atom = + foldi_down_cont (fun i cont h -> + build_positive_atom_aux cont (get t_atom h)) (length t_atom) + (ExtrNative.of_uint(0)) (fun x -> None) + +(** val build_z_atom_aux : Atom.atom array -> Atom.atom -> z option **) + +let build_z_atom_aux t_atom = function +| Atom.Acop c -> + (match c with + | Atom.CO_xH -> None + | Atom.CO_Z0 -> Some Z0) +| Atom.Auop (u, a0) -> + (match u with + | Atom.UO_Zpos -> option_map (fun x -> Zpos x) (build_positive t_atom a0) + | Atom.UO_Zneg -> option_map (fun x -> Zneg x) (build_positive t_atom a0) + | _ -> None) +| _ -> None + +(** val build_z_atom : Atom.atom array -> Atom.atom -> z option **) + +let build_z_atom t_atom = + build_z_atom_aux t_atom + +type vmap = positive*Atom.atom list + +(** val find_var_aux : + Atom.atom -> positive -> Atom.atom list -> positive option **) + +let rec find_var_aux h p = function +| Nil -> None +| Cons (h', l0) -> + let p2 = Coq_Pos.pred p in + if Atom.eqb h h' then Some p2 else find_var_aux h p2 l0 + +(** val find_var : vmap -> Atom.atom -> vmap*positive **) + +let find_var vm h = + let count,map0 = vm in + (match find_var_aux h count map0 with + | Some p -> vm,p + | None -> ((Coq_Pos.succ count),(Cons (h, map0))),count) + +(** val empty_vmap : vmap **) + +let empty_vmap = + XH,Nil + +(** val build_pexpr_atom_aux : + Atom.atom array -> (vmap -> int -> vmap*z pExpr) -> vmap -> Atom.atom -> + vmap*z pExpr **) + +let build_pexpr_atom_aux t_atom build_pexpr0 vm h = match h with +| Atom.Auop (u, a) -> + (match u with + | Atom.UO_Zopp -> let vm0,pe = build_pexpr0 vm a in vm0,(PEopp pe) + | _ -> + (match build_z_atom t_atom h with + | Some z0 -> vm,(PEc z0) + | None -> let vm0,p = find_var vm h in vm0,(PEX p))) +| Atom.Abop (b, a1, a2) -> + (match b with + | Atom.BO_Zplus -> + let vm0,pe1 = build_pexpr0 vm a1 in + let vm1,pe2 = build_pexpr0 vm0 a2 in vm1,(PEadd (pe1, pe2)) + | Atom.BO_Zminus -> + let vm0,pe1 = build_pexpr0 vm a1 in + let vm1,pe2 = build_pexpr0 vm0 a2 in vm1,(PEsub (pe1, pe2)) + | Atom.BO_Zmult -> + let vm0,pe1 = build_pexpr0 vm a1 in + let vm1,pe2 = build_pexpr0 vm0 a2 in vm1,(PEmul (pe1, pe2)) + | _ -> + (match build_z_atom t_atom h with + | Some z0 -> vm,(PEc z0) + | None -> let vm0,p = find_var vm h in vm0,(PEX p))) +| _ -> + (match build_z_atom t_atom h with + | Some z0 -> vm,(PEc z0) + | None -> let vm0,p = find_var vm h in vm0,(PEX p)) + +(** val build_pexpr : Atom.atom array -> vmap -> int -> vmap*z pExpr **) + +let build_pexpr t_atom = + foldi_down_cont (fun i cont vm h -> + build_pexpr_atom_aux t_atom cont vm (get t_atom h)) (length t_atom) + (ExtrNative.of_uint(0)) (fun vm x -> vm,(PEc Z0)) + +(** val build_op2 : Atom.binop -> op2 option **) + +let build_op2 = function +| Atom.BO_Zlt -> Some OpLt +| Atom.BO_Zle -> Some OpLe +| Atom.BO_Zge -> Some OpGe +| Atom.BO_Zgt -> Some OpGt +| Atom.BO_eq t0 -> + (match t0 with + | Typ.TZ -> Some OpEq + | _ -> None) +| _ -> None + +(** val build_formula_atom : + Atom.atom array -> vmap -> Atom.atom -> (vmap*z formula) option **) + +let build_formula_atom t_atom vm = function +| Atom.Abop (op, a1, a2) -> + (match build_op2 op with + | Some o -> + let vm0,pe1 = build_pexpr t_atom vm a1 in + let vm1,pe2 = build_pexpr t_atom vm0 a2 in + Some (vm1,{ flhs = pe1; fop = o; frhs = pe2 }) + | None -> None) +| _ -> None + +(** val build_formula : + Atom.atom array -> vmap -> int -> (vmap*z formula) option **) + +let build_formula t_atom vm h = + build_formula_atom t_atom vm (get t_atom h) + +(** val build_not2 : int -> z formula bFormula -> z formula bFormula **) + +let build_not2 i f = + fold (fun f' -> N (N f')) (ExtrNative.of_uint(1)) i f + +(** val build_hform : + Atom.atom array -> (vmap -> int -> (vmap*z formula bFormula) option) -> + vmap -> Form.form -> (vmap*z formula bFormula) option **) + +let build_hform t_atom build_var0 vm = function +| Form.Fatom h -> + (match build_formula t_atom vm h with + | Some p -> let vm0,f0 = p in Some (vm0,(A f0)) + | None -> None) +| Form.Ftrue -> Some (vm,TT) +| Form.Ffalse -> Some (vm,FF) +| Form.Fnot2 (i, l) -> + (match build_var0 vm (Lit.blit l) with + | Some p -> + let vm0,f0 = p in + let f' = build_not2 i f0 in + let f'' = if Lit.is_pos l then f' else N f' in Some (vm0,f'') + | None -> None) +| Form.Fand args -> + let n0 = length args in + if eqb0 n0 (ExtrNative.of_uint(0)) + then Some (vm,TT) + else foldi (fun i f1 -> + match f1 with + | Some y -> + let vm',f1' = y in + let l = get args i in + (match build_var0 vm' (Lit.blit l) with + | Some p -> + let vm2,f2 = p in + let f2' = if Lit.is_pos l then f2 else N f2 in + Some (vm2,(Cj (f1', f2'))) + | None -> None) + | None -> None) (ExtrNative.of_uint(1)) + (sub0 n0 (ExtrNative.of_uint(1))) + (let l = get args (ExtrNative.of_uint(0)) in + match build_var0 vm (Lit.blit l) with + | Some p -> + let vm',f0 = p in + if Lit.is_pos l then Some (vm',f0) else Some (vm',(N f0)) + | None -> None) +| Form.For args -> + let n0 = length args in + if eqb0 n0 (ExtrNative.of_uint(0)) + then Some (vm,FF) + else foldi (fun i f1 -> + match f1 with + | Some y -> + let vm',f1' = y in + let l = get args i in + (match build_var0 vm' (Lit.blit l) with + | Some p -> + let vm2,f2 = p in + let f2' = if Lit.is_pos l then f2 else N f2 in + Some (vm2,(D (f1', f2'))) + | None -> None) + | None -> None) (ExtrNative.of_uint(1)) + (sub0 n0 (ExtrNative.of_uint(1))) + (let l = get args (ExtrNative.of_uint(0)) in + match build_var0 vm (Lit.blit l) with + | Some p -> + let vm',f0 = p in + if Lit.is_pos l then Some (vm',f0) else Some (vm',(N f0)) + | None -> None) +| Form.Fimp args -> + let n0 = length args in + if eqb0 n0 (ExtrNative.of_uint(0)) + then Some (vm,TT) + else if leb0 n0 (ExtrNative.of_uint(1)) + then let l = get args (ExtrNative.of_uint(0)) in + (match build_var0 vm (Lit.blit l) with + | Some p -> + let vm',f0 = p in + if Lit.is_pos l then Some (vm',f0) else Some (vm',(N f0)) + | None -> None) + else foldi_down (fun i f1 -> + match f1 with + | Some y -> + let vm',f1' = y in + let l = get args i in + (match build_var0 vm' (Lit.blit l) with + | Some p -> + let vm2,f2 = p in + let f2' = if Lit.is_pos l then f2 else N f2 in + Some (vm2,(I (f2', f1'))) + | None -> None) + | None -> None) (sub0 n0 (ExtrNative.of_uint(2))) + (ExtrNative.of_uint(0)) + (let l = get args (sub0 n0 (ExtrNative.of_uint(1))) in + match build_var0 vm (Lit.blit l) with + | Some p -> + let vm',f0 = p in + if Lit.is_pos l then Some (vm',f0) else Some (vm',(N f0)) + | None -> None) +| Form.Fxor (a, b) -> + (match build_var0 vm (Lit.blit a) with + | Some p -> + let vm1,f1 = p in + (match build_var0 vm1 (Lit.blit b) with + | Some p2 -> + let vm2,f2 = p2 in + let f1' = if Lit.is_pos a then f1 else N f1 in + let f2' = if Lit.is_pos b then f2 else N f2 in + Some (vm2,(Cj ((D (f1', f2')), (D ((N f1'), (N f2')))))) + | None -> None) + | None -> None) +| Form.Fiff (a, b) -> + (match build_var0 vm (Lit.blit a) with + | Some p -> + let vm1,f1 = p in + (match build_var0 vm1 (Lit.blit b) with + | Some p2 -> + let vm2,f2 = p2 in + let f1' = if Lit.is_pos a then f1 else N f1 in + let f2' = if Lit.is_pos b then f2 else N f2 in + Some (vm2,(Cj ((D (f1', (N f2'))), (D ((N f1'), f2'))))) + | None -> None) + | None -> None) +| Form.Fite (a, b, c) -> + (match build_var0 vm (Lit.blit a) with + | Some p -> + let vm1,f1 = p in + (match build_var0 vm1 (Lit.blit b) with + | Some p2 -> + let vm2,f2 = p2 in + (match build_var0 vm2 (Lit.blit c) with + | Some p3 -> + let vm3,f3 = p3 in + let f1' = if Lit.is_pos a then f1 else N f1 in + let f2' = if Lit.is_pos b then f2 else N f2 in + let f3' = if Lit.is_pos c then f3 else N f3 in + Some (vm3,(D ((Cj (f1', f2')), (Cj ((N f1'), f3'))))) + | None -> None) + | None -> None) + | None -> None) + +(** val build_var : + Form.form array -> Atom.atom array -> vmap -> int -> (vmap*z formula + bFormula) option **) + +let build_var t_form t_atom = + foldi_down_cont (fun i cont vm h -> + build_hform t_atom cont vm (get t_form h)) (length t_form) + (ExtrNative.of_uint(0)) (fun x x0 -> None) + +(** val build_form : + Form.form array -> Atom.atom array -> vmap -> Form.form -> (vmap*z + formula bFormula) option **) + +let build_form t_form t_atom = + build_hform t_atom (build_var t_form t_atom) + +(** val build_nlit : + Form.form array -> Atom.atom array -> vmap -> int -> (vmap*z formula + bFormula) option **) + +let build_nlit t_form t_atom vm l = + let l0 = Lit.neg l in + (match build_form t_form t_atom vm (get t_form (Lit.blit l0)) with + | Some p -> + let vm0,f = p in + let f0 = if Lit.is_pos l0 then f else N f in Some (vm0,f0) + | None -> None) + +(** val build_clause_aux : + Form.form array -> Atom.atom array -> vmap -> int list -> (vmap*z formula + bFormula) option **) + +let rec build_clause_aux t_form t_atom vm = function +| Nil -> None +| Cons (l, cl0) -> + (match cl0 with + | Nil -> build_nlit t_form t_atom vm l + | Cons (i, l0) -> + (match build_nlit t_form t_atom vm l with + | Some p -> + let vm0,bf1 = p in + (match build_clause_aux t_form t_atom vm0 cl0 with + | Some p2 -> let vm1,bf2 = p2 in Some (vm1,(Cj (bf1, bf2))) + | None -> None) + | None -> None)) + +(** val build_clause : + Form.form array -> Atom.atom array -> vmap -> int list -> (vmap*z formula + bFormula) option **) + +let build_clause t_form t_atom vm cl = + match build_clause_aux t_form t_atom vm cl with + | Some p -> let vm0,bf = p in Some (vm0,(I (bf, FF))) + | None -> None + +(** val get_eq0 : + Form.form array -> Atom.atom array -> int -> (int -> int -> C.t) -> C.t **) + +let get_eq0 t_form t_atom l f = + if Lit.is_pos l + then (match get t_form (Lit.blit l) with + | Form.Fatom xa -> + (match get t_atom xa with + | Atom.Abop (b0, a, b) -> + (match b0 with + | Atom.BO_eq t0 -> f a b + | _ -> C._true) + | _ -> C._true) + | _ -> C._true) + else C._true + +(** val get_not_le : + Form.form array -> Atom.atom array -> int -> (int -> int -> C.t) -> C.t **) + +let get_not_le t_form t_atom l f = + if negb (Lit.is_pos l) + then (match get t_form (Lit.blit l) with + | Form.Fatom xa -> + (match get t_atom xa with + | Atom.Abop (b0, a, b) -> + (match b0 with + | Atom.BO_Zle -> f a b + | _ -> C._true) + | _ -> C._true) + | _ -> C._true) + else C._true + +(** val check_micromega : + Form.form array -> Atom.atom array -> int list -> zArithProof list -> C.t **) + +let check_micromega t_form t_atom cl c = + match build_clause t_form t_atom empty_vmap cl with + | Some p -> let v,bf = p in if zTautoChecker bf c then cl else C._true + | None -> C._true + +(** val check_diseq : Form.form array -> Atom.atom array -> int -> C.t **) + +let check_diseq t_form t_atom l = + match get t_form (Lit.blit l) with + | Form.For a -> + if eqb0 (length a) (ExtrNative.of_uint(3)) + then let a_eq_b = get a (ExtrNative.of_uint(0)) in + let not_a_le_b = get a (ExtrNative.of_uint(1)) in + let not_b_le_a = get a (ExtrNative.of_uint(2)) in + get_eq0 t_form t_atom a_eq_b (fun a0 b -> + get_not_le t_form t_atom not_a_le_b (fun a' b' -> + get_not_le t_form t_atom not_b_le_a (fun b'' a'' -> + if if if if eqb0 a0 a' then eqb0 a0 a'' else false + then eqb0 b b' + else false + then eqb0 b b'' + else false + then Cons ((Lit.lit (Lit.blit l)), Nil) + else if if if if eqb0 a0 b' then eqb0 a0 b'' else false + then eqb0 b a' + else false + then eqb0 b a'' + else false + then Cons ((Lit.lit (Lit.blit l)), Nil) + else C._true))) + else C._true + | _ -> C._true + +(** val check_atom_aux : + Atom.atom array -> (int -> int -> bool) -> Atom.atom -> Atom.atom -> bool **) + +let check_atom_aux t_atom check_hatom0 a b = + match a with + | Atom.Acop o1 -> + (match b with + | Atom.Acop o2 -> Atom.cop_eqb o1 o2 + | _ -> false) + | Atom.Auop (o1, a0) -> + (match o1 with + | Atom.UO_Zneg -> + (match b with + | Atom.Auop (o2, b0) -> + (match o2 with + | Atom.UO_Zopp -> + (match get t_atom b0 with + | Atom.Auop (u, q) -> + (match u with + | Atom.UO_Zpos -> check_hatom0 a0 q + | _ -> false) + | _ -> false) + | _ -> if Atom.uop_eqb o1 o2 then check_hatom0 a0 b0 else false) + | _ -> false) + | Atom.UO_Zopp -> + (match b with + | Atom.Auop (o2, b0) -> + (match o2 with + | Atom.UO_Zneg -> + (match get t_atom a0 with + | Atom.Auop (u, p) -> + (match u with + | Atom.UO_Zpos -> check_hatom0 p b0 + | _ -> false) + | _ -> false) + | _ -> if Atom.uop_eqb o1 o2 then check_hatom0 a0 b0 else false) + | _ -> false) + | _ -> + (match b with + | Atom.Auop (o2, b0) -> + if Atom.uop_eqb o1 o2 then check_hatom0 a0 b0 else false + | _ -> false)) + | Atom.Abop (o1, a1, a2) -> + (match b with + | Atom.Abop (o2, b1, b2) -> + (match o1 with + | Atom.BO_Zplus -> + (match o2 with + | Atom.BO_Zplus -> + if if check_hatom0 a1 b1 then check_hatom0 a2 b2 else false + then true + else if check_hatom0 a1 b2 then check_hatom0 a2 b1 else false + | _ -> false) + | Atom.BO_Zminus -> + (match o2 with + | Atom.BO_Zminus -> + if check_hatom0 a1 b1 then check_hatom0 a2 b2 else false + | _ -> false) + | Atom.BO_Zmult -> + (match o2 with + | Atom.BO_Zmult -> + if if check_hatom0 a1 b1 then check_hatom0 a2 b2 else false + then true + else if check_hatom0 a1 b2 then check_hatom0 a2 b1 else false + | _ -> false) + | Atom.BO_Zlt -> + (match o2 with + | Atom.BO_Zlt -> + if check_hatom0 a1 b1 then check_hatom0 a2 b2 else false + | Atom.BO_Zgt -> + if check_hatom0 a1 b2 then check_hatom0 a2 b1 else false + | _ -> false) + | Atom.BO_Zle -> + (match o2 with + | Atom.BO_Zle -> + if check_hatom0 a1 b1 then check_hatom0 a2 b2 else false + | Atom.BO_Zge -> + if check_hatom0 a1 b2 then check_hatom0 a2 b1 else false + | _ -> false) + | Atom.BO_Zge -> + (match o2 with + | Atom.BO_Zle -> + if check_hatom0 a1 b2 then check_hatom0 a2 b1 else false + | Atom.BO_Zge -> + if check_hatom0 a1 b1 then check_hatom0 a2 b2 else false + | _ -> false) + | Atom.BO_Zgt -> + (match o2 with + | Atom.BO_Zlt -> + if check_hatom0 a1 b2 then check_hatom0 a2 b1 else false + | Atom.BO_Zgt -> + if check_hatom0 a1 b1 then check_hatom0 a2 b2 else false + | _ -> false) + | Atom.BO_eq t1 -> + (match o2 with + | Atom.BO_eq t2 -> + if Typ.eqb t1 t2 + then if if check_hatom0 a1 b1 then check_hatom0 a2 b2 else false + then true + else if check_hatom0 a1 b2 + then check_hatom0 a2 b1 + else false + else false + | _ -> false)) + | _ -> false) + | Atom.Anop (o1, l1) -> + (match b with + | Atom.Anop (o2, l2) -> + if Typ.eqb o1 o2 then list_beq check_hatom0 l1 l2 else false + | _ -> false) + | Atom.Aapp (f1, aargs) -> + (match b with + | Atom.Aapp (f2, bargs) -> + if eqb0 f1 f2 then list_beq check_hatom0 aargs bargs else false + | _ -> false) + +(** val check_hatom : Atom.atom array -> int -> int -> bool **) + +let check_hatom t_atom h1 h2 = + foldi_down_cont (fun x cont h3 h4 -> + if eqb0 h3 h4 + then true + else check_atom_aux t_atom cont (get t_atom h3) (get t_atom h4)) + (length t_atom) (ExtrNative.of_uint(0)) (fun h3 h4 -> false) h1 h2 + +(** val check_neg_hatom : Atom.atom array -> int -> int -> bool **) + +let check_neg_hatom t_atom h1 h2 = + match get t_atom h1 with + | Atom.Abop (op3, a1, a2) -> + (match get t_atom h2 with + | Atom.Abop (op4, b1, b2) -> + (match op3 with + | Atom.BO_Zlt -> + (match op4 with + | Atom.BO_Zle -> + if check_hatom t_atom a1 b2 + then check_hatom t_atom a2 b1 + else false + | Atom.BO_Zge -> + if check_hatom t_atom a1 b1 + then check_hatom t_atom a2 b2 + else false + | _ -> false) + | Atom.BO_Zle -> + (match op4 with + | Atom.BO_Zlt -> + if check_hatom t_atom a1 b2 + then check_hatom t_atom a2 b1 + else false + | Atom.BO_Zgt -> + if check_hatom t_atom a1 b1 + then check_hatom t_atom a2 b2 + else false + | _ -> false) + | Atom.BO_Zge -> + (match op4 with + | Atom.BO_Zlt -> + if check_hatom t_atom a1 b1 + then check_hatom t_atom a2 b2 + else false + | Atom.BO_Zgt -> + if check_hatom t_atom a1 b2 + then check_hatom t_atom a2 b1 + else false + | _ -> false) + | Atom.BO_Zgt -> + (match op4 with + | Atom.BO_Zle -> + if check_hatom t_atom a1 b1 + then check_hatom t_atom a2 b2 + else false + | Atom.BO_Zge -> + if check_hatom t_atom a1 b2 + then check_hatom t_atom a2 b1 + else false + | _ -> false) + | _ -> false) + | _ -> false) + | _ -> false + +(** val remove_not : Form.form array -> int -> int **) + +let remove_not t_form l = + match get t_form (Lit.blit l) with + | Form.Fnot2 (i, l') -> if Lit.is_pos l then l' else Lit.neg l' + | _ -> l + +(** val get_and : Form.form array -> int -> int array option **) + +let get_and t_form l = + let l0 = remove_not t_form l in + if Lit.is_pos l0 + then (match get t_form (Lit.blit l0) with + | Form.Fand args -> Some args + | _ -> None) + else None + +(** val get_or : Form.form array -> int -> int array option **) + +let get_or t_form l = + let l0 = remove_not t_form l in + if Lit.is_pos l0 + then (match get t_form (Lit.blit l0) with + | Form.For args -> Some args + | _ -> None) + else None + +(** val flatten_op_body : + (int -> int array option) -> (int list -> int -> int list) -> int list -> + int -> int list **) + +let flatten_op_body get_op frec largs l = + match get_op l with + | Some a -> fold_left frec largs a + | None -> Cons (l, largs) + +(** val flatten_op_lit : + (int -> int array option) -> int -> int list -> int -> int list **) + +let flatten_op_lit get_op max0 = + foldi_cont (fun x -> flatten_op_body get_op) (ExtrNative.of_uint(0)) max0 + (fun largs l -> Cons (l, largs)) + +(** val flatten_and : Form.form array -> int array -> int list **) + +let flatten_and t_form t0 = + fold_left (flatten_op_lit (get_and t_form) (length t_form)) Nil t0 + +(** val flatten_or : Form.form array -> int array -> int list **) + +let flatten_or t_form t0 = + fold_left (flatten_op_lit (get_or t_form) (length t_form)) Nil t0 + +(** val check_flatten_body : + Form.form array -> (int -> int -> bool) -> (int -> int -> bool) -> (int + -> int -> bool) -> int -> int -> bool **) + +let check_flatten_body t_form check_atom0 check_neg_atom frec l lf = + let l0 = remove_not t_form l in + let lf0 = remove_not t_form lf in + if eqb0 l0 lf0 + then true + else if eqb0 (land0 (ExtrNative.of_uint(1)) (lxor0 l0 lf0)) + (ExtrNative.of_uint(0)) + then (match get t_form (Lit.blit l0) with + | Form.Fatom a1 -> + (match get t_form (Lit.blit lf0) with + | Form.Fatom a2 -> check_atom0 a1 a2 + | _ -> false) + | Form.Ftrue -> + (match get t_form (Lit.blit lf0) with + | Form.Ftrue -> true + | _ -> false) + | Form.Ffalse -> + (match get t_form (Lit.blit lf0) with + | Form.Ffalse -> true + | _ -> false) + | Form.Fnot2 (i, i0) -> false + | Form.Fand args1 -> + (match get t_form (Lit.blit lf0) with + | Form.Fand args2 -> + let args3 = flatten_and t_form args1 in + let args4 = flatten_and t_form args2 in + forallb2 frec args3 args4 + | _ -> false) + | Form.For args1 -> + (match get t_form (Lit.blit lf0) with + | Form.For args2 -> + let args3 = flatten_or t_form args1 in + let args4 = flatten_or t_form args2 in + forallb2 frec args3 args4 + | _ -> false) + | Form.Fimp args1 -> + (match get t_form (Lit.blit lf0) with + | Form.Fimp args2 -> + if eqb0 (length args1) (length args2) + then forallbi (fun i l1 -> frec l1 (get args2 i)) args1 + else false + | _ -> false) + | Form.Fxor (l1, l2) -> + (match get t_form (Lit.blit lf0) with + | Form.Fxor (lf1, lf2) -> + if frec l1 lf1 then frec l2 lf2 else false + | _ -> false) + | Form.Fiff (l1, l2) -> + (match get t_form (Lit.blit lf0) with + | Form.Fiff (lf1, lf2) -> + if frec l1 lf1 then frec l2 lf2 else false + | _ -> false) + | Form.Fite (l1, l2, l3) -> + (match get t_form (Lit.blit lf0) with + | Form.Fite (lf1, lf2, lf3) -> + if if frec l1 lf1 then frec l2 lf2 else false + then frec l3 lf3 + else false + | _ -> false)) + else (match get t_form (Lit.blit l0) with + | Form.Fatom a1 -> + (match get t_form (Lit.blit lf0) with + | Form.Fatom a2 -> check_neg_atom a1 a2 + | _ -> false) + | _ -> false) + +(** val check_flatten_aux : + Form.form array -> (int -> int -> bool) -> (int -> int -> bool) -> int -> + int -> bool **) + +let check_flatten_aux t_form check_atom0 check_neg_atom l lf = + foldi_cont (fun x -> check_flatten_body t_form check_atom0 check_neg_atom) + (ExtrNative.of_uint(0)) (length t_form) (fun x x0 -> false) l lf + +(** val check_flatten : + Form.form array -> (int -> int -> bool) -> (int -> int -> bool) -> S.t -> + int -> int -> C.t **) + +let check_flatten t_form check_atom0 check_neg_atom s cid lf = + match S.get s cid with + | Nil -> C._true + | Cons (l, l0) -> + (match l0 with + | Nil -> + if check_flatten_aux t_form check_atom0 check_neg_atom l lf + then Cons (lf, Nil) + else C._true + | Cons (i, l1) -> C._true) + +(** val check_spl_arith : + Form.form array -> Atom.atom array -> int list -> int -> zArithProof list + -> C.t **) + +let check_spl_arith t_form t_atom orig res l = + match orig with + | Nil -> C._true + | Cons (li, l0) -> + (match l0 with + | Nil -> + let cl = Cons ((Lit.neg li), (Cons (res, Nil))) in + (match build_clause t_form t_atom empty_vmap cl with + | Some p -> + let v,bf = p in + if zTautoChecker bf l then Cons (res, Nil) else C._true + | None -> C._true) + | Cons (y, l1) -> C._true) + +(** val check_in : int -> int list -> bool **) + +let rec check_in x = function +| Nil -> false +| Cons (t0, q) -> if eqb0 x t0 then true else check_in x q + +(** val check_diseqs_complete_aux : + int -> int list -> (int*int) option array -> bool **) + +let rec check_diseqs_complete_aux a dist t0 = + match dist with + | Nil -> true + | Cons (b, q) -> + if existsb1 (fun x -> + match x with + | Some p -> + let a',b' = p in + if if eqb0 a a' then eqb0 b b' else false + then true + else if eqb0 a b' then eqb0 b a' else false + | None -> false) t0 + then check_diseqs_complete_aux a q t0 + else false + +(** val check_diseqs_complete : + int list -> (int*int) option array -> bool **) + +let rec check_diseqs_complete dist t0 = + match dist with + | Nil -> true + | Cons (a, q) -> + if check_diseqs_complete_aux a q t0 + then check_diseqs_complete q t0 + else false + +(** val check_diseqs : + Form.form array -> Atom.atom array -> Typ.coq_type -> int list -> int + array -> bool **) + +let check_diseqs t_form t_atom ty dist diseq = + let t0 = + mapi (fun x t0 -> + if Lit.is_pos t0 + then None + else (match get t_form (Lit.blit t0) with + | Form.Fatom a -> + (match get t_atom a with + | Atom.Acop c -> None + | Atom.Auop (u, i) -> None + | Atom.Abop (b, h1, h2) -> + (match b with + | Atom.BO_Zplus -> None + | Atom.BO_Zminus -> None + | Atom.BO_Zmult -> None + | Atom.BO_Zlt -> None + | Atom.BO_Zle -> None + | Atom.BO_Zge -> None + | Atom.BO_Zgt -> None + | Atom.BO_eq a0 -> + if if if if Typ.eqb ty a0 + then negb (eqb0 h1 h2) + else false + then check_in h1 dist + else false + then check_in h2 dist + else false + then Some (h1,h2) + else None) + | _ -> None) + | _ -> None)) diseq + in + if forallb1 (fun x -> + match x with + | Some y -> true + | None -> false) t0 + then check_diseqs_complete dist t0 + else false + +(** val check_distinct : + Form.form array -> Atom.atom array -> int -> int array -> bool **) + +let check_distinct t_form t_atom ha diseq = + match get t_atom ha with + | Atom.Anop (n0, dist) -> check_diseqs t_form t_atom n0 dist diseq + | _ -> false + +(** val check_distinct_two_args : + Form.form array -> Atom.atom array -> int -> int -> bool **) + +let check_distinct_two_args t_form t_atom f1 f2 = + match get t_form f1 with + | Form.Fatom ha -> + (match get t_form f2 with + | Form.Fatom hb -> + (match get t_atom ha with + | Atom.Anop (n0, l) -> + (match l with + | Nil -> false + | Cons (x, l0) -> + (match l0 with + | Nil -> false + | Cons (y, l1) -> + (match l1 with + | Nil -> + (match get t_atom hb with + | Atom.Abop (b, x', y') -> + (match b with + | Atom.BO_eq ty' -> + if Typ.eqb n0 ty' + then if if eqb0 x x' then eqb0 y y' else false + then true + else if eqb0 x y' then eqb0 y x' else false + else false + | _ -> false) + | _ -> false) + | Cons (i, l2) -> false))) + | _ -> false) + | _ -> false) + | _ -> false + +(** val check_lit : + Form.form array -> Atom.atom array -> (int -> int -> bool) -> int -> int + -> bool **) + +let check_lit t_form t_atom check_var l1 l2 = + if if eqb0 l1 l2 + then true + else if eqb (Lit.is_pos l1) (Lit.is_pos l2) + then check_var (Lit.blit l1) (Lit.blit l2) + else false + then true + else if eqb (Lit.is_pos l1) (negb (Lit.is_pos l2)) + then check_distinct_two_args t_form t_atom (Lit.blit l1) (Lit.blit l2) + else false + +(** val check_form_aux : + Form.form array -> Atom.atom array -> (int -> int -> bool) -> Form.form + -> Form.form -> bool **) + +let check_form_aux t_form t_atom check_var a b = + match a with + | Form.Fatom a0 -> + (match b with + | Form.Fatom b0 -> eqb0 a0 b0 + | Form.Fand diseq -> check_distinct t_form t_atom a0 diseq + | _ -> false) + | Form.Ftrue -> + (match b with + | Form.Ftrue -> true + | _ -> false) + | Form.Ffalse -> + (match b with + | Form.Ffalse -> true + | _ -> false) + | Form.Fnot2 (i1, l1) -> + (match b with + | Form.Fnot2 (i2, l2) -> + if eqb0 i1 i2 then check_lit t_form t_atom check_var l1 l2 else false + | _ -> false) + | Form.Fand a1 -> + (match b with + | Form.Fand a2 -> + if eqb0 (length a1) (length a2) + then forallbi (fun i l -> + check_lit t_form t_atom check_var l (get a2 i)) a1 + else false + | _ -> false) + | Form.For a1 -> + (match b with + | Form.For a2 -> + if eqb0 (length a1) (length a2) + then forallbi (fun i l -> + check_lit t_form t_atom check_var l (get a2 i)) a1 + else false + | _ -> false) + | Form.Fimp a1 -> + (match b with + | Form.Fimp a2 -> + if eqb0 (length a1) (length a2) + then forallbi (fun i l -> + check_lit t_form t_atom check_var l (get a2 i)) a1 + else false + | _ -> false) + | Form.Fxor (l1, l2) -> + (match b with + | Form.Fxor (j1, j2) -> + if check_lit t_form t_atom check_var l1 j1 + then check_lit t_form t_atom check_var l2 j2 + else false + | _ -> false) + | Form.Fiff (l1, l2) -> + (match b with + | Form.Fiff (j1, j2) -> + if check_lit t_form t_atom check_var l1 j1 + then check_lit t_form t_atom check_var l2 j2 + else false + | _ -> false) + | Form.Fite (l1, l2, l3) -> + (match b with + | Form.Fite (j1, j2, j3) -> + if if check_lit t_form t_atom check_var l1 j1 + then check_lit t_form t_atom check_var l2 j2 + else false + then check_lit t_form t_atom check_var l3 j3 + else false + | _ -> false) + +(** val check_hform : + Form.form array -> Atom.atom array -> int -> int -> bool **) + +let check_hform t_form t_atom h1 h2 = + foldi_down_cont (fun x cont h3 h4 -> + if eqb0 h3 h4 + then true + else check_form_aux t_form t_atom cont (get t_form h3) (get t_form h4)) + (length t_form) (ExtrNative.of_uint(0)) (fun h3 h4 -> false) h1 h2 + +(** val check_lit' : + Form.form array -> Atom.atom array -> int -> int -> bool **) + +let check_lit' t_form t_atom = + check_lit t_form t_atom (check_hform t_form t_atom) + +(** val check_distinct_elim : + Form.form array -> Atom.atom array -> int list -> int -> int list **) + +let rec check_distinct_elim t_form t_atom input res = + match input with + | Nil -> Nil + | Cons (l, q) -> + if check_lit' t_form t_atom l res + then Cons (res, q) + else Cons (l, (check_distinct_elim t_form t_atom q res)) + +type 'step _trace_ = 'step array array + +(** val _checker_ : + (S.t -> 'a1 -> S.t) -> (C.t -> bool) -> S.t -> 'a1 _trace_ -> int -> bool **) + +let _checker_ check_step is_false0 s t0 confl = + let s' = fold_left (fun s0 a -> fold_left check_step s0 a) s t0 in + is_false0 (S.get s' confl) + +module Euf_Checker = + struct + type step = + | Res of int * int array + | ImmFlatten of int * int * int + | CTrue of int + | CFalse of int + | BuildDef of int * int + | BuildDef2 of int * int + | BuildProj of int * int * int + | ImmBuildDef of int * int + | ImmBuildDef2 of int * int + | ImmBuildProj of int * int * int + | EqTr of int * int * int list + | EqCgr of int * int * int option list + | EqCgrP of int * int * int * int option list + | LiaMicromega of int * int list * zArithProof list + | LiaDiseq of int * int + | SplArith of int * int * int * zArithProof list + | SplDistinctElim of int * int * int + + (** val step_rect : + (int -> int array -> 'a1) -> (int -> int -> int -> 'a1) -> (int -> 'a1) + -> (int -> 'a1) -> (int -> int -> 'a1) -> (int -> int -> 'a1) -> (int + -> int -> int -> 'a1) -> (int -> int -> 'a1) -> (int -> int -> 'a1) -> + (int -> int -> int -> 'a1) -> (int -> int -> int list -> 'a1) -> (int + -> int -> int option list -> 'a1) -> (int -> int -> int -> int option + list -> 'a1) -> (int -> int list -> zArithProof list -> 'a1) -> (int -> + int -> 'a1) -> (int -> int -> int -> zArithProof list -> 'a1) -> (int + -> int -> int -> 'a1) -> step -> 'a1 **) + + let step_rect f f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 = function + | Res (x, x0) -> f x x0 + | ImmFlatten (x, x0, x1) -> f0 x x0 x1 + | CTrue x -> f1 x + | CFalse x -> f2 x + | BuildDef (x, x0) -> f3 x x0 + | BuildDef2 (x, x0) -> f4 x x0 + | BuildProj (x, x0, x1) -> f5 x x0 x1 + | ImmBuildDef (x, x0) -> f6 x x0 + | ImmBuildDef2 (x, x0) -> f7 x x0 + | ImmBuildProj (x, x0, x1) -> f8 x x0 x1 + | EqTr (x, x0, x1) -> f9 x x0 x1 + | EqCgr (x, x0, x1) -> f10 x x0 x1 + | EqCgrP (x, x0, x1, x2) -> f11 x x0 x1 x2 + | LiaMicromega (x, x0, x1) -> f12 x x0 x1 + | LiaDiseq (x, x0) -> f13 x x0 + | SplArith (x, x0, x1, x2) -> f14 x x0 x1 x2 + | SplDistinctElim (x, x0, x1) -> f15 x x0 x1 + + (** val step_rec : + (int -> int array -> 'a1) -> (int -> int -> int -> 'a1) -> (int -> 'a1) + -> (int -> 'a1) -> (int -> int -> 'a1) -> (int -> int -> 'a1) -> (int + -> int -> int -> 'a1) -> (int -> int -> 'a1) -> (int -> int -> 'a1) -> + (int -> int -> int -> 'a1) -> (int -> int -> int list -> 'a1) -> (int + -> int -> int option list -> 'a1) -> (int -> int -> int -> int option + list -> 'a1) -> (int -> int list -> zArithProof list -> 'a1) -> (int -> + int -> 'a1) -> (int -> int -> int -> zArithProof list -> 'a1) -> (int + -> int -> int -> 'a1) -> step -> 'a1 **) + + let step_rec f f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 = function + | Res (x, x0) -> f x x0 + | ImmFlatten (x, x0, x1) -> f0 x x0 x1 + | CTrue x -> f1 x + | CFalse x -> f2 x + | BuildDef (x, x0) -> f3 x x0 + | BuildDef2 (x, x0) -> f4 x x0 + | BuildProj (x, x0, x1) -> f5 x x0 x1 + | ImmBuildDef (x, x0) -> f6 x x0 + | ImmBuildDef2 (x, x0) -> f7 x x0 + | ImmBuildProj (x, x0, x1) -> f8 x x0 x1 + | EqTr (x, x0, x1) -> f9 x x0 x1 + | EqCgr (x, x0, x1) -> f10 x x0 x1 + | EqCgrP (x, x0, x1, x2) -> f11 x x0 x1 x2 + | LiaMicromega (x, x0, x1) -> f12 x x0 x1 + | LiaDiseq (x, x0) -> f13 x x0 + | SplArith (x, x0, x1, x2) -> f14 x x0 x1 x2 + | SplDistinctElim (x, x0, x1) -> f15 x x0 x1 + + (** val step_checker : + Atom.atom array -> Form.form array -> S.t -> step -> S.t **) + + let step_checker t_atom t_form s = function + | Res (pos, res) -> S.set_resolve s pos res + | ImmFlatten (pos, cid, lf) -> + S.set_clause s pos + (check_flatten t_form (check_hatom t_atom) (check_neg_hatom t_atom) s + cid lf) + | CTrue pos -> S.set_clause s pos check_True + | CFalse pos -> S.set_clause s pos check_False + | BuildDef (pos, l) -> S.set_clause s pos (check_BuildDef t_form l) + | BuildDef2 (pos, l) -> S.set_clause s pos (check_BuildDef2 t_form l) + | BuildProj (pos, l, i) -> S.set_clause s pos (check_BuildProj t_form l i) + | ImmBuildDef (pos, cid) -> + S.set_clause s pos (check_ImmBuildDef t_form s cid) + | ImmBuildDef2 (pos, cid) -> + S.set_clause s pos (check_ImmBuildDef2 t_form s cid) + | ImmBuildProj (pos, cid, i) -> + S.set_clause s pos (check_ImmBuildProj t_form s cid i) + | EqTr (pos, l, fl) -> S.set_clause s pos (check_trans t_form t_atom l fl) + | EqCgr (pos, l, fl) -> S.set_clause s pos (check_congr t_form t_atom l fl) + | EqCgrP (pos, l1, l2, fl) -> + S.set_clause s pos (check_congr_pred t_form t_atom l1 l2 fl) + | LiaMicromega (pos, cl, c) -> + S.set_clause s pos (check_micromega t_form t_atom cl c) + | LiaDiseq (pos, l) -> S.set_clause s pos (check_diseq t_form t_atom l) + | SplArith (pos, orig, res, l) -> + S.set_clause s pos (check_spl_arith t_form t_atom (S.get s orig) res l) + | SplDistinctElim (pos, orig, res) -> + S.set_clause s pos (check_distinct_elim t_form t_atom (S.get s orig) res) + + (** val euf_checker : + Atom.atom array -> Form.form array -> (C.t -> bool) -> S.t -> step + _trace_ -> int -> bool **) + + let euf_checker t_atom t_form s t0 = + _checker_ (step_checker t_atom t_form) s t0 + + type certif = + | Certif of int * step _trace_ * int + + (** val certif_rect : + (int -> step _trace_ -> int -> 'a1) -> certif -> 'a1 **) + + let certif_rect f = function + | Certif (x, x0, x1) -> f x x0 x1 + + (** val certif_rec : + (int -> step _trace_ -> int -> 'a1) -> certif -> 'a1 **) + + let certif_rec f = function + | Certif (x, x0, x1) -> f x x0 x1 + + (** val add_roots : S.t -> int array -> int array option -> S.t **) + + let add_roots s d = function + | Some ur -> + foldi_right (fun i c_index s0 -> + let c = + if ltb0 c_index (length d) + then Cons ((get d c_index), Nil) + else C._true + in + S.set_clause s0 i c) ur s + | None -> foldi_right (fun i c s0 -> S.set_clause s0 i (Cons (c, Nil))) d s + + (** val valid : + typ_eqb array -> Atom.tval array -> Atom.atom array -> Form.form array + -> int array -> bool **) + + let valid t_i t_func t_atom t_form d = + let rho = + Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) t_form + in + afold_left true (fun b1 b2 -> if b1 then b2 else false) (Lit.interp rho) + d + + (** val checker : + typ_eqb array -> Atom.tval array -> Atom.atom array -> Form.form array + -> int array -> int array option -> certif -> bool **) + + let checker t_i t_func t_atom t_form d used_roots = function + | Certif (nclauses, t0, confl) -> + if if if Form.check_form t_form then Atom.check_atom t_atom else false + then Atom.wt t_i t_func t_atom + else false + then euf_checker t_atom t_form C.is_false + (add_roots (S.make nclauses) d used_roots) t0 confl + else false + + (** val checker_b : + typ_eqb array -> Atom.tval array -> Atom.atom array -> Form.form array + -> int -> bool -> certif -> bool **) + + let checker_b t_i t_func t_atom t_form l b c = + let l0 = if b then Lit.neg l else l in + let Certif (nclauses, x, x0) = c in + checker t_i t_func t_atom t_form (make nclauses l0) None c + + (** val checker_eq : + typ_eqb array -> Atom.tval array -> Atom.atom array -> Form.form array + -> int -> int -> int -> certif -> bool **) + + let checker_eq t_i t_func t_atom t_form l1 l2 l c = + if if negb (Lit.is_pos l) + then (match get t_form (Lit.blit l) with + | Form.Fiff (l1', l2') -> + if eqb0 l1 l1' then eqb0 l2 l2' else false + | _ -> false) + else false + then let Certif (nclauses, x, x0) = c in + checker t_i t_func t_atom t_form (make nclauses l) None c + else false + + (** val checker_ext : + Atom.atom array -> Form.form array -> int array -> int array option -> + certif -> bool **) + + let checker_ext t_atom t_form d used_roots = function + | Certif (nclauses, t0, confl) -> + if if Form.check_form t_form then Atom.check_atom t_atom else false + then euf_checker t_atom t_form C.is_false + (add_roots (S.make nclauses) d used_roots) t0 confl + else false + end + diff --git a/src/extraction/smt_checker.mli b/src/extraction/smt_checker.mli new file mode 100644 index 0000000..502d6f3 --- /dev/null +++ b/src/extraction/smt_checker.mli @@ -0,0 +1,1889 @@ +type __ = Obj.t + +type unit0 = +| Tt + +val implb : bool -> bool -> bool + +val xorb : bool -> bool -> bool + +val negb : bool -> bool + +type nat = +| O +| S of nat + +type 'a option = +| Some of 'a +| None + +val option_map : ('a1 -> 'a2) -> 'a1 option -> 'a2 option + +val fst : ('a1*'a2) -> 'a1 + +val snd : ('a1*'a2) -> 'a2 + +type 'a list = +| Nil +| Cons of 'a * 'a list + +val app : 'a1 list -> 'a1 list -> 'a1 list + +val compOpp : ExtrNative.comparison -> ExtrNative.comparison + +type compareSpecT = +| CompEqT +| CompLtT +| CompGtT + +val compareSpec2Type : ExtrNative.comparison -> compareSpecT + +type 'a compSpecT = compareSpecT + +val compSpec2Type : 'a1 -> 'a1 -> ExtrNative.comparison -> 'a1 compSpecT + +type 'a sig0 = + 'a + (* singleton inductive, whose constructor was exist *) + +type sumbool = +| Left +| Right + +type 'a sumor = +| Inleft of 'a +| Inright + +val plus : nat -> nat -> nat + +val nat_iter : nat -> ('a1 -> 'a1) -> 'a1 -> 'a1 + +type positive = +| XI of positive +| XO of positive +| XH + +type n = +| N0 +| Npos of positive + +type z = +| Z0 +| Zpos of positive +| Zneg of positive + +val eqb : bool -> bool -> bool + +type reflect = +| ReflectT +| ReflectF + +val iff_reflect : bool -> reflect + +module type TotalOrder' = + sig + type t + end + +module MakeOrderTac : + functor (O:TotalOrder') -> + sig + + end + +module MaxLogicalProperties : + functor (O:TotalOrder') -> + functor (M:sig + val max : O.t -> O.t -> O.t + end) -> + sig + module Private_Tac : + sig + + end + end + +module Pos : + sig + type t = positive + + val succ : positive -> positive + + val add : positive -> positive -> positive + + val add_carry : positive -> positive -> positive + + val pred_double : positive -> positive + + val pred : positive -> positive + + val pred_N : positive -> n + + type mask = + | IsNul + | IsPos of positive + | IsNeg + + val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 + + val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 + + val succ_double_mask : mask -> mask + + val double_mask : mask -> mask + + val double_pred_mask : positive -> mask + + val pred_mask : mask -> mask + + val sub_mask : positive -> positive -> mask + + val sub_mask_carry : positive -> positive -> mask + + val sub : positive -> positive -> positive + + val mul : positive -> positive -> positive + + val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 + + val pow : positive -> positive -> positive + + val square : positive -> positive + + val div2 : positive -> positive + + val div2_up : positive -> positive + + val size_nat : positive -> nat + + val size : positive -> positive + + val compare_cont : + positive -> positive -> ExtrNative.comparison -> ExtrNative.comparison + + val compare : positive -> positive -> ExtrNative.comparison + + val min : positive -> positive -> positive + + val max : positive -> positive -> positive + + val eqb : positive -> positive -> bool + + val leb : positive -> positive -> bool + + val ltb : positive -> positive -> bool + + val sqrtrem_step : + (positive -> positive) -> (positive -> positive) -> (positive*mask) -> + positive*mask + + val sqrtrem : positive -> positive*mask + + val sqrt : positive -> positive + + val gcdn : nat -> positive -> positive -> positive + + val gcd : positive -> positive -> positive + + val ggcdn : nat -> positive -> positive -> positive*(positive*positive) + + val ggcd : positive -> positive -> positive*(positive*positive) + + val coq_Nsucc_double : n -> n + + val coq_Ndouble : n -> n + + val coq_lor : positive -> positive -> positive + + val coq_land : positive -> positive -> n + + val ldiff : positive -> positive -> n + + val coq_lxor : positive -> positive -> n + + val shiftl_nat : positive -> nat -> positive + + val shiftr_nat : positive -> nat -> positive + + val shiftl : positive -> n -> positive + + val shiftr : positive -> n -> positive + + val testbit_nat : positive -> nat -> bool + + val testbit : positive -> n -> bool + + val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 + + val to_nat : positive -> nat + + val of_nat : nat -> positive + + val of_succ_nat : nat -> positive + end + +module Coq_Pos : + sig + module Coq__1 : sig + type t = positive + end + type t = Coq__1.t + + val succ : positive -> positive + + val add : positive -> positive -> positive + + val add_carry : positive -> positive -> positive + + val pred_double : positive -> positive + + val pred : positive -> positive + + val pred_N : positive -> n + + type mask = Pos.mask = + | IsNul + | IsPos of positive + | IsNeg + + val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 + + val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 + + val succ_double_mask : mask -> mask + + val double_mask : mask -> mask + + val double_pred_mask : positive -> mask + + val pred_mask : mask -> mask + + val sub_mask : positive -> positive -> mask + + val sub_mask_carry : positive -> positive -> mask + + val sub : positive -> positive -> positive + + val mul : positive -> positive -> positive + + val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 + + val pow : positive -> positive -> positive + + val square : positive -> positive + + val div2 : positive -> positive + + val div2_up : positive -> positive + + val size_nat : positive -> nat + + val size : positive -> positive + + val compare_cont : + positive -> positive -> ExtrNative.comparison -> ExtrNative.comparison + + val compare : positive -> positive -> ExtrNative.comparison + + val min : positive -> positive -> positive + + val max : positive -> positive -> positive + + val eqb : positive -> positive -> bool + + val leb : positive -> positive -> bool + + val ltb : positive -> positive -> bool + + val sqrtrem_step : + (positive -> positive) -> (positive -> positive) -> (positive*mask) -> + positive*mask + + val sqrtrem : positive -> positive*mask + + val sqrt : positive -> positive + + val gcdn : nat -> positive -> positive -> positive + + val gcd : positive -> positive -> positive + + val ggcdn : nat -> positive -> positive -> positive*(positive*positive) + + val ggcd : positive -> positive -> positive*(positive*positive) + + val coq_Nsucc_double : n -> n + + val coq_Ndouble : n -> n + + val coq_lor : positive -> positive -> positive + + val coq_land : positive -> positive -> n + + val ldiff : positive -> positive -> n + + val coq_lxor : positive -> positive -> n + + val shiftl_nat : positive -> nat -> positive + + val shiftr_nat : positive -> nat -> positive + + val shiftl : positive -> n -> positive + + val shiftr : positive -> n -> positive + + val testbit_nat : positive -> nat -> bool + + val testbit : positive -> n -> bool + + val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 + + val to_nat : positive -> nat + + val of_nat : nat -> positive + + val of_succ_nat : nat -> positive + + val eq_dec : positive -> positive -> sumbool + + val peano_rect : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 + + val peano_rec : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 + + type coq_PeanoView = + | PeanoOne + | PeanoSucc of positive * coq_PeanoView + + val coq_PeanoView_rect : + 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> + coq_PeanoView -> 'a1 + + val coq_PeanoView_rec : + 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> + coq_PeanoView -> 'a1 + + val peanoView_xO : positive -> coq_PeanoView -> coq_PeanoView + + val peanoView_xI : positive -> coq_PeanoView -> coq_PeanoView + + val peanoView : positive -> coq_PeanoView + + val coq_PeanoView_iter : + 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1 + + val eqb_spec : positive -> positive -> reflect + + val switch_Eq : + ExtrNative.comparison -> ExtrNative.comparison -> ExtrNative.comparison + + val mask2cmp : mask -> ExtrNative.comparison + + val leb_spec0 : positive -> positive -> reflect + + val ltb_spec0 : positive -> positive -> reflect + + module Private_Tac : + sig + + end + + module Private_Rev : + sig + module ORev : + sig + type t = Coq__1.t + end + + module MRev : + sig + val max : t -> t -> t + end + + module MPRev : + sig + module Private_Tac : + sig + + end + end + end + + module Private_Dec : + sig + val max_case_strong : + t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + 'a1 + + val max_case : + t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 + + val max_dec : t -> t -> sumbool + + val min_case_strong : + t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + 'a1 + + val min_case : + t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 + + val min_dec : t -> t -> sumbool + end + + val max_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + + val max_case : t -> t -> 'a1 -> 'a1 -> 'a1 + + val max_dec : t -> t -> sumbool + + val min_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + + val min_case : t -> t -> 'a1 -> 'a1 -> 'a1 + + val min_dec : t -> t -> sumbool + end + +module N : + sig + type t = n + + val zero : n + + val one : n + + val two : n + + val succ_double : n -> n + + val double : n -> n + + val succ : n -> n + + val pred : n -> n + + val succ_pos : n -> positive + + val add : n -> n -> n + + val sub : n -> n -> n + + val mul : n -> n -> n + + val compare : n -> n -> ExtrNative.comparison + + val eqb : n -> n -> bool + + val leb : n -> n -> bool + + val ltb : n -> n -> bool + + val min : n -> n -> n + + val max : n -> n -> n + + val div2 : n -> n + + val even : n -> bool + + val odd : n -> bool + + val pow : n -> n -> n + + val square : n -> n + + val log2 : n -> n + + val size : n -> n + + val size_nat : n -> nat + + val pos_div_eucl : positive -> n -> n*n + + val div_eucl : n -> n -> n*n + + val div : n -> n -> n + + val modulo : n -> n -> n + + val gcd : n -> n -> n + + val ggcd : n -> n -> n*(n*n) + + val sqrtrem : n -> n*n + + val sqrt : n -> n + + val coq_lor : n -> n -> n + + val coq_land : n -> n -> n + + val ldiff : n -> n -> n + + val coq_lxor : n -> n -> n + + val shiftl_nat : n -> nat -> n + + val shiftr_nat : n -> nat -> n + + val shiftl : n -> n -> n + + val shiftr : n -> n -> n + + val testbit_nat : n -> nat -> bool + + val testbit : n -> n -> bool + + val to_nat : n -> nat + + val of_nat : nat -> n + + val iter : n -> ('a1 -> 'a1) -> 'a1 -> 'a1 + + val eq_dec : n -> n -> sumbool + + val discr : n -> positive sumor + + val binary_rect : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 + + val binary_rec : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 + + val peano_rect : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 + + val peano_rec : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 + + val leb_spec0 : n -> n -> reflect + + val ltb_spec0 : n -> n -> reflect + + module Private_BootStrap : + sig + + end + + val recursion : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 + + module Private_OrderTac : + sig + module Elts : + sig + type t = n + end + + module Tac : + sig + + end + end + + module Private_NZPow : + sig + + end + + module Private_NZSqrt : + sig + + end + + val sqrt_up : n -> n + + val log2_up : n -> n + + module Private_NZDiv : + sig + + end + + val lcm : n -> n -> n + + val eqb_spec : n -> n -> reflect + + val b2n : bool -> n + + val setbit : n -> n -> n + + val clearbit : n -> n -> n + + val ones : n -> n + + val lnot : n -> n -> n + + module Private_Tac : + sig + + end + + module Private_Rev : + sig + module ORev : + sig + type t = n + end + + module MRev : + sig + val max : n -> n -> n + end + + module MPRev : + sig + module Private_Tac : + sig + + end + end + end + + module Private_Dec : + sig + val max_case_strong : + n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + 'a1 + + val max_case : + n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 + + val max_dec : n -> n -> sumbool + + val min_case_strong : + n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + 'a1 + + val min_case : + n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 + + val min_dec : n -> n -> sumbool + end + + val max_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + + val max_case : n -> n -> 'a1 -> 'a1 -> 'a1 + + val max_dec : n -> n -> sumbool + + val min_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + + val min_case : n -> n -> 'a1 -> 'a1 -> 'a1 + + val min_dec : n -> n -> sumbool + end + +module Z : + sig + type t = z + + val zero : z + + val one : z + + val two : z + + val double : z -> z + + val succ_double : z -> z + + val pred_double : z -> z + + val pos_sub : positive -> positive -> z + + val add : z -> z -> z + + val opp : z -> z + + val succ : z -> z + + val pred : z -> z + + val sub : z -> z -> z + + val mul : z -> z -> z + + val pow_pos : z -> positive -> z + + val pow : z -> z -> z + + val square : z -> z + + val compare : z -> z -> ExtrNative.comparison + + val sgn : z -> z + + val leb : z -> z -> bool + + val ltb : z -> z -> bool + + val geb : z -> z -> bool + + val gtb : z -> z -> bool + + val eqb : z -> z -> bool + + val max : z -> z -> z + + val min : z -> z -> z + + val abs : z -> z + + val abs_nat : z -> nat + + val abs_N : z -> n + + val to_nat : z -> nat + + val to_N : z -> n + + val of_nat : nat -> z + + val of_N : n -> z + + val iter : z -> ('a1 -> 'a1) -> 'a1 -> 'a1 + + val pos_div_eucl : positive -> z -> z*z + + val div_eucl : z -> z -> z*z + + val div : z -> z -> z + + val modulo : z -> z -> z + + val quotrem : z -> z -> z*z + + val quot : z -> z -> z + + val rem : z -> z -> z + + val even : z -> bool + + val odd : z -> bool + + val div2 : z -> z + + val quot2 : z -> z + + val log2 : z -> z + + val sqrtrem : z -> z*z + + val sqrt : z -> z + + val gcd : z -> z -> z + + val ggcd : z -> z -> z*(z*z) + + val testbit : z -> z -> bool + + val shiftl : z -> z -> z + + val shiftr : z -> z -> z + + val coq_lor : z -> z -> z + + val coq_land : z -> z -> z + + val ldiff : z -> z -> z + + val coq_lxor : z -> z -> z + + val eq_dec : z -> z -> sumbool + + module Private_BootStrap : + sig + + end + + val leb_spec0 : z -> z -> reflect + + val ltb_spec0 : z -> z -> reflect + + module Private_OrderTac : + sig + module Elts : + sig + type t = z + end + + module Tac : + sig + + end + end + + val sqrt_up : z -> z + + val log2_up : z -> z + + module Private_NZDiv : + sig + + end + + module Private_Div : + sig + module Quot2Div : + sig + val div : z -> z -> z + + val modulo : z -> z -> z + end + + module NZQuot : + sig + + end + end + + val lcm : z -> z -> z + + val eqb_spec : z -> z -> reflect + + val b2z : bool -> z + + val setbit : z -> z -> z + + val clearbit : z -> z -> z + + val lnot : z -> z + + val ones : z -> z + + module Private_Tac : + sig + + end + + module Private_Rev : + sig + module ORev : + sig + type t = z + end + + module MRev : + sig + val max : z -> z -> z + end + + module MPRev : + sig + module Private_Tac : + sig + + end + end + end + + module Private_Dec : + sig + val max_case_strong : + z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + 'a1 + + val max_case : + z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 + + val max_dec : z -> z -> sumbool + + val min_case_strong : + z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + 'a1 + + val min_case : + z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 + + val min_dec : z -> z -> sumbool + end + + val max_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + + val max_case : z -> z -> 'a1 -> 'a1 -> 'a1 + + val max_dec : z -> z -> sumbool + + val min_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + + val min_case : z -> z -> 'a1 -> 'a1 -> 'a1 + + val min_dec : z -> z -> sumbool + end + +val zeq_bool : z -> z -> bool + +val nth : nat -> 'a1 list -> 'a1 -> 'a1 + +val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list + +val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 + +val existsb : ('a1 -> bool) -> 'a1 list -> bool + +val forallb : ('a1 -> bool) -> 'a1 list -> bool + +type int = ExtrNative.uint + +val lsl0 : int -> int -> int + +val lsr0 : int -> int -> int + +val land0 : int -> int -> int + +val lxor0 : int -> int -> int + +val sub0 : int -> int -> int + +val eqb0 : int -> int -> bool + +val ltb0 : int -> int -> bool + +val leb0 : int -> int -> bool + +val foldi_cont : + (int -> ('a1 -> 'a2) -> 'a1 -> 'a2) -> int -> int -> ('a1 -> 'a2) -> 'a1 -> + 'a2 + +val foldi_down_cont : + (int -> ('a1 -> 'a2) -> 'a1 -> 'a2) -> int -> int -> ('a1 -> 'a2) -> 'a1 -> + 'a2 + +val is_zero : int -> bool + +val is_even : int -> bool + +val compare0 : int -> int -> ExtrNative.comparison + +val foldi : (int -> 'a1 -> 'a1) -> int -> int -> 'a1 -> 'a1 + +val fold : ('a1 -> 'a1) -> int -> int -> 'a1 -> 'a1 + +val foldi_down : (int -> 'a1 -> 'a1) -> int -> int -> 'a1 -> 'a1 + +val forallb0 : (int -> bool) -> int -> int -> bool + +val existsb0 : (int -> bool) -> int -> int -> bool + +val cast : int -> int -> (__ -> __ -> __) option + +val reflect_eqb : int -> int -> reflect + +type 'a array = 'a ExtrNative.parray + +val make : int -> 'a1 -> 'a1 array + +val get : 'a1 array -> int -> 'a1 + +val default : 'a1 array -> 'a1 + +val set : 'a1 array -> int -> 'a1 -> 'a1 array + +val length : 'a1 array -> int + +val to_list : 'a1 array -> 'a1 list + +val forallbi : (int -> 'a1 -> bool) -> 'a1 array -> bool + +val forallb1 : ('a1 -> bool) -> 'a1 array -> bool + +val existsb1 : ('a1 -> bool) -> 'a1 array -> bool + +val mapi : (int -> 'a1 -> 'a2) -> 'a1 array -> 'a2 array + +val foldi_left : (int -> 'a1 -> 'a2 -> 'a1) -> 'a1 -> 'a2 array -> 'a1 + +val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a1 -> 'a2 array -> 'a1 + +val foldi_right : (int -> 'a1 -> 'a2 -> 'a2) -> 'a1 array -> 'a2 -> 'a2 + +module Valuation : + sig + type t = int -> bool + end + +module Var : + sig + val _true : int + + val _false : int + + val interp : Valuation.t -> int -> bool + end + +module Lit : + sig + val is_pos : int -> bool + + val blit : int -> int + + val lit : int -> int + + val neg : int -> int + + val nlit : int -> int + + val _true : int + + val _false : int + + val eqb : int -> int -> bool + + val interp : Valuation.t -> int -> bool + end + +module C : + sig + type t = int list + + val interp : Valuation.t -> t -> bool + + val _true : t + + val is_false : t -> bool + + val or_aux : (t -> t -> t) -> int -> t -> t -> int list + + val coq_or : t -> t -> t + + val resolve_aux : (t -> t -> t) -> int -> t -> t -> t + + val resolve : t -> t -> t + end + +module S : + sig + type t = C.t array + + val get : t -> int -> C.t + + val internal_set : t -> int -> C.t -> t + + val make : int -> t + + val insert : int -> int list -> int list + + val sort_uniq : int list -> int list + + val set_clause : t -> int -> C.t -> t + + val set_resolve : t -> int -> int array -> t + end + +val afold_left : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a2 -> 'a1) -> 'a2 array -> 'a1 + +val afold_right : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a2 -> 'a1) -> 'a2 array -> 'a1 + +val rev_aux : 'a1 list -> 'a1 list -> 'a1 list + +val rev : 'a1 list -> 'a1 list + +val distinct_aux2 : ('a1 -> 'a1 -> bool) -> bool -> 'a1 -> 'a1 list -> bool + +val distinct_aux : ('a1 -> 'a1 -> bool) -> bool -> 'a1 list -> bool + +val distinct : ('a1 -> 'a1 -> bool) -> 'a1 list -> bool + +val forallb2 : ('a1 -> 'a2 -> bool) -> 'a1 list -> 'a2 list -> bool + +module Form : + sig + type form = + | Fatom of int + | Ftrue + | Ffalse + | Fnot2 of int * int + | Fand of int array + | For of int array + | Fimp of int array + | Fxor of int * int + | Fiff of int * int + | Fite of int * int * int + + val form_rect : + (int -> 'a1) -> 'a1 -> 'a1 -> (int -> int -> 'a1) -> (int array -> 'a1) + -> (int array -> 'a1) -> (int array -> 'a1) -> (int -> int -> 'a1) -> + (int -> int -> 'a1) -> (int -> int -> int -> 'a1) -> form -> 'a1 + + val form_rec : + (int -> 'a1) -> 'a1 -> 'a1 -> (int -> int -> 'a1) -> (int array -> 'a1) + -> (int array -> 'a1) -> (int array -> 'a1) -> (int -> int -> 'a1) -> + (int -> int -> 'a1) -> (int -> int -> int -> 'a1) -> form -> 'a1 + + val is_Ftrue : form -> bool + + val is_Ffalse : form -> bool + + val interp_aux : (int -> bool) -> (int -> bool) -> form -> bool + + val t_interp : (int -> bool) -> form array -> bool array + + val lt_form : int -> form -> bool + + val wf : form array -> bool + + val interp_state_var : (int -> bool) -> form array -> int -> bool + + val interp : (int -> bool) -> form array -> form -> bool + + val check_form : form array -> bool + end + +type typ_eqb = { te_eqb : (__ -> __ -> bool); + te_reflect : (__ -> __ -> reflect) } + +type te_carrier = __ + +val te_eqb : typ_eqb -> te_carrier -> te_carrier -> bool + +module Typ : + sig + type coq_type = + | Tindex of int + | TZ + | Tbool + | Tpositive + + val type_rect : (int -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> coq_type -> 'a1 + + val type_rec : (int -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> coq_type -> 'a1 + + type ftype = coq_type list*coq_type + + type interp = __ + + type interp_ftype = __ + + val i_eqb : typ_eqb array -> coq_type -> interp -> interp -> bool + + val reflect_i_eqb : + typ_eqb array -> coq_type -> interp -> interp -> reflect + + type cast_result = + | Cast of (__ -> __ -> __) + | NoCast + + val cast_result_rect : + coq_type -> coq_type -> ((__ -> __ -> __) -> 'a1) -> 'a1 -> cast_result + -> 'a1 + + val cast_result_rec : + coq_type -> coq_type -> ((__ -> __ -> __) -> 'a1) -> 'a1 -> cast_result + -> 'a1 + + val cast : coq_type -> coq_type -> cast_result + + val eqb : coq_type -> coq_type -> bool + + val reflect_eqb : coq_type -> coq_type -> reflect + end + +val list_beq : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list -> bool + +val reflect_list_beq : + ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> reflect) -> 'a1 list -> 'a1 list -> + reflect + +module Atom : + sig + type cop = + | CO_xH + | CO_Z0 + + val cop_rect : 'a1 -> 'a1 -> cop -> 'a1 + + val cop_rec : 'a1 -> 'a1 -> cop -> 'a1 + + type unop = + | UO_xO + | UO_xI + | UO_Zpos + | UO_Zneg + | UO_Zopp + + val unop_rect : 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> unop -> 'a1 + + val unop_rec : 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> unop -> 'a1 + + type binop = + | BO_Zplus + | BO_Zminus + | BO_Zmult + | BO_Zlt + | BO_Zle + | BO_Zge + | BO_Zgt + | BO_eq of Typ.coq_type + + val binop_rect : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> (Typ.coq_type -> 'a1) -> + binop -> 'a1 + + val binop_rec : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> (Typ.coq_type -> 'a1) -> + binop -> 'a1 + + type nop = + Typ.coq_type + (* singleton inductive, whose constructor was NO_distinct *) + + val nop_rect : (Typ.coq_type -> 'a1) -> nop -> 'a1 + + val nop_rec : (Typ.coq_type -> 'a1) -> nop -> 'a1 + + type atom = + | Acop of cop + | Auop of unop * int + | Abop of binop * int * int + | Anop of nop * int list + | Aapp of int * int list + + val atom_rect : + (cop -> 'a1) -> (unop -> int -> 'a1) -> (binop -> int -> int -> 'a1) -> + (nop -> int list -> 'a1) -> (int -> int list -> 'a1) -> atom -> 'a1 + + val atom_rec : + (cop -> 'a1) -> (unop -> int -> 'a1) -> (binop -> int -> int -> 'a1) -> + (nop -> int list -> 'a1) -> (int -> int list -> 'a1) -> atom -> 'a1 + + val cop_eqb : cop -> cop -> bool + + val uop_eqb : unop -> unop -> bool + + val bop_eqb : binop -> binop -> bool + + val nop_eqb : nop -> nop -> bool + + val eqb : atom -> atom -> bool + + val reflect_cop_eqb : cop -> cop -> reflect + + val reflect_uop_eqb : unop -> unop -> reflect + + val reflect_bop_eqb : binop -> binop -> reflect + + val reflect_nop_eqb : nop -> nop -> reflect + + val reflect_eqb : atom -> atom -> reflect + + type ('t, 'i) coq_val = { v_type : 't; v_val : 'i } + + val val_rect : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) coq_val -> 'a3 + + val val_rec : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) coq_val -> 'a3 + + val v_type : ('a1, 'a2) coq_val -> 'a1 + + val v_val : ('a1, 'a2) coq_val -> 'a2 + + type bval = (Typ.coq_type, Typ.interp) coq_val + + val coq_Bval : + typ_eqb array -> Typ.coq_type -> Typ.interp -> (Typ.coq_type, Typ.interp) + coq_val + + type tval = (Typ.ftype, Typ.interp_ftype) coq_val + + val coq_Tval : + typ_eqb array -> Typ.ftype -> Typ.interp_ftype -> (Typ.ftype, + Typ.interp_ftype) coq_val + + val bvtrue : typ_eqb array -> bval + + val bvfalse : typ_eqb array -> bval + + val typ_cop : cop -> Typ.coq_type + + val typ_uop : unop -> Typ.coq_type*Typ.coq_type + + val typ_bop : binop -> (Typ.coq_type*Typ.coq_type)*Typ.coq_type + + val typ_nop : nop -> Typ.coq_type*Typ.coq_type + + val check_args : + (int -> Typ.coq_type) -> int list -> Typ.coq_type list -> bool + + val check_aux : + typ_eqb array -> tval array -> (int -> Typ.coq_type) -> atom -> + Typ.coq_type -> bool + + val check_args_dec : + (int -> Typ.coq_type) -> Typ.coq_type -> int list -> Typ.coq_type list -> + sumbool + + val check_aux_dec : + typ_eqb array -> tval array -> (int -> Typ.coq_type) -> atom -> sumbool + + val apply_unop : + typ_eqb array -> Typ.coq_type -> Typ.coq_type -> (Typ.interp -> + Typ.interp) -> bval -> (Typ.coq_type, Typ.interp) coq_val + + val apply_binop : + typ_eqb array -> Typ.coq_type -> Typ.coq_type -> Typ.coq_type -> + (Typ.interp -> Typ.interp -> Typ.interp) -> bval -> bval -> + (Typ.coq_type, Typ.interp) coq_val + + val apply_func : + typ_eqb array -> Typ.coq_type list -> Typ.coq_type -> Typ.interp_ftype -> + bval list -> bval + + val interp_cop : typ_eqb array -> cop -> (Typ.coq_type, Typ.interp) coq_val + + val interp_uop : + typ_eqb array -> unop -> bval -> (Typ.coq_type, Typ.interp) coq_val + + val interp_bop : + typ_eqb array -> binop -> bval -> bval -> (Typ.coq_type, Typ.interp) + coq_val + + val compute_interp : + typ_eqb array -> (int -> bval) -> Typ.coq_type -> Typ.interp list -> int + list -> Typ.interp list option + + val interp_aux : + typ_eqb array -> tval array -> (int -> bval) -> atom -> bval + + val interp_bool : typ_eqb array -> bval -> bool + + val t_interp : typ_eqb array -> tval array -> atom array -> bval array + + val lt_atom : int -> atom -> bool + + val wf : atom array -> bool + + val get_type' : typ_eqb array -> bval array -> int -> Typ.coq_type + + val get_type : + typ_eqb array -> tval array -> atom array -> int -> Typ.coq_type + + val wt : typ_eqb array -> tval array -> atom array -> bool + + val interp_hatom : typ_eqb array -> tval array -> atom array -> int -> bval + + val interp : typ_eqb array -> tval array -> atom array -> atom -> bval + + val interp_form_hatom : + typ_eqb array -> tval array -> atom array -> int -> bool + + val check_atom : atom array -> bool + end + +val or_of_imp : int array -> int array + +val check_True : C.t + +val check_False : int list + +val check_BuildDef : Form.form array -> int -> C.t + +val check_ImmBuildDef : Form.form array -> S.t -> int -> C.t + +val check_BuildDef2 : Form.form array -> int -> C.t + +val check_ImmBuildDef2 : Form.form array -> S.t -> int -> C.t + +val check_BuildProj : Form.form array -> int -> int -> C.t + +val check_ImmBuildProj : Form.form array -> S.t -> int -> int -> C.t + +val get_eq : + Form.form array -> Atom.atom array -> int -> (int -> int -> C.t) -> C.t + +val check_trans_aux : + Form.form array -> Atom.atom array -> int -> int -> int list -> int -> C.t + -> C.t + +val check_trans : + Form.form array -> Atom.atom array -> int -> int list -> C.t + +val build_congr : + Form.form array -> Atom.atom array -> int option list -> int list -> int + list -> C.t -> C.t + +val check_congr : + Form.form array -> Atom.atom array -> int -> int option list -> C.t + +val check_congr_pred : + Form.form array -> Atom.atom array -> int -> int -> int option list -> C.t + +type 'c pol = +| Pc of 'c +| Pinj of positive * 'c pol +| PX of 'c pol * positive * 'c pol + +val p0 : 'a1 -> 'a1 pol + +val p1 : 'a1 -> 'a1 pol + +val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool + +val mkPinj : positive -> 'a1 pol -> 'a1 pol + +val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol + +val mkPX : + 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + +val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol + +val mkX : 'a1 -> 'a1 -> 'a1 pol + +val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol + +val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol + +val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol + +val paddI : + ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> + positive -> 'a1 pol -> 'a1 pol + +val psubI : + ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> + 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + +val paddX : + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol + -> positive -> 'a1 pol -> 'a1 pol + +val psubX : + 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 + pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + +val padd : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> + 'a1 pol + +val psub : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 + -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol + +val pmulC_aux : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 + pol + +val pmulC : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 + -> 'a1 pol + +val pmulI : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> + 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + +val pmul : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol + +val psquare : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> 'a1 pol -> 'a1 pol + +type 'c pExpr = +| PEc of 'c +| PEX of positive +| PEadd of 'c pExpr * 'c pExpr +| PEsub of 'c pExpr * 'c pExpr +| PEmul of 'c pExpr * 'c pExpr +| PEopp of 'c pExpr +| PEpow of 'c pExpr * n + +val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol + +val ppow_pos : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol + +val ppow_N : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol + +val norm_aux : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + +type 'a bFormula = +| TT +| FF +| X +| A of 'a +| Cj of 'a bFormula * 'a bFormula +| D of 'a bFormula * 'a bFormula +| N of 'a bFormula +| I of 'a bFormula * 'a bFormula + +type 'term' clause = 'term' list + +type 'term' cnf = 'term' clause list + +val tt : 'a1 cnf + +val ff : 'a1 cnf + +val add_term : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 + clause option + +val or_clause : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause -> + 'a1 clause option + +val or_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> 'a1 + cnf + +val or_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 + cnf + +val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf + +val xcnf : + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> + 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf + +val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool + +val tauto_checker : + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> + 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> bool + +val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool + +val cltb : ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool + +type 'c polC = 'c pol + +type op1 = +| Equal +| NonEqual +| Strict +| NonStrict + +type 'c nFormula = 'c polC*op1 + +val opMult : op1 -> op1 -> op1 option + +val opAdd : op1 -> op1 -> op1 option + +type 'c psatz = +| PsatzIn of nat +| PsatzSquare of 'c polC +| PsatzMulC of 'c polC * 'c psatz +| PsatzMulE of 'c psatz * 'c psatz +| PsatzAdd of 'c psatz * 'c psatz +| PsatzC of 'c +| PsatzZ + +val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option + +val map_option2 : + ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option + +val pexpr_times_nformula : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option + +val nformula_times_nformula : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option + +val nformula_plus_nformula : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 + nFormula -> 'a1 nFormula option + +val eval_Psatz : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 + nFormula option + +val check_inconsistent : + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool + +type op2 = +| OpEq +| OpNEq +| OpLe +| OpGe +| OpLt +| OpGt + +type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } + +val norm : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + +val psub0 : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 + -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol + +val padd0 : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> + 'a1 pol + +type zWitness = z psatz + +val psub1 : z pol -> z pol -> z pol + +val padd1 : z pol -> z pol -> z pol + +val norm0 : z pExpr -> z pol + +val xnormalise : z formula -> z nFormula list + +val normalise : z formula -> z nFormula cnf + +val xnegate : z formula -> z nFormula list + +val negate : z formula -> z nFormula cnf + +val zunsat : z nFormula -> bool + +val zdeduce : z nFormula -> z nFormula -> z nFormula option + +val ceiling : z -> z -> z + +type zArithProof = +| DoneProof +| RatProof of zWitness * zArithProof +| CutProof of zWitness * zArithProof +| EnumProof of zWitness * zWitness * zArithProof list + +val zgcdM : z -> z -> z + +val zgcd_pol : z polC -> z*z + +val zdiv_pol : z polC -> z -> z polC + +val makeCuttingPlane : z polC -> z polC*z + +val genCuttingPlane : z nFormula -> ((z polC*z)*op1) option + +val nformula_of_cutting_plane : ((z polC*z)*op1) -> z nFormula + +val is_pol_Z0 : z polC -> bool + +val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option + +val valid_cut_sign : op1 -> bool + +val zChecker : z nFormula list -> zArithProof -> bool + +val zTautoChecker : z formula bFormula -> zArithProof list -> bool + +val build_positive_atom_aux : + (int -> positive option) -> Atom.atom -> positive option + +val build_positive : Atom.atom array -> int -> positive option + +val build_z_atom_aux : Atom.atom array -> Atom.atom -> z option + +val build_z_atom : Atom.atom array -> Atom.atom -> z option + +type vmap = positive*Atom.atom list + +val find_var_aux : Atom.atom -> positive -> Atom.atom list -> positive option + +val find_var : vmap -> Atom.atom -> vmap*positive + +val empty_vmap : vmap + +val build_pexpr_atom_aux : + Atom.atom array -> (vmap -> int -> vmap*z pExpr) -> vmap -> Atom.atom -> + vmap*z pExpr + +val build_pexpr : Atom.atom array -> vmap -> int -> vmap*z pExpr + +val build_op2 : Atom.binop -> op2 option + +val build_formula_atom : + Atom.atom array -> vmap -> Atom.atom -> (vmap*z formula) option + +val build_formula : Atom.atom array -> vmap -> int -> (vmap*z formula) option + +val build_not2 : int -> z formula bFormula -> z formula bFormula + +val build_hform : + Atom.atom array -> (vmap -> int -> (vmap*z formula bFormula) option) -> + vmap -> Form.form -> (vmap*z formula bFormula) option + +val build_var : + Form.form array -> Atom.atom array -> vmap -> int -> (vmap*z formula + bFormula) option + +val build_form : + Form.form array -> Atom.atom array -> vmap -> Form.form -> (vmap*z formula + bFormula) option + +val build_nlit : + Form.form array -> Atom.atom array -> vmap -> int -> (vmap*z formula + bFormula) option + +val build_clause_aux : + Form.form array -> Atom.atom array -> vmap -> int list -> (vmap*z formula + bFormula) option + +val build_clause : + Form.form array -> Atom.atom array -> vmap -> int list -> (vmap*z formula + bFormula) option + +val get_eq0 : + Form.form array -> Atom.atom array -> int -> (int -> int -> C.t) -> C.t + +val get_not_le : + Form.form array -> Atom.atom array -> int -> (int -> int -> C.t) -> C.t + +val check_micromega : + Form.form array -> Atom.atom array -> int list -> zArithProof list -> C.t + +val check_diseq : Form.form array -> Atom.atom array -> int -> C.t + +val check_atom_aux : + Atom.atom array -> (int -> int -> bool) -> Atom.atom -> Atom.atom -> bool + +val check_hatom : Atom.atom array -> int -> int -> bool + +val check_neg_hatom : Atom.atom array -> int -> int -> bool + +val remove_not : Form.form array -> int -> int + +val get_and : Form.form array -> int -> int array option + +val get_or : Form.form array -> int -> int array option + +val flatten_op_body : + (int -> int array option) -> (int list -> int -> int list) -> int list -> + int -> int list + +val flatten_op_lit : + (int -> int array option) -> int -> int list -> int -> int list + +val flatten_and : Form.form array -> int array -> int list + +val flatten_or : Form.form array -> int array -> int list + +val check_flatten_body : + Form.form array -> (int -> int -> bool) -> (int -> int -> bool) -> (int -> + int -> bool) -> int -> int -> bool + +val check_flatten_aux : + Form.form array -> (int -> int -> bool) -> (int -> int -> bool) -> int -> + int -> bool + +val check_flatten : + Form.form array -> (int -> int -> bool) -> (int -> int -> bool) -> S.t -> + int -> int -> C.t + +val check_spl_arith : + Form.form array -> Atom.atom array -> int list -> int -> zArithProof list + -> C.t + +val check_in : int -> int list -> bool + +val check_diseqs_complete_aux : + int -> int list -> (int*int) option array -> bool + +val check_diseqs_complete : int list -> (int*int) option array -> bool + +val check_diseqs : + Form.form array -> Atom.atom array -> Typ.coq_type -> int list -> int array + -> bool + +val check_distinct : + Form.form array -> Atom.atom array -> int -> int array -> bool + +val check_distinct_two_args : + Form.form array -> Atom.atom array -> int -> int -> bool + +val check_lit : + Form.form array -> Atom.atom array -> (int -> int -> bool) -> int -> int -> + bool + +val check_form_aux : + Form.form array -> Atom.atom array -> (int -> int -> bool) -> Form.form -> + Form.form -> bool + +val check_hform : Form.form array -> Atom.atom array -> int -> int -> bool + +val check_lit' : Form.form array -> Atom.atom array -> int -> int -> bool + +val check_distinct_elim : + Form.form array -> Atom.atom array -> int list -> int -> int list + +type 'step _trace_ = 'step array array + +val _checker_ : + (S.t -> 'a1 -> S.t) -> (C.t -> bool) -> S.t -> 'a1 _trace_ -> int -> bool + +module Euf_Checker : + sig + type step = + | Res of int * int array + | ImmFlatten of int * int * int + | CTrue of int + | CFalse of int + | BuildDef of int * int + | BuildDef2 of int * int + | BuildProj of int * int * int + | ImmBuildDef of int * int + | ImmBuildDef2 of int * int + | ImmBuildProj of int * int * int + | EqTr of int * int * int list + | EqCgr of int * int * int option list + | EqCgrP of int * int * int * int option list + | LiaMicromega of int * int list * zArithProof list + | LiaDiseq of int * int + | SplArith of int * int * int * zArithProof list + | SplDistinctElim of int * int * int + + val step_rect : + (int -> int array -> 'a1) -> (int -> int -> int -> 'a1) -> (int -> 'a1) + -> (int -> 'a1) -> (int -> int -> 'a1) -> (int -> int -> 'a1) -> (int -> + int -> int -> 'a1) -> (int -> int -> 'a1) -> (int -> int -> 'a1) -> (int + -> int -> int -> 'a1) -> (int -> int -> int list -> 'a1) -> (int -> int + -> int option list -> 'a1) -> (int -> int -> int -> int option list -> + 'a1) -> (int -> int list -> zArithProof list -> 'a1) -> (int -> int -> + 'a1) -> (int -> int -> int -> zArithProof list -> 'a1) -> (int -> int -> + int -> 'a1) -> step -> 'a1 + + val step_rec : + (int -> int array -> 'a1) -> (int -> int -> int -> 'a1) -> (int -> 'a1) + -> (int -> 'a1) -> (int -> int -> 'a1) -> (int -> int -> 'a1) -> (int -> + int -> int -> 'a1) -> (int -> int -> 'a1) -> (int -> int -> 'a1) -> (int + -> int -> int -> 'a1) -> (int -> int -> int list -> 'a1) -> (int -> int + -> int option list -> 'a1) -> (int -> int -> int -> int option list -> + 'a1) -> (int -> int list -> zArithProof list -> 'a1) -> (int -> int -> + 'a1) -> (int -> int -> int -> zArithProof list -> 'a1) -> (int -> int -> + int -> 'a1) -> step -> 'a1 + + val step_checker : Atom.atom array -> Form.form array -> S.t -> step -> S.t + + val euf_checker : + Atom.atom array -> Form.form array -> (C.t -> bool) -> S.t -> step + _trace_ -> int -> bool + + type certif = + | Certif of int * step _trace_ * int + + val certif_rect : (int -> step _trace_ -> int -> 'a1) -> certif -> 'a1 + + val certif_rec : (int -> step _trace_ -> int -> 'a1) -> certif -> 'a1 + + val add_roots : S.t -> int array -> int array option -> S.t + + val valid : + typ_eqb array -> Atom.tval array -> Atom.atom array -> Form.form array -> + int array -> bool + + val checker : + typ_eqb array -> Atom.tval array -> Atom.atom array -> Form.form array -> + int array -> int array option -> certif -> bool + + val checker_b : + typ_eqb array -> Atom.tval array -> Atom.atom array -> Form.form array -> + int -> bool -> certif -> bool + + val checker_eq : + typ_eqb array -> Atom.tval array -> Atom.atom array -> Form.form array -> + int -> int -> int -> certif -> bool + + val checker_ext : + Atom.atom array -> Form.form array -> int array -> int array option -> + certif -> bool + end + diff --git a/src/extraction/test.ml b/src/extraction/test.ml new file mode 100644 index 0000000..0b16b7f --- /dev/null +++ b/src/extraction/test.ml @@ -0,0 +1,42 @@ +let _ = Printf.printf "Zchaff_checker.checker \"tests/sat1.cnf\" \"tests/sat1.zlog\" = %b\n" (Zchaff_checker.checker "tests/sat1.cnf" "tests/sat1.zlog") +let _ = Printf.printf "Zchaff_checker.checker \"tests/sat2.cnf\" \"tests/sat2.zlog\" = %b\n" (Zchaff_checker.checker "tests/sat2.cnf" "tests/sat2.zlog") +let _ = Printf.printf "Zchaff_checker.checker \"tests/sat3.cnf\" \"tests/sat3.zlog\" = %b\n" (Zchaff_checker.checker "tests/sat3.cnf" "tests/sat3.zlog") +let _ = Printf.printf "Zchaff_checker.checker \"tests/sat5.cnf\" \"tests/sat5.zlog\" = %b\n" (Zchaff_checker.checker "tests/sat5.cnf" "tests/sat5.zlog") +let _ = Printf.printf "Zchaff_checker.checker \"tests/sat6.cnf\" \"tests/sat6.zlog\" = %b\n" (Zchaff_checker.checker "tests/sat6.cnf" "tests/sat6.zlog") +let _ = Printf.printf "Zchaff_checker.checker \"tests/sat7.cnf\" \"tests/sat7.zlog\" = %b\n" (Zchaff_checker.checker "tests/sat7.cnf" "tests/sat7.zlog") +let _ = Printf.printf "Zchaff_checker.checker \"tests/hole4.cnf\" \"tests/hole4.zlog\" = %b\n" (Zchaff_checker.checker "tests/hole4.cnf" "tests/hole4.zlog") +let _ = Printf.printf "Zchaff_checker.checker \"tests/cmu-bmc-barrel6.cnf\" \"tests/cmu-bmc-barrel6.zlog\" = %b\n" (Zchaff_checker.checker "tests/cmu-bmc-barrel6.cnf" "tests/cmu-bmc-barrel6.zlog") +let _ = Printf.printf "Zchaff_checker.checker \"tests/velev-sss-1.0-05.cnf\" \"tests/velev-sss-1.0-05.zlog\" = %b\n" (Zchaff_checker.checker "tests/velev-sss-1.0-05.cnf" "tests/velev-sss-1.0-05.zlog") + + + + +let _ = Printf.printf "Verit_checker.checker \"tests/sat1.smt2\" \"tests/sat1.vtlog\" = %b\n" (Verit_checker.checker "tests/sat1.smt2" "tests/sat1.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/sat2.smt2\" \"tests/sat2.vtlog\" = %b\n" (Verit_checker.checker "tests/sat2.smt2" "tests/sat2.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/sat3.smt2\" \"tests/sat3.vtlog\" = %b\n" (Verit_checker.checker "tests/sat3.smt2" "tests/sat3.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/sat4.smt2\" \"tests/sat4.vtlog\" = %b\n" (Verit_checker.checker "tests/sat4.smt2" "tests/sat4.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/sat5.smt2\" \"tests/sat5.vtlog\" = %b\n" (Verit_checker.checker "tests/sat5.smt2" "tests/sat5.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/sat6.smt2\" \"tests/sat6.vtlog\" = %b\n" (Verit_checker.checker "tests/sat6.smt2" "tests/sat6.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/sat7.smt2\" \"tests/sat7.vtlog\" = %b\n" (Verit_checker.checker "tests/sat7.smt2" "tests/sat7.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/sat8.smt2\" \"tests/sat8.vtlog\" = %b\n" (Verit_checker.checker "tests/sat8.smt2" "tests/sat8.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/sat9.smt2\" \"tests/sat9.vtlog\" = %b\n" (Verit_checker.checker "tests/sat9.smt2" "tests/sat9.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/sat11.smt2\" \"tests/sat11.vtlog\" = %b\n" (Verit_checker.checker "tests/sat11.smt2" "tests/sat11.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/sat12.smt2\" \"tests/sat12.vtlog\" = %b\n" (Verit_checker.checker "tests/sat12.smt2" "tests/sat12.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/sat13.smt2\" \"tests/sat13.vtlog\" = %b\n" (Verit_checker.checker "tests/sat13.smt2" "tests/sat13.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/hole4.smt2\" \"tests/hole4.vtlog\" = %b\n" (Verit_checker.checker "tests/hole4.smt2" "tests/hole4.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/uf1.smt2\" \"tests/uf1.vtlog\" = %b\n" (Verit_checker.checker "tests/uf1.smt2" "tests/uf1.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/uf2.smt2\" \"tests/uf2.vtlog\" = %b\n" (Verit_checker.checker "tests/uf2.smt2" "tests/uf2.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/uf3.smt2\" \"tests/uf3.vtlog\" = %b\n" (Verit_checker.checker "tests/uf3.smt2" "tests/uf3.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/uf4.smt2\" \"tests/uf4.vtlog\" = %b\n" (Verit_checker.checker "tests/uf4.smt2" "tests/uf4.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/uf5.smt2\" \"tests/uf5.vtlog\" = %b\n" (Verit_checker.checker "tests/uf5.smt2" "tests/uf5.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/uf6.smt2\" \"tests/uf6.vtlog\" = %b\n" (Verit_checker.checker "tests/uf6.smt2" "tests/uf6.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/uf7.smt2\" \"tests/uf7.vtlog\" = %b\n" (Verit_checker.checker "tests/uf7.smt2" "tests/uf7.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/lia1.smt2\" \"tests/lia1.vtlog\" = %b\n" (Verit_checker.checker "tests/lia1.smt2" "tests/lia1.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/lia2.smt2\" \"tests/lia2.vtlog\" = %b\n" (Verit_checker.checker "tests/lia2.smt2" "tests/lia2.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/lia3.smt2\" \"tests/lia3.vtlog\" = %b\n" (Verit_checker.checker "tests/lia3.smt2" "tests/lia3.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/lia4.smt2\" \"tests/lia4.vtlog\" = %b\n" (Verit_checker.checker "tests/lia4.smt2" "tests/lia4.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/lia5.smt2\" \"tests/lia5.vtlog\" = %b\n" (Verit_checker.checker "tests/lia5.smt2" "tests/lia5.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/lia6.smt2\" \"tests/lia6.vtlog\" = %b\n" (Verit_checker.checker "tests/lia6.smt2" "tests/lia6.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/lia7.smt2\" \"tests/lia7.vtlog\" = %b\n" (Verit_checker.checker "tests/lia7.smt2" "tests/lia7.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/let1.smt2\" \"tests/let1.vtlog\" = %b\n" (Verit_checker.checker "tests/let1.smt2" "tests/let1.vtlog") +let _ = Printf.printf "Verit_checker.checker \"tests/let2.smt2\" \"tests/let2.vtlog\" = %b\n" (Verit_checker.checker "tests/let2.smt2" "tests/let2.vtlog") diff --git a/src/extraction/verit_checker.ml b/src/extraction/verit_checker.ml new file mode 100644 index 0000000..e317dcf --- /dev/null +++ b/src/extraction/verit_checker.ml @@ -0,0 +1,324 @@ +open SmtMisc +open SmtCertif +open SmtForm +open SmtAtom +open SmtTrace +open Verit +open Smtlib2_ast +open Smtlib2_genConstr +(* open Smt_checker *) + + +module Mc = Micromega + + +let mkInt = ExtrNative.of_int +let mkArray = ExtrNative.of_array + + +let rec dump_nat x = + match x with + | Mc.O -> Smt_checker.O + | Mc.S p -> Smt_checker.S (dump_nat p) + + +let rec dump_positive x = + match x with + | Mc.XH -> Smt_checker.XH + | Mc.XO p -> Smt_checker.XO (dump_positive p) + | Mc.XI p -> Smt_checker.XI (dump_positive p) + + +let dump_z x = + match x with + | Mc.Z0 -> Smt_checker.Z0 + | Mc.Zpos p -> Smt_checker.Zpos (dump_positive p) + | Mc.Zneg p -> Smt_checker.Zneg (dump_positive p) + + +let dump_pol e = + let rec dump_pol e = + match e with + | Mc.Pc n -> Smt_checker.Pc (dump_z n) + | Mc.Pinj(p,pol) -> Smt_checker.Pinj (dump_positive p, dump_pol pol) + | Mc.PX(pol1,p,pol2) -> Smt_checker.PX (dump_pol pol1, dump_positive p, dump_pol pol2) in + dump_pol e + + +let dump_psatz e = + let rec dump_cone e = + match e with + | Mc.PsatzIn n -> Smt_checker.PsatzIn (dump_nat n) + | Mc.PsatzMulC(e,c) -> Smt_checker.PsatzMulC (dump_pol e, dump_cone c) + | Mc.PsatzSquare e -> Smt_checker.PsatzSquare (dump_pol e) + | Mc.PsatzAdd(e1,e2) -> Smt_checker.PsatzAdd (dump_cone e1, dump_cone e2) + | Mc.PsatzMulE(e1,e2) -> Smt_checker.PsatzMulE (dump_cone e1, dump_cone e2) + | Mc.PsatzC p -> Smt_checker.PsatzC (dump_z p) + | Mc.PsatzZ -> Smt_checker.PsatzZ in + dump_cone e + + +let rec dump_list dump_elt l = + match l with + | [] -> Smt_checker.Nil + | e :: l -> Smt_checker.Cons (dump_elt e, dump_list dump_elt l) + + +let rec dump_proof_term = function + | Micromega.DoneProof -> Smt_checker.DoneProof + | Micromega.RatProof(cone,rst) -> + Smt_checker.RatProof (dump_psatz cone, dump_proof_term rst) + | Micromega.CutProof(cone,prf) -> + Smt_checker.CutProof (dump_psatz cone, dump_proof_term prf) + | Micromega.EnumProof(c1,c2,prfs) -> + Smt_checker.EnumProof (dump_psatz c1, dump_psatz c2, dump_list dump_proof_term prfs) + + + +let to_coq to_lit confl = + let out_f f = to_lit f in + let out_c c = mkInt (get_pos c) in + let step_to_coq c = + match c.kind with + | Res res -> + let size = List.length res.rtail + 3 in + let args = Array.make size (mkInt 0) in + args.(0) <- mkInt (get_pos res.rc1); + args.(1) <- mkInt (get_pos res.rc2); + let l = ref res.rtail in + for i = 2 to size - 2 do + match !l with + | c::tl -> + args.(i) <- mkInt (get_pos c); + l := tl + | _ -> assert false + done; + Smt_checker.Euf_Checker.Res (mkInt (get_pos c), mkArray args) + | Other other -> + begin match other with + | ImmFlatten (c',f) -> Smt_checker.Euf_Checker.ImmFlatten (out_c c, out_c c', out_f f) + | True -> Smt_checker.Euf_Checker.CTrue (out_c c) + | False -> Smt_checker.Euf_Checker.CFalse (out_c c) + | BuildDef f -> Smt_checker.Euf_Checker.BuildDef (out_c c, out_f f) + | BuildDef2 f -> Smt_checker.Euf_Checker.BuildDef2 (out_c c, out_f f) + | BuildProj (f, i) -> Smt_checker.Euf_Checker.BuildProj (out_c c, out_f f, mkInt i) + | ImmBuildDef c' -> Smt_checker.Euf_Checker.ImmBuildDef (out_c c, out_c c') + | ImmBuildDef2 c' -> Smt_checker.Euf_Checker.ImmBuildDef2 (out_c c, out_c c') + | ImmBuildProj(c', i) -> Smt_checker.Euf_Checker.ImmBuildProj (out_c c, out_c c',mkInt i) + | EqTr (f, fl) -> + let res = List.fold_right (fun f l -> Smt_checker.Cons (out_f f, l)) fl Smt_checker.Nil in + Smt_checker.Euf_Checker.EqTr (out_c c, out_f f, res) + | EqCgr (f, fl) -> + let res = List.fold_right (fun f l -> Smt_checker.Cons ((match f with | Some f -> Smt_checker.Some (out_f f) | None -> Smt_checker.None), l)) fl Smt_checker.Nil in + Smt_checker.Euf_Checker.EqCgr (out_c c, out_f f, res) + | EqCgrP (f1, f2, fl) -> + let res = List.fold_right (fun f l -> Smt_checker.Cons ((match f with | Some f -> Smt_checker.Some (out_f f) | None -> Smt_checker.None), l)) fl Smt_checker.Nil in + Smt_checker.Euf_Checker.EqCgrP (out_c c, out_f f1, out_f f2, res) + | LiaMicromega (cl,d) -> + let cl' = List.fold_right (fun f l -> Smt_checker.Cons (out_f f, l)) cl Smt_checker.Nil in + let c' = List.fold_right (fun f l -> Smt_checker.Cons (dump_proof_term f, l)) d Smt_checker.Nil in + Smt_checker.Euf_Checker.LiaMicromega (out_c c, cl', c') + | LiaDiseq l -> Smt_checker.Euf_Checker.LiaDiseq (out_c c, out_f l) + | SplArith (orig,res,l) -> + let res' = out_f res in + let l' = List.fold_right (fun f l -> Smt_checker.Cons (dump_proof_term f, l)) l Smt_checker.Nil in + Smt_checker.Euf_Checker.SplArith (out_c c, out_c orig, res', l') + | SplDistinctElim (c',f) -> Smt_checker.Euf_Checker.SplDistinctElim (out_c c, out_c c', out_f f) + end + | _ -> assert false in + let def_step = + Smt_checker.Euf_Checker.Res (mkInt 0, mkArray [|mkInt 0|]) in + let r = ref confl in + let nc = ref 0 in + while not (isRoot !r.kind) do r := prev !r; incr nc done; + let last_root = !r in + let size = !nc in + let max = (Parray.trunc_size (Uint63.of_int 4194303)) - 1 in + let q,r1 = size / max, size mod max in + + let trace = + let len = if r1 = 0 then q + 1 else q + 2 in + Array.make len (mkArray [|def_step|]) in + for j = 0 to q - 1 do + let tracej = Array.make (Parray.trunc_size (Uint63.of_int 4194303)) def_step in + for i = 0 to max - 1 do + r := next !r; + tracej.(i) <- step_to_coq !r; + done; + trace.(j) <- mkArray tracej + done; + if r1 <> 0 then begin + let traceq = Array.make (r1 + 1) def_step in + for i = 0 to r1-1 do + r := next !r; + traceq.(i) <- step_to_coq !r; + done; + trace.(q) <- mkArray traceq + end; + + (mkArray trace, last_root) + + +let btype_to_coq = function + | TZ -> Smt_checker.Typ.TZ + | Tbool -> Smt_checker.Typ.Tbool + | Tpositive -> Smt_checker.Typ.Tpositive + | Tindex i -> Smt_checker.Typ.Tindex (mkInt (SmtAtom.indexed_type_index i)) + + +let c_to_coq = function + | CO_xH -> Smt_checker.Atom.CO_xH + | CO_Z0 -> Smt_checker.Atom.CO_Z0 + + +let u_to_coq = function + | UO_xO -> Smt_checker.Atom.UO_xO + | UO_xI -> Smt_checker.Atom.UO_xI + | UO_Zpos -> Smt_checker.Atom.UO_Zpos + | UO_Zneg -> Smt_checker.Atom.UO_Zneg + | UO_Zopp -> Smt_checker.Atom.UO_Zopp + + +let b_to_coq = function + | BO_Zplus -> Smt_checker.Atom.BO_Zplus + | BO_Zminus -> Smt_checker.Atom.BO_Zminus + | BO_Zmult -> Smt_checker.Atom.BO_Zmult + | BO_Zlt -> Smt_checker.Atom.BO_Zlt + | BO_Zle -> Smt_checker.Atom.BO_Zle + | BO_Zge -> Smt_checker.Atom.BO_Zge + | BO_Zgt -> Smt_checker.Atom.BO_Zgt + | BO_eq t -> Smt_checker.Atom.BO_eq (btype_to_coq t) + + +let n_to_coq = function + | NO_distinct t -> btype_to_coq t + + +let i_to_coq i = mkInt (SmtAtom.indexed_op_index i) + + +let a_to_coq a = + let to_coq h = mkInt (Atom.index h) in + match a with + | Acop op -> Smt_checker.Atom.Acop (c_to_coq op) + | Auop (op,h) -> Smt_checker.Atom.Auop (u_to_coq op, to_coq h) + | Abop (op,h1,h2) -> + Smt_checker.Atom.Abop (b_to_coq op, to_coq h1, to_coq h2) + | Anop (op,ha) -> + let cop = n_to_coq op in + let cargs = Array.fold_right (fun h l -> Smt_checker.Cons (to_coq h, l)) ha Smt_checker.Nil in + Smt_checker.Atom.Anop (cop, cargs) + | Aapp (op,args) -> + let cop = i_to_coq op in + let cargs = Array.fold_right (fun h l -> Smt_checker.Cons (to_coq h, l)) args Smt_checker.Nil in + Smt_checker.Atom.Aapp (cop, cargs) + + +let atom_interp_tbl reify = + let t = Atom.to_array reify (Smt_checker.Atom.Acop Smt_checker.Atom.CO_xH) a_to_coq in + mkArray t + + +let form_to_coq hf = mkInt (Form.to_lit hf) + +let args_to_coq args = + let cargs = Array.make (Array.length args + 1) (mkInt 0) in + Array.iteri (fun i hf -> cargs.(i) <- form_to_coq hf) args; + mkArray cargs + +let pf_to_coq = function + | Fatom a -> Smt_checker.Form.Fatom (mkInt (Atom.index a)) + | Fapp(op,args) -> + match op with + | Ftrue -> Smt_checker.Form.Ftrue + | Ffalse -> Smt_checker.Form.Ffalse + | Fand -> Smt_checker.Form.Fand (args_to_coq args) + | For -> Smt_checker.Form.For (args_to_coq args) + | Fimp -> Smt_checker.Form.Fimp (args_to_coq args) + | Fxor -> if Array.length args = 2 then Smt_checker.Form.Fxor (form_to_coq args.(0), form_to_coq args.(1)) else assert false + | Fiff -> if Array.length args = 2 then Smt_checker.Form.Fiff (form_to_coq args.(0), form_to_coq args.(1)) else assert false + | Fite -> if Array.length args = 3 then Smt_checker.Form.Fite (form_to_coq args.(0), form_to_coq args.(1), form_to_coq args.(2)) else assert false + | Fnot2 i -> Smt_checker.Form.Fnot2 (mkInt i, form_to_coq args.(0)) + + +let form_interp_tbl reify = + let (_,t) = Form.to_array reify Smt_checker.Form.Ftrue pf_to_coq in + mkArray t + + +(* Importing from SMT-LIB v.2 without generating section variables *) + +let count_btype = ref 0 +let count_op = ref 0 + + +let declare_sort sym = + let s = string_of_symbol sym in + let res = Tindex (dummy_indexed_type !count_btype) in + incr count_btype; + VeritSyntax.add_btype s res; + res + + +let declare_fun sym arg cod = + let s = string_of_symbol sym in + let tyl = List.map sort_of_sort arg in + let ty = sort_of_sort cod in + let op = dummy_indexed_op !count_op (Array.of_list (List.map fst tyl)) (fst ty) in + incr count_op; + VeritSyntax.add_fun s op; + op + + +let declare_commands ra rf acc = function + | CDeclareSort (_,sym,_) -> let _ = declare_sort sym in acc + | CDeclareFun (_,sym, (_, arg), cod) -> let _ = declare_fun sym arg cod in acc + | CAssert (_, t) -> (make_root ra rf t)::acc + | _ -> acc + + +let import_smtlib2 ra rf filename = + let chan = open_in filename in + let lexbuf = Lexing.from_channel chan in + let commands = Smtlib2_parse.main Smtlib2_lex.token lexbuf in + close_in chan; + match commands with + | None -> [] + | Some (Smtlib2_ast.Commands (_,(_,res))) -> + List.rev (List.fold_left (declare_commands ra rf) [] res) + + +(* The final checker *) + +let this_clear_all () = + Verit.clear_all (); + count_btype := 0; + count_op := 0 + + +let checker fsmt fproof = + this_clear_all (); + let ra = VeritSyntax.ra in + let rf = VeritSyntax.rf in + let roots = import_smtlib2 ra rf fsmt in + let (max_id, confl) = import_trace fproof None in + let (tres,last_root) = to_coq (fun i -> mkInt (SmtAtom.Form.to_lit i)) confl in + let certif = + Smt_checker.Euf_Checker.Certif (mkInt (max_id + 1), tres, mkInt (get_pos confl)) in + let used_roots = compute_roots roots last_root in + let used_rootsCstr = + let l = List.length used_roots in + let res = Array.make (l + 1) (mkInt 0) in + let i = ref (l-1) in + List.iter (fun j -> res.(!i) <- mkInt j; decr i) used_roots; + Smt_checker.Some (mkArray res) in + let rootsCstr = + let res = Array.make (List.length roots + 1) (mkInt 0) in + let i = ref 0 in + List.iter (fun j -> res.(!i) <- mkInt (SmtAtom.Form.to_lit j); incr i) roots; + mkArray res in + + let t_atom = atom_interp_tbl ra in + let t_form = form_interp_tbl rf in + + Smt_checker.Euf_Checker.checker_ext t_atom t_form rootsCstr used_rootsCstr certif diff --git a/src/extraction/zchaff_checker.ml b/src/extraction/zchaff_checker.ml new file mode 100644 index 0000000..79e87cc --- /dev/null +++ b/src/extraction/zchaff_checker.ml @@ -0,0 +1,103 @@ +open SmtCertif +open SmtForm +open SatAtom +open SmtTrace +open Zchaff +open Sat_checker + + +let mkInt = ExtrNative.of_int +let mkArray = ExtrNative.of_array + + +let make_roots first last = + let roots = Array.make (last.id + 2) (mkArray (Array.make 1 (mkInt 0))) in + let mk_elem l = + let x = match Form.pform l with + | Fatom x -> x + 2 + | _ -> assert false in + mkInt (if Form.is_pos l then x lsl 1 else (x lsl 1) lxor 1) in + let r = ref first in + while !r.id < last.id do + let root = Array.of_list (get_val !r) in + let croot = Array.make (Array.length root + 1) (mkInt 0) in + Array.iteri (fun i l -> croot.(i) <- mk_elem l) root; + roots.(!r.id) <- mkArray croot; + r := next !r + done; + let root = Array.of_list (get_val !r) in + let croot = Array.make (Array.length root + 1) (mkInt 0) in + Array.iteri (fun i l -> croot.(i) <- mk_elem l) root; + roots.(!r.id) <- mkArray croot; + + mkArray roots + + +let to_coq to_lit (cstep, + cRes, cImmFlatten, + cTrue, cFalse, cBuildDef, cBuildDef2, cBuildProj, + cImmBuildProj,cImmBuildDef,cImmBuildDef2, + cEqTr, cEqCgr, cEqCgrP, + cLiaMicromega, cLiaDiseq, cSplArith, cSplDistinctElim) confl = + let step_to_coq c = + match c.kind with + | Res res -> + let size = List.length res.rtail + 3 in + let args = Array.make size (mkInt 0) in + args.(0) <- mkInt (get_pos res.rc1); + args.(1) <- mkInt (get_pos res.rc2); + let l = ref res.rtail in + for i = 2 to size - 2 do + match !l with + | c::tl -> + args.(i) <- mkInt (get_pos c); + l := tl + | _ -> assert false + done; + Sat_Checker.Res (mkInt (get_pos c), mkArray args) + | _ -> assert false in + let def_step = + Sat_Checker.Res (mkInt 0, mkArray [|mkInt 0|]) in + let r = ref confl in + let nc = ref 0 in + while not (isRoot !r.kind) do r := prev !r; incr nc done; + let last_root = !r in + let size = !nc in + let max = (Parray.trunc_size (Uint63.of_int 4194303)) - 1 in + let q,r1 = size / max, size mod max in + + let trace = + let len = if r1 = 0 then q + 1 else q + 2 in + Array.make len (mkArray [|def_step|]) in + for j = 0 to q - 1 do + let tracej = Array.make (Parray.trunc_size (Uint63.of_int 4194303)) def_step in + for i = 0 to max - 1 do + r := next !r; + tracej.(i) <- step_to_coq !r; + done; + trace.(j) <- mkArray tracej + done; + if r1 <> 0 then begin + let traceq = Array.make (r1 + 1) def_step in + for i = 0 to r1-1 do + r := next !r; + traceq.(i) <- step_to_coq !r; + done; + trace.(q) <- mkArray traceq + end; + + (mkArray trace, last_root) + + +let checker fdimacs ftrace = + SmtTrace.clear (); + let _,first,last,reloc = import_cnf fdimacs in + let d = make_roots first last in + + let max_id, confl = import_cnf_trace reloc ftrace first last in + let (tres,_) = + to_coq (fun _ -> assert false) certif_ops confl in + let certif = + Sat_Checker.Certif (mkInt (max_id + 1), tres, mkInt (get_pos confl)) in + + Sat_Checker.checker d certif |