From Coq Require Import ZArith.ZArith MSets.MSetPositive FSets.FMapPositive
     Strings.String Strings.Ascii Bool.Bool Lists.List Strings.HexString.
From Crypto.Util Require Import
     ListUtil
     Strings.String Strings.Decimal Strings.Show
     ZRange.Operations ZRange.Show
     OptionList Bool.Equality.
Require Import Crypto.Util.Option.
(* Work around COQBUG(https://github.com/coq/coq/issues/12251) *)
Require Import Crypto.Util.ZRange.

From Crypto Require Import IR Stringification.Language AbstractInterpretation.ZRange.

Import ListNotations.

Local Open Scope string_scope.
Local Open Scope list_scope.
Local Open Scope zrange_scope.
Local Open Scope Z_scope.

Import IR.Compilers.ToString.
Import Stringification.Language.Compilers.
Import Stringification.Language.Compilers.Options.
Import Stringification.Language.Compilers.ToString.
Import Stringification.Language.Compilers.ToString.int.Notations.

Module JSON.
  Definition indent (indent : string) : list string -> list string
    := List.map (fun s => indent ++ s)%string.

  Definition int_bitwidth_to_string (signed : bool) (bitwidth : Z) : string :=
    ((if signed then "i" else "u")
       ++ Decimal.Z.to_string bitwidth)%string.

  Definition int_type_to_string (t : ToString.int.type) : string :=
    int_bitwidth_to_string (ToString.int.is_signed t) (ToString.int.bitwidth_of t).

  Definition primitive_type_to_string (t : IR.type.primitive)
             (r : option ToString.int.type) : string :=
    match t with
    | IR.type.Zptr => "*"
    | IR.type.Z => ""
    end ++ match r with
           | Some int_t => int_type_to_string int_t
           | None => "(auto)"
           end.

  Definition int_literal_to_string (t : IR.type.primitive) (v : BinInt.Z) : string :=
    match t with
    | IR.type.Z => HexString.of_Z v
    | IR.type.Zptr => "#error ""literal address " ++ HexString.of_Z v ++ """;"
    end.

  Import IR.Notations.

  Record op_data :=
    { datatype : string ; name : list string ; operation : string ; parameters : list (string * string) ; arguments : list (list string) }.

  Definition comma_concat (ls : list (list string)) : list string
    := let ret := List.flat_map (fun s => match s with
                                          | [] => []
                                          | _ => s ++ [","]
                                          end) ls in
       (* drop the final , *)
       List.firstn (List.length ret - 1) ret.

  Definition op_data_to_JSON (v : op_data) : list string
    := (["{"
         ; " ""datatype"": """ ++ v.(datatype) ++ ""","
         ; " ""name"": [" ++ String.concat ", " (List.map (fun n => """" ++ n ++ """")%string v.(name)) ++ "],"
         ; " ""operation"": """ ++ v.(operation) ++ ""","
         ]%string)
         ++ match v.(parameters) with
            | [] => []
            | _ =>
                [" ""parameters"": {" ++ String.concat ", " (List.map (fun '(n, val) => """" ++ n ++ """: " ++ val)%string v.(parameters)) ++ "},"]%string
            end
         ++ [" ""arguments"": ["]
         ++ (indent "  " (comma_concat v.(arguments)))
         ++ [" ]"
             ; "}"].

  Fixpoint arith_to_string (outargs : list string)
           {t} (sz : option ToString.int.type)
           (e : IR.arith_expr t)
    : list (list string)
    := let handle_op sz op params outargs inargs
           := [op_data_to_JSON
                 {| datatype := match sz with None => "(auto)" | Some ty => int_type_to_string ty end
                    ; name := outargs
                    ; operation := op
                    ; parameters := params
                    ; arguments := inargs |}] in
       let handle_op_size lg2s op outargs inargs
         := handle_op sz op [("size", Decimal.show_Z lg2s)] outargs inargs in
       let handle_op1 op {t} inargs
           := handle_op sz op [] outargs (@arith_to_string [] t sz inargs) in
       let wrap_value res
           := match outargs with
              | [] => res
              | _ => handle_op sz "=" [] outargs res
              end in
       match e with
       (* integer literals *)
       | (IR.literal v @@@ _)
         => wrap_value [ ["""" ++ int_literal_to_string IR.type.Z v ++ """"] ]
       (* array dereference *)
       | (IR.List_nth n @@@ IR.Var _ v)
         => wrap_value [ ["""" ++ v ++ "[" ++ Decimal.Z.to_string (Z.of_nat n) ++ "]"""] ]
       (* (de)referencing *)
       | (IR.Addr @@@ IR.Var _ v)
         => wrap_value [ ["""&" ++ v ++ """"] ]
       | (IR.Dereference @@@ IR.Var _ v)
         => wrap_value [ ["""*" ++ v ++ """"] ]
       | (IR.Dereference @@@ e)
         => handle_op sz "dereference" [] [] (arith_to_string [] sz e)
       (* bitwise operations *)
       | (IR.Z_shiftr offset @@@ e)
         => handle_op sz ">>" [] outargs
                      ((arith_to_string [] sz e)
                         ++ [ ["""" ++ Decimal.Z.to_string offset ++ """"]%string ])%list
       | (IR.Z_shiftl offset @@@ e)
         => handle_op sz "<<" [] outargs
                      ((arith_to_string [] sz e)
                         ++ [ ["""" ++ Decimal.Z.to_string offset ++ """"]%string ])%list
       | (IR.Z_land @@@ args)
         => handle_op1 "&" args
       | (IR.Z_lor @@@ args)
         => handle_op1 "|" args
       | (IR.Z_lxor @@@ args)
         => handle_op1 "^" args
       | (IR.Z_lnot _ @@@ args)
         => handle_op1 "~" args
       (* arithmetic operations *)
       | (IR.Z_add @@@ args)
         => handle_op1 "+" args
       | (IR.Z_mul @@@ args)
         => handle_op1 "*" args
       | (IR.Z_sub @@@ args)
         => handle_op1 "-" args
       | (IR.Z_bneg @@@ args)
         => handle_op1 "!" args
       | (IR.Z_mul_split lg2s @@@ ((IR.Addr @@@ IR.Var _ x1, IR.Addr @@@ IR.Var _ x2), args))
         => let sz' := Some (int.of_bitwidth_up false lg2s) in
            wrap_value (handle_op_size lg2s "mulx" [x1; x2] (arith_to_string [] sz' args))
       | (IR.Z_add_with_get_carry lg2s @@@ ((IR.Addr @@@ IR.Var _ x1, IR.Addr @@@ IR.Var _ x2), args))
         => let sz' := Some (int.of_bitwidth_up false lg2s) in
            wrap_value (handle_op_size lg2s "addcarryx" [x1; x2] (arith_to_string [] sz' args))
       | (IR.Z_sub_with_get_borrow lg2s @@@ ((IR.Addr @@@ IR.Var _ x1, IR.Addr @@@ IR.Var _ x2), args))
         => let sz' := Some (int.of_bitwidth_up false lg2s) in
            wrap_value (handle_op_size lg2s "subborrowx" [x1; x2] (arith_to_string [] sz' args))
       | (IR.Z_value_barrier ty @@@ args) => arith_to_string outargs sz args
       | (IR.Z_zselect ty @@@ (IR.Addr @@@ IR.Var _ v, args))
         => wrap_value (handle_op (Some ty) "cmovznz" [] [v] (arith_to_string [] (Some ty) args))
       | (IR.Z_static_cast int_t @@@ args)
         => handle_op (Some int_t) "static_cast" [] outargs (arith_to_string [] (Some int_t) args)
       | IR.Var _ v
         => wrap_value [ [ """" ++ v ++ """" ] ]
       | IR.Pair A B a b
         => wrap_value (arith_to_string [] sz a ++ arith_to_string [] sz b)%list
       | (IR.Z_add_modulo @@@ _)
         => wrap_value [ [ "#error addmodulo" ] ]
       | (IR.List_nth _ @@@ _)
       | (IR.Addr @@@ _)
       | (IR.Z_mul_split _ @@@ _)
       | (IR.Z_add_with_get_carry _ @@@ _)
       | (IR.Z_sub_with_get_borrow _ @@@ _)
       | (IR.Z_zselect _ @@@ _)
         => wrap_value [ [ "#error bad_arg" ] ]
       | IR.TT => wrap_value [ [ "#error tt" ] ]
       end%string%Cexpr.

  Definition stmt_to_string (e : IR.stmt) : list string
    := List.concat
         match e with
         | IR.Call val
           => arith_to_string [] None val
         | IR.Assign _ _ sz name val
           => arith_to_string [name] sz val
         | IR.AssignZPtr name sz val
           => arith_to_string [name] sz val
         | IR.AssignNth name n val
           => let name := (name ++ "[" ++ Decimal.Z.to_string (Z.of_nat n) ++ "]")%string in
              arith_to_string [name] None val
         | IR.DeclareVar _ _ _
         | IR.Comment _ _
           => []
         end.

  Definition to_strings (e : IR.expr) : list string :=
    comma_concat (List.map stmt_to_string e).

  Import Rewriter.Language.Language.Compilers Crypto.Language.API.Compilers IR.OfPHOAS.

  Local Notation tZ := (base.type.type_base base.type.Z).
  Local Notation None_object := "null" (only parsing).
  Local Notation quote_string s := ("""" ++ s ++ """")%string (only parsing).

  Fixpoint to_base_arg_list {t} : base_var_data t -> Compilers.ZRange.type.base.option.interp t -> list (string * string * (string * string))
    := let show_Z s := quote_string (Hex.show_Z s) in
       let opt_to_json T f (b : option T) :=
           match b with
           | None => (None_object, None_object)
           | Some v => f v
           end in
       let zrange_to_json b :=
           (show_Z b.(lower), show_Z b.(upper)) in
       let opt_zrange_to_json b :=
           opt_to_json _ zrange_to_json b in
       let opt_zrange_list_to_json ls :=
           let ls := List.map opt_zrange_to_json ls in
           ("[" ++ String.concat ", " (List.map (@fst _ _) ls) ++ "]",
            "[" ++ String.concat ", " (List.map (@snd _ _) ls) ++ "]")%string in
       let opt_opt_zrange_list_to_json ls :=
           opt_to_json _ opt_zrange_list_to_json ls in
       match t return base_var_data t -> Compilers.ZRange.type.base.option.interp t -> _ with
       | tZ
         => fun '(n, is_ptr, r, typedef) b
            => [(primitive_type_to_string IR.type.Z r, n, opt_zrange_to_json b)]
       | base.type.prod A B
         => fun '(va, vb) '(ba, bb) => (@to_base_arg_list A va ba ++ @to_base_arg_list B vb bb)%list
       | base.type.list tZ
         => fun '(n, r, len, typedef) b
            => [(primitive_type_to_string IR.type.Z r ++ "[" ++ Decimal.Z.to_string (Z.of_nat len) ++ "]", n,
                 opt_opt_zrange_list_to_json b)]
       | base.type.list _ => fun _ _ => [("#error ""complex list""", "", (None_object, None_object))]
       | base.type.option _ => fun _ _ => [("#error option", "", (None_object, None_object))]
       | base.type.unit => fun _ _ => [("#error unit", "", (None_object, None_object))]
       | base.type.type_base t => fun _ _ => [("#error " ++ show t, "", (None_object, None_object))]
       end%string.

  Definition to_arg_list {t} : var_data t -> Compilers.ZRange.type.option.interp t -> list (string * string * (string * string)) :=
    match t return var_data t -> Compilers.ZRange.type.option.interp t -> _ with
    | type.base t => to_base_arg_list
    | type.arrow _ _ => fun _ _ => [("#error arrow", "", (None_object, None_object))]
    end%string.

  Fixpoint to_arg_list_for_each_lhs_of_arrow {t} : type.for_each_lhs_of_arrow var_data t -> type.for_each_lhs_of_arrow Compilers.ZRange.type.option.interp t -> list (string * string * (string * string))
    := match t return type.for_each_lhs_of_arrow _ t -> type.for_each_lhs_of_arrow _ t -> _ with
       | type.base t => fun _ _ => nil
       | type.arrow s d
         => fun '(x, xs) '(b, bs)
            => to_arg_list x b ++ @to_arg_list_for_each_lhs_of_arrow d xs bs
       end%list.

  (** * Language-specific numeric conversions to be passed to the PHOAS -> IR translation *)

  Definition JSON_bin_op_natural_output
    : IR.Z_binop -> ToString.int.type * ToString.int.type -> ToString.int.type
    := fun idc '(t1, t2)
       => ToString.int.union t1 t2.

  (* Does the binary operation commute with (-- mod 2^bw)? *)
  Definition bin_op_commutes_with_mod_pow2 (idc : IR.Z_binop)
    := match idc with
       | IR.Z_land
       | IR.Z_lor
       | IR.Z_lxor
       | IR.Z_add
       | IR.Z_mul
       | IR.Z_sub
         => true
       end.

  Definition JSON_bin_op_casts
    : IR.Z_binop -> option ToString.int.type -> ToString.int.type * ToString.int.type -> option ToString.int.type * (option ToString.int.type * option ToString.int.type)
    := fun idc desired_type '(t1, t2)
       => match desired_type with
          | Some desired_type
            => let ct := ToString.int.union t1 t2 in
               if bin_op_commutes_with_mod_pow2 idc
               then
                 (* these operations commute with mod, so we just pre-cast them *)
                 (None, (Some desired_type, Some desired_type))
               else
                 let desired_type' := Some (ToString.int.union ct desired_type) in
                 (desired_type',
                  (get_Zcast_up_if_needed desired_type' (Some t1),
                   get_Zcast_up_if_needed desired_type' (Some t2)))
          | None => (None, (None, None))
          end.

  Definition JSON_un_op_casts
    : IR.Z_unop -> option ToString.int.type -> ToString.int.type -> option ToString.int.type * option ToString.int.type
    := fun idc desired_type t
       => match idc with
          | IR.Z_shiftr offset
            => (** N.B. We must cast the expression up to a large
                   enough type to fit 2^offset (importantly, not just
                   2^offset-1), because C considers it to be undefined
                   behavior to shift >= width of the type.  We should
                   probably figure out how to not generate these
                   things in the first place...

                   N.B. We must preserve signedness of the value being
                   shifted, because shift does not commute with
                   mod. *)
            let t' := ToString.int.union_zrange r[0~>2^offset]%zrange t in
            ((** We cast the result down to the specified type, if needed *)
              get_Zcast_down_if_needed desired_type (Some t'),
              (** We cast the argument up to a large enough type *)
              get_Zcast_up_if_needed (Some t') (Some t))
          | IR.Z_shiftl offset
            => (** N.B. We must cast the expression up to a large
                   enough type to fit 2^offset (importantly, not just
                   2^offset-1), because C considers it to be undefined
                   behavior to shift >= width of the type.  We should
                   probably figure out how to not generate these
                   things in the first place...

                   N.B. We make sure that we only left-shift unsigned
                   values, since shifting into the sign bit is
                   undefined behavior. *)
            let rpre_out := match desired_type with
                            | Some rout => Some (ToString.int.union_zrange r[0~>2^offset] (ToString.int.unsigned_counterpart_of rout))
                            | None => Some (ToString.int.of_zrange_relaxed r[0~>2^offset]%zrange)
                            end in
            ((** We cast the result down to the specified type, if needed *)
              get_Zcast_down_if_needed desired_type rpre_out,
              (** We cast the argument up to a large enough type *)
              get_Zcast_up_if_needed rpre_out (Some t))
          | IR.Z_lnot ty
            => ((* if the result is too big, we cast it down; we
                       don't need to upcast it because it'll get
                       picked up by implicit casts if necessary *)
              get_Zcast_down_if_needed desired_type (Some ty),
              (** always cast to the width of the type, unless we are already exactly that type (which the machinery in IR handles *)
              Some ty)
          | IR.Z_value_barrier ty
            => ((* if the result is too big, we cast it down; we
                       don't need to upcast it because it'll get
                       picked up by implicit casts if necessary *)
              get_Zcast_down_if_needed desired_type (Some ty),
              (** always cast to the width of the type, unless we are already exactly that type (which the machinery in IR handles *)
              Some ty)
          | IR.Z_bneg
            => ((* bneg is !, i.e., takes the argument to 1 if its not zero, and to zero if it is zero; so we don't ever need to cast *)
              None, None)
          end.

  Local Instance JSONLanguageCasts : LanguageCasts :=
    {| bin_op_natural_output := JSON_bin_op_natural_output
       ; bin_op_casts := JSON_bin_op_casts
       ; un_op_casts := JSON_un_op_casts
       ; upcast_on_assignment := true
       ; upcast_on_funcall := true
       ; explicit_pointer_variables := false
    |}.

  Definition to_function_lines (static : bool) (inline : bool) (name : string)
             {t}
             (inbounds : type.for_each_lhs_of_arrow Compilers.ZRange.type.option.interp t)
             (outbounds : Compilers.ZRange.type.base.option.interp (type.final_codomain t))
             (f : type.for_each_lhs_of_arrow var_data t * var_data (type.base (type.final_codomain t)) * IR.expr)
    : list string :=
    let '(args, rets, body) := f in
    let args_list_to_string ls
        := ("["
              ++ (String.concat
                    ", "
                    (List.map
                       (fun '(typ, name, (lbound, ubound)) => "{""datatype"": """ ++ typ ++ """, ""name"": """ ++ name ++ """, ""lbound"": " ++ lbound ++ ", ""ubound"": " ++ ubound ++ "}")
                       ls))
              ++ "]")%string in
    ["{"]
      ++ (["""operation"": """ ++ name ++ ""","
           ; """arguments"": " ++ args_list_to_string (to_arg_list_for_each_lhs_of_arrow args inbounds) ++ ","
           ; """returns"": " ++ args_list_to_string (to_arg_list rets outbounds) ++ ","
           ; """body"": ["]%string)
      ++ to_strings body
      ++ ["]"
          ; "}"].

  (** We will treat all dead variables as _ *)
  Local Instance : consider_retargs_live_opt := fun _ _ _ => false.
  Local Instance : rename_dead_opt := fun s => "_".
  (** No need to lift declarations to the top *)
  Local Instance : lift_declarations_opt := false.

  Definition ToFunctionLines
             {absint_opts : AbstractInterpretation.Options}
             {relax_zrange : relax_zrange_opt}
             {language_naming_conventions : language_naming_conventions_opt}
             {documentation_options : documentation_options_opt}
             {output_options : output_options_opt}
             (machine_wordsize : Z)
             (do_bounds_check : bool) (internal_static : bool) (static : bool) (all_static : bool) (inline : bool) (prefix : string) (name : string)
             {t}
             (e : API.Expr t)
             (comment : type.for_each_lhs_of_arrow var_data t -> var_data (type.base (type.final_codomain t)) -> list string)
             (name_list : option (list string))
             (inbounds : type.for_each_lhs_of_arrow Compilers.ZRange.type.option.interp t)
             (outbounds : Compilers.ZRange.type.base.option.interp (type.final_codomain t))
             (intypedefs : type.for_each_lhs_of_arrow var_typedef_data t)
             (outtypedefs : base_var_typedef_data (type.final_codomain t))
    : (list string * ToString.ident_infos) + string :=
    match ExprOfPHOAS do_bounds_check e name_list inbounds intypedefs outtypedefs with
    | inl (indata, outdata, f) =>
      inl (to_function_lines
             static inline name
             inbounds
             outbounds
             (indata, outdata, f),
           IR.ident_infos.collect_all_infos f intypedefs outtypedefs)
    | inr nil =>
      inr ("Unknown internal error in converting " ++ name ++ " to JSON")%string
    | inr [err] =>
      inr ("Error in converting " ++ name ++ " to JSON:" ++ String.NewLine ++ err)%string
    | inr errs =>
      inr ("Errors in converting " ++ name ++ " to JSON:" ++ String.NewLine ++ String.concat String.NewLine errs)%string
    end.

  Definition OutputJSONAPI : ToString.OutputLanguageAPI :=
    {| ToString.comment_block _ := [];
       ToString.comment_file_header_block _ := [];
       ToString.ToFunctionLines := @ToFunctionLines;
       ToString.header := fun _ _ _ _ _ _ _ _ _ _ _ => [];
       ToString.footer := fun _ _ _ _ _ _ _ _ _ => [];
       (** No special handling for any functions *)
       ToString.strip_special_infos machine_wordsize infos := infos |}.

End JSON.


(** * DomKildall: Dominators via Kildall *)
(* -------------------------------------------------------------------------- *
 *                     Vellvm - the Verified LLVM project                     *
 *                                                                            *
 *     Copyright (c) 2017 Steve Zdancewic <stevez@cis.upenn.edu>              *
 *                                                                            *
 *   This file is distributed under the terms of the GNU General Public       *
 *   License as published by the Free Software Foundation, either version     *
 *   3 of the License, or (at your option) any later version.                 *
 ---------------------------------------------------------------------------- *)

(* ################################################################# *)
(** * Computing Dominators *)
(** Implementation via fixpoint iteration. *)

Require Import Coq.Program.Equality.
Require Import Equalities.
Require Import Vminus.Dom Vminus.Kildall Vminus.Util.
Require Import FSets FMaps.

Module AlgdomKildall (PC:UsualDecidableType)
                     (Import G:GRAPH with Definition V := PC.t)
       : Algdom G.

  Module Import GS := Spec G.
  Module N := PC.
  Module E := PC.                     Module NS := FSetWeakList.Make N.

  Module L := BoundedSet NS.
  Module Import K := ! ForwardSolver N L.    Module NM := K.NM.
  (* Module Import FMP := FMapProps N NM. *)
  Module FMF := FMapFacts.WFacts_fun N NM.
  Module FSF := FSetFacts.WFacts_fun N NS.

    Parameter succs : G.t -> N.t -> list N.t.
  Axiom succs_compat : forall g n s, Succ g n s <-> In s (succs g n).
  Axiom succs_compat2 : forall g n s, In s (succs g n) -> Mem g s.

  Parameter enum_vs : G.t -> list N.t.
  Axiom enum_vs_compat : forall g n, Mem g n <-> In n (enum_vs g).

  (* this follows directly from wf_cfg *)
  Axiom entry_not_sdom : forall g v, ~ SDom g v (entry g).

  Definition trans (n: N.t) (l:L.t) : L.t :=
    L.union (L.singleton n) l.

  Definition inits (g:G.t) : NM.t L.t :=
    NM.add (entry g) L.top
    (fold_right (fun n g => NM.add n L.bot g) (NM.empty L.t) (enum_vs g) ).

  Definition calc_sdom (g:G.t) : option (N.t -> L.t) :=
    let nmo := K.fixpoint (succs g) trans (inits g) in
    match nmo with
      | None => None
      | Some nm => Some (fun n => nm!!n)
    end.

  Lemma entry_sound : forall g sdom,
    calc_sdom g = Some sdom ->
    sdom (entry g) == L.top.
  Proof.
    unfold calc_sdom. intros.
    destruct (K.fixpoint _ _ _) eqn:Heqk; try discriminate H.
    injection H. intro. clear H. subst sdom.
    set (r := t0!!(entry g)). cut (L.le L.top r).
    destruct r; try inversion 1. simpl.
    intro Hsub. red. intro a. split;
    intro; exfalso; eapply FSF.empty_iff; eauto.

    replace L.top with ((inits g)!!(entry g)).
    eapply K.fixpoint_entry. apply Heqk.
    unfold inits. rewrite FMP.find_default_eq; auto.
  Qed.

  Lemma successors_sound : forall g sdom n1 n2,
    calc_sdom g = Some sdom ->
    Mem g n1 -> Mem g n2 -> Succ g n1 n2 ->
    L.union (L.singleton n1) (sdom n1) <= sdom n2.
  Proof.
    unfold calc_sdom. intros.
    destruct (K.fixpoint _ _ _) eqn:Heqk; try discriminate H.
    injection H. intro. clear H. subst sdom.

    set (trans n o := L.union (L.singleton n) o).
    change (L.union (L.singleton n1) t0!!n1)
           with (trans n1 t0!!n1).
    eapply K.fixpoint_solution.
    eauto.

    unfold inits. destruct (N.eq_dec n1 (entry g)).
    apply FMF.add_in_iff; auto. apply FMF.add_neq_in_iff; auto.

    (* separate lemma? *)
    apply enum_vs_compat in H0. set (f g n := NM.add n L.bot g).
    assert (In n1 (enum_vs g) \/ NM.In n1 (NM.empty L.t))
           as Hin by exact (or_introl H0).
    generalize (enum_vs g) (NM.empty L.t) Hin.
    induction l; simpl. intuition.
    intros to Hin'. destruct Hin' as [[? | ?] | ?]; subst; auto.
    apply FMF.add_in_iff; auto.
    destruct (N.eq_dec a n1).
      subst.
      apply FMF.add_in_iff; auto. apply FMF.add_neq_in_iff; auto.
      lapply (IHl to). intros.
      apply FMF.add_in_iff; auto.
      right; auto.
    apply succs_compat; auto.
  Qed.

  (* Include AlgdomProperties G. *)

  Lemma complete : forall g sdom n1 n2,
    calc_sdom g = Some sdom ->
    SDom g n1 n2 -> L.In n1 (sdom n2).
  Proof.
    intros. pose proof entry_sound _ _ H as Hentry.
    unfold calc_sdom in *.
    destruct (K.fixpoint _ _ _) as [res|] eqn:heqk; try discriminate H.
    injection H. intro. clear H. subst sdom.

    generalize H0. clear H0. pattern n2, res!!n2.
    eapply K.fixpoint_invariant; eauto.

    intros. destruct (N.eq_dec (entry g) n).
    subst n. contradict H0.
    apply entry_not_sdom. unfold inits.
    rewrite FMP.find_default_neq; auto. unfold FMP.find_default.
    destruct (NM.find _ _) as [l'|] eqn:Heq; simpl; auto.

    induction (enum_vs g); simpl in *.
    unfold NM.find in Heq. rewrite FMF.empty_o in Heq. inversion Heq.
    unfold NM.find, NM.add in Heq. rewrite <- FMF.find_mapsto_iff in Heq.
    rewrite FMF.add_mapsto_iff in Heq.
    destruct Heq as [[eq1 eq2] | [neq1 hyp]]; subst; simpl in *; auto.
    apply IHl. rewrite FMF.find_mapsto_iff in hyp.
    apply hyp.

    (* step preserves completeness *)
    intros. unfold trans.

    pose proof (succs_compat2 _ _ _ H) as Hmem.
    apply succs_compat in H.

    destruct ls eqn:Heqls, ln eqn:Heqln; simpl; auto.
    apply FSF.inter_iff. split. apply H1; auto.
    apply FSF.union_iff.
    destruct (N.eq_dec n1 n). left. apply FSF.singleton_iff; auto.
    right. apply H0. red; split; auto.
    eapply dom_step with (v2:=s); auto.

    apply H1; auto.

    apply FSF.union_iff.
    destruct (N.eq_dec n1 n). left. apply FSF.singleton_iff; auto.
    right. apply H0. red; split; auto.
    eapply dom_step with (v2:=s); auto.

  Qed.

End AlgdomKildall.


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import bedrock2.Array.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Scalars.
Require Import bedrock2.Semantics.
Require Import bedrock2.Syntax.
Require Import bedrock2.WeakestPrecondition.
Require Import bedrock2.WeakestPreconditionProperties.
Require Import coqutil.Word.Interface.
Require Import coqutil.Word.Properties.
Require Import coqutil.Map.Interface.
Require Import coqutil.Map.Properties.
Require Import coqutil.Tactics.Tactics.
Require Import coqutil.Tactics.syntactic_unify.
Require Import coqutil.Tactics.letexists.
Require Import coqutil.Z.Lia.
Require Import Bedrock2Experiments.ProgramSemantics32.
Require Import Bedrock2Experiments.Tactics.
Require Import Bedrock2Experiments.WhileProperties.
Require Import Bedrock2Experiments.Word.
Require Import Bedrock2Experiments.WordProperties.
Require Import Bedrock2Experiments.LibBase.Bitfield.
Require Import coqutil.Map.SortedListString.
Import Syntax.Coercions List.ListNotations.
Local Open Scope string_scope.
Local Open Scope list_scope.
Local Open Scope Z_scope.

Section Proof.
  Context {word: word.word 32} {mem: map.map word Byte.byte}
          {word_ok: word.ok word} {mem_ok: map.ok mem}
          {ext_spec: ExtSpec} {ext_spec_ok: ext_spec.ok ext_spec}.

  Global Instance spec_of_bitfield_field32_write : spec_of "b2_bitfield_field32_write" :=
    fun function_env =>
      forall (field mask index value : word) (m : mem) (t : trace),
        call function_env bitfield_field32_write t m [field; mask; index; value]
          (fun t' m' rets =>
            t = t' /\ m = m' /\
            rets = [word.or
              (word.and
                field
                (word.xor (word.slu mask index) (word.of_Z (- 1)))
              )
              (word.slu (word.and value mask) index)]).
  Lemma bitfield_field32_write_correct :
    program_logic_goal_for_function! bitfield_field32_write.
  Proof.
    repeat straightline.
    repeat lazymatch goal with
           | |- exists _, _ =>
             eexists; ssplit; repeat straightline
    end.
    ssplit; eauto.
  Qed.

  Global Instance spec_of_bitfield_bit32_write : spec_of "b2_bitfield_bit32_write" :=
  fun function_env =>
    forall (field index value: word) (m : mem) (t : trace),
      call function_env bitfield_bit32_write t m [field; index; value]
        (fun t' m' rets =>
           t = t' /\ m = m' /\
           rets = [word.or
              (word.and
                field
                (word.xor (word.slu (word.of_Z 1) index) (word.of_Z (- 1)))
              )
              (word.slu (word.and (if word.eqb value (word.of_Z 1) then word.of_Z 1 else word.of_Z 0) (word.of_Z 1)) index)]).
  Lemma bitfield_bit32_write_correct :
    program_logic_goal_for_function! bitfield_bit32_write.
  Proof.
    repeat straightline.
    straightline_call.
    eexists; ssplit; repeat straightline.
    + cbn [map.putmany_of_list_zip]. subst a1.
      reflexivity.
    + repeat straightline. ssplit; eauto.
  Qed.

  Global Instance spec_of_bitfield_field32_read : spec_of "b2_bitfield_field32_read" :=
    fun function_env =>
      forall (field mask index : word) (m : mem) (t : trace),
        call function_env bitfield_field32_read t m [field; mask; index]
          (fun t' m' rets =>
          t = t' /\ m = m' /\ rets = [select_bits field index mask]
          ).

  Lemma bitfield_field32_read_correct :
    program_logic_goal_for_function! bitfield_field32_read.
  Proof.
    repeat straightline.
    repeat split; try reflexivity.
  Qed.

  Global Instance spec_of_bitfield_bit32_read : spec_of "b2_bitfield_bit32_read" :=
    fun function_env =>
      forall (field : word) (index: word) (m : mem) (t : trace),
        call function_env bitfield_bit32_read t m [field; index]
          (fun t' m' rets =>
          t = t' /\ m = m' /\
          rets = [word.and (word.sru field index) (word.of_Z 1)]
          ).

  Lemma bitfield_bit32_read_correct :
    program_logic_goal_for_function! bitfield_bit32_read.
  Proof.
    repeat straightline.
    (* call bitfield_field32_read *)
    straightline_call; eauto; try reflexivity; [ ].
    unfold select_bits in *.
    repeat straightline.
    repeat split; try reflexivity.
  Qed.
End Proof.


(**
   Version très simplifiée des idée de: "Java bytecode verification: algorithms
   and formalizations", Xavier Leroy (Journal of Automated Reasoning,
   30(3-4):235-269, 2003).

   Dont voici l'abstract:

   "Bytecode verification is a crucial security component for Java applets, on
   the Web and on embedded devices such as smart cards. This paper reviews the
   various bytecode verification algorithms that have been proposed, recasts
   them in a common framework of dataflow analysis, and surveys the use of proof
   assistants to specify bytecode verification and prove its correctness."

 *)

(* Coq écrira de préférence la syntaxe [foo.(bar)] plutôt que [(bar
   foo)], pour les champs (bar) de records (foo). *)
Set Printing Projections.

Require Omega.
Require Import OrderedType OrderedTypeEx OrderedTypeAlt DecidableType DecidableTypeEx.
From bcv Require Import LibHypsNaming heritage vmtype vmdefinition.

(** * Valeurs manipulée par la machine défensive,

   Ce module servira à instancier VMDefinition plus bas.
   La définition des types, classes et instruction est fixée dans [vmtype]. *)

Module DefVal <: VMVal.

  Inductive DVal:Set :=
  | Vint (i:nat)
  | Vref (clrf:class_id * heap_idx) (** nom de classe * adresse dans le tas *)
  | Vrefnull
  | Error
  | NonInit.

  Definition Val := DVal.

  (** Calcul du type d'une valeur défensive. *)
  Definition v2t (v:Val): VMType :=
    match v with
      | Vint i => Tint
      | Vref (clid,_) => Tref clid
      | Vrefnull => Trefnull
      | Error => Top
      | NonInit => Top
    end.

  Lemma val_eq_dec : forall v1 v2:Val, {v1=v2}+{v1<>v2}.
  Proof.
    intros v1 v2.
    decide equality.
    decide equality.
    decide equality.
    decide equality.
    decide equality.
  Qed.

End DefVal.

Module D (H:Herit).

(** États défensifs. *)
  Module Def := VMDefinition(DefVal)(H).
  Import DefVal.
  Include Def.
  Ltac rename_dvm h th := fail.

  (* Hypothesis renaming stuff from other files + current file.
     DO NOT REDEFINE IN THIS FILE. Redefine rename_dvm instead. *)
  Ltac rename_hyp h th ::=
    match th with
    | _ => (rename_dvm h th) (* redefine this tactic at will to enrich renaming*)
    | _ => (Def.rename_vmdef h th) (* renaming from Def *)
    | _ => (LibHypsNaming.rename_hyp_neg h th) (* basic generic renaming *)
    end.

  (** test *)
  (*
    Definition obj1:Obj := {| objclass:=1; objfields:=Dico.empty _|}.
    Definition heap1:Heap := Dico.empty _ .
    Definition heap2:Heap := Dico.add 1 obj1 heap1.
    Definition heap3:Heap := Dico.add 2 obj1 heap2.
    Eval vm_compute in (maxkey heap3).
    Eval vm_compute in (maxkey heap2). *)
  (* fin test *)

 Definition build_flds: ClasseDef -> (Dico.t Val) :=
    Dico.map
      (fun t:VMType =>
         match t with
         | Tint => Vint 0
         | Tref id => Vrefnull (** null = 0 *)
         | Object => Vrefnull (** null = 0 *)
         | Top => Vrefnull (** Should never happen *)
         | Trefnull => Vrefnull (** Should never happen *)
         end).

(** [new cldefs clid heap] vérifie que clid existe bien, puis retourne une
    reference [r] un nouveau [Heap] [h] et telle que [heap(r) = None] et [h(r) =
    Some(o)] où [o] est un objet "frais" et toutes les adresses de [heap] sont
    identiques dans [h]. *)
  Function new (clid:class_id) (heap:Heap) :=
    match Dico.find clid allcl with
    | None => None (** Classe inconnue *)
    | Some cldef =>
      let flds:Obj := {| objclass := clid; objfields := build_flds cldef |} in
      let newhpidx: nat := maxkey heap in
      Some((clid,S newhpidx), Dico.add (S newhpidx) flds heap)
    end.

(**
  Lemma new_one_change : forall clid hp hpidx newhp,
      new clid hp = Some (hpidx, newhp) ->
      forall idx,
        FIND idx newhp = FIND idx hp \/ idx=hpidx.
  Proof.
    intros clid hp.
    !functional induction new clid hp;intros;simpl;try solve [discriminate].
    inversion heq_Some;clear heq_Some;subst.
    destruct (Dico.E.eq_dec idx (S (maxkey hp)));simpl.
    - right;auto.
    - rewrite Dicomore.add_neq_o;auto.
  Qed.

  Add Parametric Morphism: build_flds with signature (Dico.Equal ==> Dico.Equal) as build_flds_morphism.
    intros x y H.
    unfold build_flds.
    setoid_rewrite H.
    apply  Dicomore.F.Equal_refl.
  Qed.*)
  (** * Fonction d'exécution défensive d'*un* bytecode.

     Pas de vérif d'overflow sur la pile d'opérandes. pas de nb
     négatifs, on ne vérifie que le typage et les underflow. *)
  Definition exec_step (s:State): option State :=
    let frm:Frame := s.(frame) in
    let pc: pc_idx := frm.(pc) in
    let instr_opt := Dico.find pc (frm.(mdef).(instrs)) in
    match instr_opt with
    | None => None
    | Some instr =>
      match instr with
        | ret => Some s
        | Iconst i =>
             Some {| framestack := s.(framestack); heap := s.(heap);
                frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                            pc:= pc + 1;
                            stack:= DefVal.Vint i :: s.(frame).(stack)
                         |}
             |}

       |Iadd =>
          match s.(frame).(stack) with
              | nil => None
              | Vint i1 :: nil => None
              | Vint i1 :: Vint i2 :: stack' =>
                Some {| framestack := s.(framestack); heap := s.(heap);
                        frame := {| mdef:=s.(frame).(mdef); regs:= s.(frame).(regs);
                                    pc:= pc + 1;
                                    stack:= Vint (i1+i2) :: stack'
                                 |}
                     |}
              | _  => None
              end
      | Iload ridx =>
        match Dico.find ridx (s.(frame).(regs)) with
        | Some (Vint i) =>
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef); regs:= s.(frame).(regs);
                              pc:= pc + 1;
                              stack:= (Vint i) :: s.(frame).(stack)
                           |}
               |}
        | _ => None (** Bad register number *)
        end

      | Rload cl_exp ridx =>
          match Dico.find ridx (s.(frame).(regs)) with
        | Some (Vref (cl_act,addr)) =>
          if (H.sub cl_act  cl_exp ) then
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                              pc:= pc + 1;
                              stack:= (Vref (cl_act,addr)) :: s.(frame).(stack)
                           |}
               |}
          else
            None
        | _ => None (** Bad register number *)
        end

      | Istore ridx =>
        match s.(frame).(stack) with
        | (Vint i) :: stack' =>
            Some {| framestack := s.(framestack); heap := s.(heap);
                    frame := {| mdef:=s.(frame).(mdef) ;
                                regs:= Dico.add ridx (Vint i) (s.(frame).(regs));
                                pc:= pc + 1;
                                stack:= stack'
                             |}
                 |}
        | _ => None (** Stack underflow *)
        end

      | Rstore cl_exp ridx =>
        match s.(frame).(stack) with
        | (Vref (cl_act,addr)) :: stack' =>
          if (H.sub cl_act cl_exp) then
            Some {| framestack := s.(framestack); heap := s.(heap);
                    frame := {| mdef:=s.(frame).(mdef) ;
                                regs:= Dico.add ridx (Vref (cl_act,addr))  (s.(frame).(regs));
                                pc:= pc + 1;
                                stack:= stack'
                             |}
                 |}
          else
          None

        | _ => None (** Stack underflow *)
        end

      | Iifle jmp => (** ifeqe *)

      match s.(frame).(stack) with
        | (Vint 0) :: stack' => (** = 0  --> jump *)
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                              pc:= jmp;
                              stack:= stack'
                           |}
               |}
        | (Vint _ ):: stack' => (** <> 0  --> pc+1 *)
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                              pc:= pc+1;
                              stack:= stack'
                           |}
               |}
        | _ => None (** Stack underflow *)
        end

      | Goto jmp =>
        Some {| framestack := s.(framestack); heap := s.(heap);
                frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                            stack:= s.(frame).(stack);
                            pc:= jmp
                         |}
             |}

      | Getfield cl namefld typ =>
        match s.(frame).(stack) with
        | Vref (classid,hpidx) :: stack' =>
          if (H.sub classid cl) then
          match Dico.find hpidx s.(heap) with
          | None => None (** adresse inconnue *)
          | Some {|objclass:= objcl; objfields:= flds |} => (* TODO: vérifier le type retourné? *)
            if (H.sub objcl cl) then
            match Dico.find namefld flds with
            | None => None (** Champ de classe inconnu ou pas initialisé *)
            | Some v =>
              Some {| framestack := s.(framestack); heap := s.(heap);
                      frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                                  pc:= pc+1;
                                  stack:= v :: stack'
                               |}
                   |}
            end
            else None
          end
          else None
        | _  => None (** Stack underflow *)
        end

      | Putfield cl namefld typ =>
        match s.(frame).(stack) with
        | Vref (classid,hpidx) :: v :: stack' =>
          if (H.sub classid cl) then
          match FIND cl H.allcl with
          | None => None
          | Some (cldef) =>
            match FIND namefld cldef with
            | None => None
            | Some (typfld) =>
              let typv := D.v2t v in
              if compat typv typfld then
              match Dico.find hpidx s.(heap) with
              | None => None (** adresse inconnue, objet non alloué *)
              | Some {| objclass:= objcl; objfields:= flds |}=>
                let newflds := {| objclass:= objcl;
                                  objfields:=Dico.add namefld v flds |} in
                let newheap := Dico.add hpidx newflds s.(heap) in
                Some {| framestack := s.(framestack);
                        heap := newheap;
                        frame := {| mdef:=s.(frame).(mdef) ;
                                    regs:= s.(frame).(regs);
                                    pc:= pc+1;
                                    stack:= stack'
                                 |}
                     |}
              end
              else None
            end
          end
          else None
        | _ => None (** Stack underflow *)
        end

      | New clid =>
        match new clid s.(heap) with
        | None => None (** Classe inconnue *)
        | Some (newobj,newhp) =>
          Some {| framestack := s.(framestack); heap := newhp;
                  frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                              stack:= (Vref newobj) :: s.(frame).(stack);
                              pc:= pc+1
                           |}
               |}

        end
      end
    end.

  Functional Scheme exec_step_ind := Induction for exec_step Sort Prop.

  (** * Tests *)

  Notation "k --> i , d" := (Dico.add k i d) (at level 55, right associativity).

  Definition prog:MethodDef :=
    {| instrs := (0 --> Iload 1 ,
                  1 --> Istore 2 ,
                  2 --> ret ,
                  Dico.empty ) ;
       argstype :=( Tint :: Tint:: nil);
       restype := Tint |}.

  Definition startstate:State :=
    {|
      framestack := nil;
      heap := Dico.empty;
      frame := {|
                mdef:= prog ;
                regs:= (0 --> Vint 32 , 1-->Vint 11, Dico.empty );
                pc:= 0;
                stack:= nil
              |}
    |}.

  Fixpoint exec_n (s : State) (n:nat) {struct n}: option State :=
    match n with
    | 0 => Some s
    | S n' =>
      match exec_step s with
      | None => None
      | Some s' => exec_n s' n'
      end
    end.
  (*
    Eval simpl in exec_n startstate 1.
    Eval simpl in exec_n startstate 2.
    Eval simpl in exec_n startstate 5.
   *)
  (* Eval simpl in exec_n (fun x y => false) (Dico.empty _) startstate 2. *)

  (** Exemple de preuve très simple sur la fonction d'exécution: la
  pile (hormis la méthode en cours d'exécution) ne change pas au cours
  de exec_step. *)

  Lemma essai : forall s x,
      exec_step s = Some x ->
      x.(framestack) = s.(framestack).
  Proof.
    intros s.
    functional induction exec_step s;intros ;simpl;
      try solve [discriminate | inversion H; subst;simpl;reflexivity] .
  Qed.

End D.


Require Export init.
Require Import generic univ utils tactics.

(* Definitions for arity-generic datatype-generic map
   - This version uses option instead of an axiom.
   - Needs a lot of unnecessary sums *)

Fixpoint optNMap {n : nat} (v : vec Type (S n)) : Type :=
  match v with
  | @vcons _ O x xs => x
  | @vcons _ (S n') x xs => x -> option (optNMap xs)
  end.

(* nat constant for nmapconst  *)
Program Fixpoint optNat (n : nat)
  : kit Ty optNMap (repeat (decodeClosed (Con Nat))) :=
  match n as n'
  return forall (pf : n=n'),
  kit Ty optNMap (repeat (n:=S n') (decodeClosed (Con Nat))) with
  | O => _
  | S n => _
  end eq_refl.
Next Obligation.
  Proof.
    exact 0.
  Defined.
Next Obligation.
  Proof.
    revert X.
    induction n as [| n' IHn']; intros x; apply Some.
    - exact x.
    - intros y. apply IHn'; exact y.
  Defined.

(* unit constant for nmapconst *)
Fixpoint optUnit (n : nat)
  : kit (n:=n) Ty optNMap (repeat (decodeClosed (Con Unit))).
Proof.
  destruct n as [| n'].
  - simpl; exact tt.
  - intros x; apply Some. apply optUnit.
Defined.

Fixpoint optSumLeft (n : nat)
  : forall (va : vec Type (S n)), optNMap va ->
  forall (vb : vec Type (S n)), optNMap (zap (zap (repeat sum) va) vb).
Proof.
  intros VA a VB. simpl.
  pose proof @veq_hdtl _ _ VA as pfa.
  destruct n as [| n'].
  - rewrite pfa in a. simpl in a. apply (inl a).
  - intros x; destruct x as [xl | xr].
    (* case for left side *)
    + rewrite pfa in a; simpl in a.
      apply a in xl; destruct xl as [somex |].
      (* case for some *)
      * apply Some; apply optSumLeft; apply somex.
      (* case for none *)
      * apply None.
    (* case for right side *)
    + apply None.
Defined.

Fixpoint optSumRight (n : nat)
  : forall (va : vec Type (S n)) (vb : vec Type (S n)),
  optNMap vb -> optNMap (zap (zap (repeat sum) va) vb).
Proof.
  intros VA VB b. simpl.
  pose proof @veq_hdtl _ _ VB as pfb.
  destruct n as [| n'].
  - rewrite pfb in b; simpl in b. apply (inr b).
  - intros x; destruct x as [xl | xr].
    (* case for left side *)
    + apply None.
    (* case for right side *)
    + rewrite pfb in b; simpl in b.
      apply b in xr. destruct xr as [somex |].
      (* case for some *)
      * apply Some; apply optSumRight; apply somex.
      (* case for none *)
      * apply None.
Defined.

Definition optSum (n : nat)
  : forall (va : vec Type (S n)), optNMap va
  -> forall (vb : vec Type (S n)), optNMap vb
  -> optNMap (zap (zap (repeat sum) va) vb).
Proof.
  intros VA a VB b.
  destruct n as [| n'].
  (* no arguments, chooses arbitrary case inr *)
  - simpl. rewrite veq_hdtl in b. simpl in b. apply (inr b).
  - intros x; destruct x as [lx | rx].
    + rewrite veq_hdtl in a; simpl in a.
      apply a in lx. destruct lx as [somex |].
      (* case for some *)
      * apply Some; apply optSumLeft; apply somex.
      (* case for none *)
      * apply None.
    + rewrite veq_hdtl in b; simpl in b.
      apply b in rx; destruct rx as [somex |].
      (* case for some *)
      * apply Some; apply optSumRight; apply somex.
      (* case for none *)
      * apply None.
Defined.

(* case for prods in curried form  *)
Fixpoint optProd (n : nat)
  : forall (va : vec Type (S n)), optNMap va
  -> forall (vb : vec Type (S n)), optNMap vb
  -> optNMap (zap (zap (repeat (decodeClosed (Con Prod))) va) vb).
Proof.
  destruct n;
  intros VA a VB b;
  pose proof @veq_hdtl _ _ VA as pfa;
  pose proof @veq_hdtl _ _ VB as pfb.
  - rewrite pfa in a; simpl in a.
    rewrite pfb in b; simpl in b.
    apply pair.
    (* inl case *)
    + apply a.
    (* inr case *)
    + apply b.
  - rewrite pfa in a; simpl in a.
    rewrite pfb in b; simpl in b.
    intros pr. destruct pr as [pa pb].
    apply a in pa. apply b in pb.
    destruct pa as [somea |].
    + destruct pb as [someb |].
      * apply Some; apply optProd.
        { apply somea. }
        { apply someb. }
      * apply None.
    + apply None.
Defined.

Definition optNMapConst {n : nat} : tyConstEnv (@optNMap n) :=
  fun k c =>
    match c with
    | Nat => optNat _
    | Unit => optUnit _
    | Prod => ltac:(curryk (optProd (n:=n)))
    | Sum => ltac:(curryk (optSum (n:=n)))
    end.

Definition optNConst {n : nat} : NGen optNMap (n:=n) :=
  nGen
  (optUnit _)
  (optNat _)
  (ltac:(curryk (optSum (n:=n))))
  (ltac:(curryk (optProd (n:=n)))).

(* doubly generic map WITH OPTION *)
Definition optngmap (n : nat) (k : kind) (t : ty k)
  : kit (n:=n) k optNMap (repeat (decodeClosed t)) :=
  ngen _ optNConst (n:=n).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q A B C D T X Y : Universe, ((wd_ P Q /\ (wd_ A D /\ (wd_ B D /\ (wd_ D P /\ (wd_ D Q /\ (wd_ B P /\ (wd_ B Q /\ (wd_ C P /\ (wd_ C Q /\ (wd_ A P /\ (wd_ A Q /\ (col_ T P Q /\ (col_ X P Q /\ (col_ Y P Q /\ (col_ A B D /\ (col_ Y Y A /\ (col_ X Y B /\ (col_ B Y D /\ (col_ A X D /\ col_ A T C))))))))))))))))))) -> col_ A D Y)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import CtxFibrancy.Overture Category CtxFibrancy.Fibrant_replacement Strict_eq CtxFibrancy.Path_eq CtxFibrancy.Equivalences CtxFibrancy.Cylinder.
Set Universe Polymorphism.

Set Implicit Arguments.
(* g is a retract of f *)
(* f in the middle, g on the side *)
Record Retract {A B} (g : A -> B) {A' B'} (f : A' -> B') :=
  { ret_s : A -> A' ;
    ret_r : A' -> A ;
    ret_s' : B -> B' ;
    ret_r' : B' -> B ;
    ret_sr : ret_r o ret_s ≡≡ idmap ;
    ret_sr' : ret_r' o ret_s' ≡≡ idmap;
    ret_H1 : f o ret_s ≡≡ ret_s' o g ;
    ret_H2 : ret_r' o f ≡≡ g o ret_r }.
Unset Implicit Arguments.

Global Arguments Build_Retract {A B g A' B' f} s r s' r' sr sr' H1 H2 : rename.

Infix "RetractOf" := Retract (at level 30).

Lemma LP_Retract {A A' B' B C C' D D'}
      {f: A -> A'} {g: B' -> B} {f': C -> C'} {g': D' -> D}
      (Hf : f' RetractOf f) (Hg : g' RetractOf g)
  : LP (C:=TYPE) f g -> LP (C:=TYPE) f' g'.
Proof.
  intros H F G H1; cbn in *.
  assert (X: g o (ret_s Hg o F o ret_r Hf) ≡≡ ret_s' Hg o G o ret_r' Hf o f). {
    intro. ref (ret_H1 Hg _ E@ _). apply Eap.
    ref (Eap10 H1 _ E@ _). apply Eap.
    exact (ret_H2 Hf _)^E. }
  specialize (H ((ret_s Hg) o F o (ret_r Hf)) ((ret_s' Hg) o G o (ret_r' Hf)) (eq_funext X)).
  destruct H as [h [H2 H3]]; cbn in *.
  exists ((ret_r Hg) o h o (ret_s' Hf)). split; apply eq_funext; intro x; simpl.
  - transitivity (ret_r Hg (h (f (ret_s Hf x)))).
    repeat apply Eap. exact (ret_H1 Hf _)^E.
    transitivity (ret_r Hg (ret_s Hg (F (ret_r Hf (ret_s Hf x))))).
    apply Eap. apply (Eap10 H2).
    transitivity (F (ret_r Hf (ret_s Hf x))).
    apply (ret_sr Hg). apply Eap. apply (ret_sr Hf).
  - ref ((ret_H2 Hg _)^E E@ _).
    ref (Eap _ (Eap10 H3 _) E@ _).
    ref (ret_sr' Hg _ E@ _).
    apply Eap. exact (ret_sr' Hf _).
Defined.

Definition retract_id {A B} (f: A -> B) : f RetractOf f.
Proof.
  use Build_Retract; intro; cbn; try reflexivity.
Defined.

Record IsFibration {A B} (f : A -> B) := (* F *)
  { fib_A : Type ;
    fib_P : fib_A -> Type ;
    fib_Fib : PFibrant fib_P;
    fib_H : f RetractOf (π1 fib_P) }.

Global Arguments Build_IsFibration {A B f B'} P {FibP} H : rename.

Notation Fib := @IsFibration.

Definition fiber {A B} (f: A -> B) := λ y, ∃ x, repl_f f x = η y.

Let f' {A B} (f: A → B) : A -> ∃ y, fiber f y
  := λ x, (f x ; η x ; 1).

Definition LP_f'_F {A B} (f: A → B)
  : LLP (C:=TYPE) Fib (f' f).
Proof.
  intros A'' B'' g [B' P HP Hg].
  refine (LP_Retract (retract_id _) Hg _).
  intros F G H; cbn in *.
  transparent assert (α: ((∃ y, fiber f y) -> ∃ y, P (G y))). {
    refine (λ y, (y; _)). destruct y as [y [x p]].
    revert x p. rapply @repl_ind. cbn; intros x p.
    pose proof (Etransport P (Eap10 H x) (F x).2); cbn in X.
    refine (repl_J (λ y p, P (G (y; (η x; p)))) p X). }
  transparent assert (β: ((∃ y, P (G y)) -> sigT P)). {
    exact (λ w, (G w.1; w.2)). }
  exists (β o α). split; [|reflexivity].
  apply eq_funext; intro x.
  use eq_sigma; cbn. exact (Eap10 H _)^E.
  now rewrite Etransport_Vp.
Defined.

Definition wfs_AC_F : weak_factorization_system (@LLP TYPE (@IsFibration)) (@IsFibration).
Proof.
  use Build_weak_factorization_system; cbn.
  - intros A B f. exists (∃ y, fiber f y).
    exists (f' f). exists (π1 _).
    split; [reflexivity|]. split.
    + apply LP_f'_F.
    + refine (Build_IsFibration _ (retract_id _)).
  - intros A B f; split; auto.
  - intros A B f; split; intros Hf.
    + intros A' B' g Hg. now apply Hg.
    + assert (LP (C:=TYPE) (f' f) f). {
        apply Hf. apply LP_f'_F. }
      specialize (X idmap (π1 _) E1); cbn in X. destruct X as [g [Hg1 Hg2]].
      refine (Build_IsFibration (fiber f) _).
      refine (Build_Retract (f' f) g idmap idmap _ _ _ _);
        intro; try reflexivity; cbn.
      exact (Eap10 Hg1 _). exact (Eap10 Hg2^E _).
Defined.

Record AFib A B (f : A -> B) := (* F *)
  { afib_A : Type ;
    afib_P : afib_A -> Type ;
    afib_Fib : PFibrant afib_P ;
    afib_H1 : ∀ y, Contr (afib_P y) ;
    afib_H2 : f RetractOf (π1 afib_P) }.

Global Arguments Build_AFib {A B f B'} P {FibP} HP H : rename.

Definition AFib_Fib {A B} (f: A -> B)
  : AFib _ _ f -> Fib _ _ f.
Proof.
  intros [B' P FibP HP H].
  exact (Build_IsFibration _ H).
Defined.

Definition LP_top'_AF {A B} (f: A → B)
  : LLP (C:=TYPE) AFib (top' (f:=f)).
Proof.
  intros A'' B'' g [B' P FibP HP Hg].
  refine (LP_Retract (retract_id _) Hg _).
  clear g Hg. intros F G H; cbn in *.
  use exist.
  - intro w. exists (G w). revert w.
    use sig_cyl_ind; cbn.
    + intro x. exact ((Eap10 H x) E# (F x).2).
    + intro y. use center. apply HP.
    + intro; cbn. use path_contr.
      refine (_ E# (HP (G (f x; top x)))).
      apply PFibrant_irrelevance.
  - split; cbn. 2: reflexivity.
    apply eq_funext; intro x. use eq_sigma. exact (Eap10 H x)^E.
    rew Etransport_Vp. reflexivity.
Defined.

Definition wfs_C_AF : weak_factorization_system (@LLP TYPE AFib) AFib.
Proof.
  use Build_weak_factorization_system; cbn.
  - intros A B f. exists (sigT (Cyl f)).
    exists top'. exists (π1 _).
    split; [reflexivity|]. split.
    + apply LP_top'_AF.
    + ref (Build_AFib _ _ (retract_id _)); cbn.
      apply Cyl_Contr.
  - intros; split; auto.
  - intros A B f; split; intros Hf.
    + intros A' B' g Hg. now apply Hg.
    + assert (LP (C:=TYPE) (top' (f:=f)) f). {
        apply Hf. apply LP_top'_AF. }
      specialize (X idmap (π1 _) E1); cbn in X. destruct X as [g [Hg1 Hg2]].
      ref (Build_AFib (Cyl f) _ _); cbn.
      apply Cyl_Contr.
      refine (Build_Retract top' g idmap idmap _ _ _ _);
        intro; try reflexivity; cbn.
      exact (Eap10 Hg1 _). exact (Eap10 Hg2^E _).
Defined.

Definition weak_eq_retract {A B A' B'}
           (f: A -> B) (f': A' -> B')
           (Hf': f' RetractOf f) (Hf: IsEquiv (repl_f f))
  : IsEquiv (repl_f f').
Proof.
  destruct Hf as [g Hg1 Hg2].
  destruct Hf' as [s r s' r' sr sr' Hf1 Hf2].
  refine (isequiv_adjointify (repl_f r o g o repl_f s') _ _); intro.
  - rew repl_f_compose. rew (eq_funext Hf2)^E.
    rewi repl_f_compose. ref (ap _ (Hg1 _) @ _).
    rew repl_f_compose. rew (eq_funext sr'). apply Eq_to_paths, repl_f_idmap.
  - rew repl_f_compose. rewi (eq_funext Hf1). rewi (repl_f_compose s).
    ref (ap _ (Hg2 _) @ _). rew repl_f_compose.
    rew (eq_funext sr). rew repl_f_idmap. exact 1.
Defined.

Definition two_out_of_three_weak_equiv
  : @two_out_of_three TYPE (λ A B f, IsEquiv (repl_f f)).
Proof.
  intros A B C f g; cbn in *. repeat split; intros H1 H2.
  - rewrite <- (eq_funext (repl_f_compose f g)).
    now apply isequiv_compose.
  - rewrite <- (eq_funext (repl_f_compose f g)) in H2.
    apply (cancelL_isequiv (Hg:=H1) (Hgf:=H2) (repl_f g)).
  - rewrite <- (eq_funext (repl_f_compose f g)) in H1.
    apply (cancelR_isequiv (Hf:=H2) (Hgf:=H1) (repl_f f)).
Defined.

Definition AFib_aux {B} {P: B -> Type} {FibP: PFibrant P} (H: IsEquiv (repl_f (π1 P)))
  : ∀ y, Contr (P y).
Proof.
  destruct H as [g Hg1 Hg2 Hg3]. intro y.
  ref (let f := repl_ind (X:=sigT P) (λ z, repl_rec P (repl_f pr1 z)) pr2 in _).
  use Build_Contr.
  - change (repl_rec P (η y)).
    refine (transport (repl_rec P) (Hg1 (η y)) (f (g (η y)))).
  - intro w.
    specialize (Hg3 (η (y; w))); cbn in Hg3. rew Hg3.
    rew (transport_compose (repl_rec P) (repl_f (π1 (λ x : B, P x))) (Hg2 (η (y; w))) _)^.
    exact (irr_paths (apD f (Hg2 (η (y; w))))).
Defined.

Definition AFib_ok {A B} (f: A -> B)
  : AFib _ _ f  <->  (IsEquiv (repl_f f) × Fib _ _ f).
Proof.
  split; intro H.
  - split.
    + destruct H as [B' P FibP HP Hf].
      eapply weak_eq_retract. exact Hf. clear f Hf.
      use isequiv_adjointify.
      * use repl_rec. intro x. apply η. exists x. apply HP.
      * use repl_ind; cbn. intro; exact 1.
      * use repl_ind; cbn. intros [x w]; cbn.
        rew (contr _ _ w). exact 1.
    + destruct H as [B' P FibP H1 H2]. econstructor. eassumption. exact H2.
  - ref (Build_AFib (fiber f) _ _).
    + pose proof (two_out_of_three_weak_equiv _ _ _ (f' f) pr1); cbn in X.
      destruct X as [_ [_ H2]]. specialize (H2 (fst H)).
      refine (AFib_aux (P:=fiber f) (H2 _)).
      clear H2 H.
      use isequiv_adjointify.
      * use repl_rec. exact (λ w, w.2.1).
      * use repl_ind; cbn. intros [y [x p]]; cbn.
        revert x p. use repl_ind; cbn. intros x p; cbn.
        unfold f'. exact (repl_J (λ y p, η (f x; (η x; 1)) = η (y; (η x; p))) _ 1).
      * use repl_ind; cbn. intro; exact 1.
    + assert (LP (C:=TYPE) (f' f) f). {
        apply LP_f'_F. apply H. }
      specialize (X idmap pr1 E1); cbn in X. destruct X as [g [Hg1 Hg2]].
      refine (Build_Retract (f' f) g idmap idmap _ _ _ _);
        intro; try reflexivity; cbn.
      exact (Eap10 Hg1 _). exact (Eap10 Hg2^E _).
Defined.

Definition LLPAFib_ok {A B} (f: A -> B)
  : LLP (C:=TYPE) Fib f  <->  (IsEquiv (repl_f f) × LLP (C:=TYPE) AFib f).
Proof.
  split.
  - intro H; split.
    + ref (let X := H _ B pr1 _ (f' f) idmap E1 in _).
      ref (Build_IsFibration _ (retract_id _)).
      destruct X as [g [Hg1 Hg2]]; cbn in *.
      use isequiv_adjointify.
      * use repl_rec. exact (λ w, (g w).2.1).
      * use repl_ind; cbn. intro x; pose (g x).2.2. cbn in *.
        rew p. apply Eq_to_paths, Eap. exact (Eap10 Hg2 _).
      * use repl_ind; cbn. intro x. rew (Eap10 Hg1 x).
        exact 1.
    + intros A' B' F Hf. apply H. now apply AFib_Fib.
  - intros [H2 H1] A' B' g Hg.
    ref (LP_Retract (f:=f' f) _ (retract_id _) _).
    +  clear A' B' g Hg.
       assert (X : AFib (∃ (y : B) (x : repl A), repl_f f x = η y) B pr1). {
         destruct H2 as [g Hg1 Hg2 Hg3].
         ref (Build_AFib _ _ (retract_id _)).
         intro y; cbn. exists (g (η y); Hg1 _).
         intros [x p].
         ref (path_sigma _ ((ap g p)^ @ Hg2 _) _).
         rew transport_paths_Fl. rew ap_pp. rew (Hg3 _)^.
         rew ap_V. rew inv_pp. rew inv_V.
         rew (ap_compose g (repl_f f) _)^.
         ref ( let X := _ : (λ x0 : repl B, repl_f f (g x0)) = idmap in _).
         ref (path_funext _); intro; cbn.
         exact (irr_paths (Hg1 _)).
         rew concat_pp_p.
         ref (irr_paths (moveR_Vp _ _ _ _)).
         set (η y) in *. clearbody r. clear y. destruct_path p.
         cbn. exact (concat_1p _ @ (concat_p1 _)^). }
       specialize (H1 (sigT (fiber f)) B pr1 X (f' f) idmap E1); clear X.
       destruct H1 as [Ɣ [H H']]; cbn in *.
       use (Build_Retract idmap idmap Ɣ pr1); intro; try reflexivity.
       exact (Eap10 H' _). exact (Eap10 H^E _).
    + now apply LP_f'_F.
Defined.

Definition fibrant_types_give_fibrations {A: Type} {FibA: Fibrant A}
  : IsFibration (λ _:A, tt).
Proof.
  ref (Build_IsFibration (λ _:unit, A) _).
  ref (Build_Retract (λ x, (tt; x)) (π2 (λ _:unit, A)) idmap idmap _ _ _ _);
    intro; try reflexivity; cbn.
  destruct x as [[] y]; reflexivity.
Defined.

Definition type_model_structure : model_structure TYPE.
Proof.
  rapply Build_model_structure.
  - exact (λ A B f, IsEquiv (repl_f f)).
  - exact Fib.
  - exact (@LLP TYPE AFib).
  - apply two_out_of_three_weak_equiv.
  - eapply wfs_iff_R. apply @AFib_ok.
  (* exact wfs_C_AF. *)
    use Build_weak_factorization_system; cbn.
    + intros A B f. exists (sigT (Cyl f)).
      exists top'. exists (π1 _).
      split; [reflexivity|]. split.
      * apply LP_top'_AF.
      * ref (Build_AFib _ _ (retract_id _)); cbn.
        apply Cyl_Contr.
    + intros; split; auto.
    + intros A B f; split; intros Hf.
      * intros A' B' g Hg. now apply Hg.
      * assert (LP (C:=TYPE) (top' (f:=f)) f). {
          apply Hf. apply LP_top'_AF. }
        specialize (X idmap (π1 _) E1); cbn in X. destruct X as [g [Hg1 Hg2]].
        ref (Build_AFib (Cyl f) _ _); cbn.
        apply Cyl_Contr.
        refine (Build_Retract top' g idmap idmap _ _ _ _);
          intro; try reflexivity; cbn.
        exact (Eap10 Hg1 _). exact (Eap10 Hg2^E _).
  - eapply wfs_iff_L. apply @LLPAFib_ok. exact wfs_AC_F.
Defined.

(* Print Assumptions type_model_structure. *)

(* F are retracts of their π1 : Σ fiber -> B *)
Definition F_caract {A B} {f: A -> B}
  : IsFibration f <-> ∃ (g: sigT (fiber f) -> A), f o g ≡≡ pr1 × g o (f' f) ≡≡ idmap.
Proof.
  split.
  - intros [B' P FibP [s r s' r' rs rs' H1 H2]].
    use exist.
    + intros [y [x p]]. apply r. exists (s' y).
      revert x p. use repl_ind; cbn. intros x p.
      ref (repl_J (λ y _, P (s' y)) p _); cbn.
      ref ((H1 x) E# _). exact (s x).2.
    + split; cbn.
      * intros [y [x p]]; cbn.
        ref ((H2 _)^E E@ _); cbn. apply rs'.
      * intro x. ref (_ E@ rs x).
        apply Eap. use eq_sigma. exact (H1 _)^E.
        apply Etransport_Vp.
  - intros [g [H1 H2]].
    ref (Build_IsFibration (fiber f) _).
    ref (Build_Retract (f' f) g idmap idmap _ _ _ _);
      intro; cbn; try reflexivity.
    apply H2. sym H1.
Defined.

(* AC are retracts of their f' *)
Definition AC_caract {A B} (f: A -> B)
  : LLP (C:=TYPE) Fib f <-> ∃ (g: B -> sigT (fiber f)), g o f ≡≡ f' f × pr1 o g ≡≡ idmap.
Proof.
  split; intro H.
  - specialize (H (sigT (fiber f)) _ pr1 (Build_IsFibration _ (retract_id _))).
    specialize (H (f' f) idmap E1).
    destruct H as [g [H1 H2]]. exists g. split; apply Eap10; assumption.
  - intros X Y g Hg. ref (LP_Retract (f:=f' f) _ (retract_id _) _).
    use (Build_Retract idmap idmap H.1 pr1); try (intro; reflexivity).
    apply H.2. cbn. symmetry. apply H.2.
    now apply LP_f'_F.
Defined.

Record Cofib {A B} (f : A -> B) := (* C *)
  { cofib_A : Type ;
    cofib_B : Type ;
    cofib_k : cofib_A -> cofib_B ;
    cofib_H : f RetractOf (top' (f:=cofib_k)) }.
Arguments Build_Cofib {A B f A' B'} k H : rename.

(* C are injections into cylinders *)
Definition C_caract {A B} (f: A -> B)
  : LLP (C:=TYPE) AFib f <-> Cofib f.
Proof.
  split.
  - intro Hf. use (Build_Cofib f).
    specialize (Hf (sigT (Cyl f)) B pr1).
    specialize (Hf (Build_AFib (Cyl f) Cyl_Contr (retract_id _))).
    specialize (Hf top' idmap E1).
    destruct Hf as [g [Hg1 Hg2]]; cbn in *.
    use (Build_Retract idmap idmap g pr1); intro; try reflexivity.
    exact (Eap10 Hg2 _). exact (Eap10 Hg1^E _).
  - intros [A' B' f' Hf] A'' B'' g Hg.
    use (LP_Retract Hf (retract_id _)).
      now apply LP_top'_AF.
Defined.

(* C are injections in THEIR cylinders *)
Definition C_caract2 {A B} (f: A -> B)
  : LLP (C:=TYPE) AFib f <-> ∃ (g: B -> sigT (Cyl f)), g o f ≡≡ top' × pr1 o g ≡≡ idmap.
Proof.
  split.
  - intro Hf.
    specialize (Hf (sigT (Cyl f)) B pr1).
    specialize (Hf (Build_AFib (Cyl f) Cyl_Contr (retract_id _))).
    specialize (Hf top' idmap E1).
    destruct Hf as [g [Hg1 Hg2]]; cbn in *.
    exists g; split; now apply Eap10.
  - intros [g [H1 H2]].
    intros A' B' h H.
    ref (LP_Retract (f:=top' (f:=f)) _ (retract_id _) _).
    + use (Build_Retract idmap idmap g pr1); try (intro; reflexivity).
      exact H2. intro; cbn; sym H1.
    + apply LP_top'_AF. assumption.
Defined.

Definition Cofib_W {A B} (f: A -> B)
  : IsEquiv (repl_f (top' (f:=f))) <-> IsEquiv (repl_f f).
Proof.
  assert (H': IsEquiv (repl_f (π1 (Cyl f)))). {
    use isequiv_adjointify. use repl_f. exact base'.
    intro; cbn. rew repl_f_compose; cbn. rew repl_f_idmap. exact 1.
    use repl_ind; cbn. use sig_cyl_ind; cbn.
    intro x. unfold base'. ref (transport (fun y => _ = η (f x; y)) (cyl_eq x) 1).
    intro; exact 1.
    intro; cbn. exact 1. }
  split; intro H.
  - pose proof (isequiv_compose H H').
    cbn in X; rewrite (eq_funext (repl_f_compose _ _)) in X.
    exact X.
  - ref (cancelL_isequiv (repl_f (π1 (Cyl f)))).
    exact H'.
    cbn. rewrite (eq_funext (repl_f_compose top' (π1 (Cyl f)))).
    exact H.
Defined.

Record ACofib {A B} (f : A -> B) := (* AC *)
  { acofib_A : Type ;
    acofib_B : Type ;
    acofib_k : acofib_A -> acofib_B ;
    acofib_Hk : IsEquiv (repl_f acofib_k) ;
    acofib_H : f RetractOf (top' (f:=acofib_k)) }.

Arguments Build_ACofib {A B f A' B'} k Hk H : rename.

(* AC are injections into cylinders of weak equivalences *)
Definition AC_caract2 {A B} (f: A -> B)
  : LLP (C:=TYPE) Fib f <-> ACofib f.
Proof.
  use transitive_iff. 2: apply LLPAFib_ok. split.
  - intros [Hf H].
    ref (Build_ACofib f Hf _).
    specialize (H (sigT (Cyl f)) B pr1).
    assert (AFib (∃ y, Cyl f y) B pr1). {
      ref (Build_AFib _ _ (retract_id _)).
      cbn. intro y; ref (_ E# Cyl_Contr y).
      apply PFibrant_irrelevance. }
    specialize (H X top' idmap E1); clear X.
    destruct H as [g [H1 H2]]; cbn in *.
    ref (Build_Retract idmap idmap g pr1 _ _ _ _);
      intro; try reflexivity.
    now apply Eap10. exact (Eap10 H1 _)^E.
  - intros [A' B' k Hk H]; split.
    + ref (weak_eq_retract _ _ H _); clear H.
      revert Hk. apply Cofib_W.
    + apply C_caract. ref (Build_Cofib k H).
Defined.

Definition IsInjEq {A B} (f: A -> B)
  := ∃ (r: B -> repl A) (H1: r o f ≡≡ η) (H2: (repl_f f) o r == η),
  forall x, H2 (f x) ≡ Eq_to_paths (Eap (repl_f f) (H1 x)).

(* AC are injective equivalences *)
Definition AC_caract3 {A B} (f: A -> B)
  : LLP (C:=TYPE) Fib f <-> IsInjEq f.
Proof.
  use transitive_iff.
  2: apply AC_caract. split.
  - intros [g [H1 H2]]. exists (λ y, (g y).2.1).
    use exist. intro x. exact (Eap (λ w, w.2.1) (H1 x)).
    use exist. intro y. pose (g y).2.2. cbn in *.
    ref (concat_pE (g y).2.2 _). exact (Eap η (H2 y)).
    intro x; cbn.
    pose (EapD (λ w: sigT (fiber f), w.2.2) (H1 x)^E); cbn in *.
    rewi e; clear e.
    pose (Etransport_paths_FlFrE (f:=λ w, repl_f f w.2.1) (g:= η o pr1) (H1 x)^E E1);
      cbn in *.
    ref (Eap (λ p, concat_pE p (Eap η (H2 (f x)))) _ E@ _).
    2: exact e; clear e.
    ref (concat_pE_ETP _ _ E@ Eap Eq_to_paths (Eq_UIP _ _)).
  - intros [s [H1 [H2 H3]]].
    use exist. ref (fun y => (y; s y; H2 y)).
    split; cbn.
    intro x. ref (eq_sigma _ E1 _); cbn.
    ref (eq_sigma _ (H1 x) _). rew (H3 x).
    ref (Etransport_paths_FlFrE (H1 x) (Eap (repl_f f) (H1 x)) E@ _).
    ref (Eap Eq_to_paths (Eq_UIP _ E1)).
    reflexivity.
Defined.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(** printing IR %\ensuremath{\mathbb R}% *)
(** printing PartIR %\ensuremath{\mathbb R\!\not\rightarrow\!\mathbb R}% *)
(** printing [0]R %\ensuremath{\mathbf0}% #0# *)
(** printing OneR %\ensuremath{\mathbf1}% #1# *)
(** printing AbsIR %\ensuremath{|\cdot|_{\mathbb R}}% *)

Require Export CoRN.reals.CReals.
Require CoRN.model.reals.Cauchy_IR.
From Coq Require Import Lia.

(**
* Real Number Structures
%\begin{convention}% Let [IR] be a structure for real numbers.
%\end{convention}%
*)

Definition IR : CReals.
Proof. exact Cauchy_IR.Cauchy_IR. Qed.
  (* Defining IR directly with := and then setting [Global Opaque] keeps it semi-transparent, so
   we really need [Qed] to get full opacity. *)

#[global]
Instance IR_default : @DefaultRelation IR (@st_eq IR) | 2 := {}.

Notation PartIR := (PartFunct IR).
Notation ProjIR1 := (prj1 IR _ _ _).
Notation ProjIR2 := (prj2 IR _ _ _).

Load "Transparent_algebra".

(* begin hide *)
Notation ZeroR := ([0]:IR).
Notation OneR := ([1]:IR).
(* end hide *)

Section CReals_axioms.
(**
** [CReals] axioms *)

Lemma CReals_is_CReals : is_CReals IR (Lim (IR:=IR)).
Proof.
 unfold Lim in |- *.
 elim IR; intros.
 exact crl_proof.
Qed.

(** First properties which follow trivially from the axioms.  *)

Lemma Lim_Cauchy : forall s : CauchySeq IR, SeqLimit s (Lim s).
Proof.
 elim CReals_is_CReals; auto.
Qed.

Lemma Archimedes : forall x : IR, {n : nat | x [<=] nring n}.
Proof.
 elim CReals_is_CReals; auto.
Qed.

Lemma Archimedes' : forall x : IR, {n : nat | x [<] nring n}.
Proof.
 intro x.
 elim (Archimedes (x[+][1])); intros n Hn.
 exists n.
 apply less_leEq_trans with (x[+][1]); auto.
 apply less_plusOne.
Qed.

(** A stronger version, which often comes in useful.  *)

Lemma str_Archimedes : forall x : IR,
 [0] [<=] x -> {n : nat | x [<=] nring n /\ (2 <= n -> nring n[-]Two [<=] x)}.
Proof.
 intros.
 elim (Archimedes x); intros n Hn.
 induction  n as [| n Hrecn].
  exists 0; split; auto.
  intro; exfalso; lia.
 clear Hrecn.
 induction  n as [| n Hrecn].
  exists 1.
  split; intros; [ assumption | eapply leEq_transitive ].
   2: apply H.
  simpl in |- *.
  rstepl ([--]OneR); astepr ([--]ZeroR); apply less_leEq; apply inv_resp_less; apply pos_one.
 cut (nring (R:=IR) n [<] nring (S n)).
  intros H0.
  cut (nring n [<] x or x [<] nring (S n)).
   intros H1.
   elim H1; intros.
    exists (S (S n)).
    split.
     assumption.
    intros.
    simpl in |- *; rstepl (nring (R:=IR) n); apply less_leEq; assumption.
   apply Hrecn; apply less_leEq; assumption.
  apply less_cotransitive_unfolded; assumption.
 simpl in |- *; apply less_plusOne.
Qed.

Definition CauchySeqR := CauchySeq IR.

End CReals_axioms.

Section Cauchy_Defs.

(**
** Cauchy sequences
*** Alternative definitions
This section gives several definitions of Cauchy sequences. There
are no lemmas in this section.

The current definition of Cauchy ([Cauchy_prop]) is:

%\[\forall \epsilon>0. \exists N. \forall m\geq N. |seq_m - seq_N|\leq\varepsilon\]%
#for all e>0 there exists N such that for all m≥ N |seqm-seqN|≤ e#

Variant 1 of Cauchy ([Cauchy_prop1]) is:

%\[\forall k. \exists N. \forall m \geq N. |seq_m - seq_N|\leq1/(k+1)\]%
#for all k there exists N such that for all m ≥ N |seqm-seqN| ≤ 1/(k+1)#

In all of the following variants the limit occurs in the definition.
Therefore it is useful to define an auxiliary predicate
[Cauchy_Lim_prop?], in terms of which [Cauchy_prop?] is defined.

Variant 2 of Cauchy ([Cauchy_prop2]) is [exists y, (Cauchy_Lim_prop2 seq y)]
where
[[
Cauchy_Lim_prop2 seq y := forall eps [>] [0], exists N, forall m >= N, (AbsIR seq m - y) [<=] eps
]]

Note that [Cauchy_Lim_prop2] equals [seqLimit].

Variant 3 of Cauchy ([Cauchy_prop3]) reads [exists y, (Cauchy_Lim_prop3 seq y)]
where
[[
Cauchy_Lim_prop3 seq y := forall k, exists N, forall m >= N, (AbsIR seq m - y) [<=] [1][/] (k[+]1)
]]

The following variant is more restricted.

Variant 4 of Cauchy ([Cauchy_prop4]): [exists y, (Cauchy_Lim_prop4 seq y)]
where
[[
Cauchy_Lim_prop4 seq y := forall k, (AbsIR seq m - y) [<=] [1][/] (k[+]1)
]]

So
[[
Cauchy_prop4 -> Cauchy_prop3 Iff Cauchy_prop2 Iff Cauchy_prop1 Iff Cauchy_prop
]]
Note: we don't know which formulations are useful.

The inequalities are stated with [[<=]] rather than with [<] for the
following reason: both formulations are equivalent, as is well known;
and [[<=]] being a negative statement, this makes proofs
sometimes easier and program extraction much more efficient.
*)

Definition Cauchy_prop1 (seq : nat -> IR) := forall k,
 {N : nat | forall m, N <= m -> AbsSmall (one_div_succ k) (seq m[-]seq N)}.

Definition Cauchy_Lim_prop2 (seq : nat -> IR) (y : IR) := forall eps,
  [0] [<] eps -> {N : nat | forall m, N <= m -> AbsSmall eps (seq m[-]y)}.

Definition Cauchy_prop2 (seq : nat -> IR) := {y : IR | Cauchy_Lim_prop2 seq y}.

Definition Cauchy_Lim_prop3 (seq : nat -> IR) (y : IR) := forall k,
  {N : nat | forall m, N <= m -> AbsSmall (one_div_succ k) (seq m[-]y)}.

Definition Cauchy_prop3 (seq : nat -> IR) := {y : IR | Cauchy_Lim_prop3 seq y}.

Definition Cauchy_Lim_prop4 (seq : nat -> IR) (y : IR) := forall m,
 AbsSmall (one_div_succ m) (seq m[-]y).

Definition Cauchy_prop4 (seq : nat -> IR) := {y : IR | Cauchy_Lim_prop4 seq y}.

End Cauchy_Defs.

Section Inequalities.
(**
*** Inequalities of Limits

The next lemma is equal to lemma [Lim_Cauchy].  *)

Lemma Cauchy_complete : forall seq : CauchySeq IR, Cauchy_Lim_prop2 seq (Lim seq).
Proof.
 exact Lim_Cauchy.
Qed.

Lemma less_Lim_so_less_seq : forall (seq : CauchySeq IR) y,
 y [<] Lim seq -> {N : nat | forall m, N <= m -> y [<] seq m}.
Proof.
 intros seq y H.
 elim (Cauchy_complete seq ((Lim seq[-]y) [/]TwoNZ)).
  intro N.
  intros H0.
  split with N.
  intros m H1.
  generalize (H0 _ H1). intro H2.
  unfold AbsSmall in H2.
  elim H2.
  intros.
  apply plus_cancel_less with ([--] (Lim seq)).
  rstepl ([--] (Lim seq[-]y)).
  rstepr (seq m[-]Lim seq).
  eapply less_leEq_trans.
   2: apply H3.
  apply inv_resp_less; apply pos_div_two'.
  apply shift_less_minus; astepl y; auto.
 apply pos_div_two.
 apply shift_less_minus; astepl y; auto.
Qed.

Lemma Lim_less_so_seq_less : forall (seq : CauchySeq IR) y,
 Lim seq [<] y -> {N : nat | forall m, N <= m -> seq m [<] y}.
Proof.
 intros.
 elim (Cauchy_complete seq ((y[-]Lim seq) [/]TwoNZ)).
  intro N.
  intros H0.
  split with N.
  intros m H1.
  generalize (H0 _ H1); intro H2.
  unfold AbsSmall in H2.
  elim H2.
  intros H3 H4.
  apply plus_cancel_less with ([--] (Lim seq)).
  eapply leEq_less_trans.
   apply H4.
  apply pos_div_two'.
  apply shift_less_plus; rstepl (Lim seq); auto.
 apply pos_div_two.
 apply shift_less_minus; astepl (Lim seq); auto.
Qed.

Lemma Lim_less_Lim_so_seq_less_seq : forall seq1 seq2 : CauchySeq IR,
 Lim seq1 [<] Lim seq2 -> {N : nat | forall m, N <= m -> seq1 m [<] seq2 m}.
Proof.
 intros.
 set (Av := (Lim seq1[+]Lim seq2) [/]TwoNZ) in |- *.
 cut (Lim seq1 [<] Av); try intro H0.
  cut (Av [<] Lim seq2); try intro H1.
   generalize (Lim_less_so_seq_less _ _ H0); intro H2.
   generalize (less_Lim_so_less_seq _ _ H1); intro H3.
   elim H2; intro N1; intro H4.
   elim H3; intro N2; intro H5.
   exists (max N1 N2); intros.
   apply less_leEq_trans with Av.
    apply H4.
    apply le_trans with (max N1 N2).
     apply le_max_l.
    assumption.
   apply less_leEq.
   apply H5.
   apply le_trans with (max N1 N2).
    apply le_max_r.
   assumption.
  unfold Av in |- *.
  apply Average_less_Greatest.
  assumption.
 unfold Av in |- *.
 apply Smallest_less_Average.
 assumption.
Qed.

(** The next lemma follows from [less_Lim_so_less_seq] with [y := (y[+] (Lim seq)) [/]TwoNZ].  *)

Lemma less_Lim_so : forall (seq : CauchySeq IR) y, y [<] Lim seq ->
 {eps : IR | [0] [<] eps | {N : nat | forall m, N <= m -> y[+]eps [<] seq m}}.
Proof.
 intros.
 elim (less_Lim_so_less_seq seq ((y[+]Lim seq) [/]TwoNZ)).
  intros x H0.
  exists ((Lim seq[-]y) [/]TwoNZ).
   apply pos_div_two.
   apply shift_zero_less_minus.
   assumption.
  exists x.
  intros.
  rstepl ((y[+]Lim seq) [/]TwoNZ).
  apply H0.
  assumption.
 apply Average_less_Greatest.
 assumption.
Qed.

Lemma Lim_less_so : forall (seq : CauchySeq IR) y, Lim seq [<] y ->
 {eps : IR | [0] [<] eps | {N : nat | forall m, N <= m -> seq m[+]eps [<] y}}.
Proof.
 intros.
 elim (Lim_less_so_seq_less seq ((Lim seq[+]y) [/]TwoNZ)).
  intros x H0.
  exists ((y[-]Lim seq) [/]TwoNZ).
   apply pos_div_two.
   apply shift_zero_less_minus.
   assumption.
  exists x.
  intros.
  apply shift_plus_less.
  rstepr ((Lim seq[+]y) [/]TwoNZ).
  apply H0.
  assumption.
 apply Smallest_less_Average.
 assumption.
Qed.

Lemma leEq_seq_so_leEq_Lim : forall (seq : CauchySeqR) y, (forall i, y [<=] seq i) -> y [<=] Lim seq.
Proof.
 intros.
 rewrite -> leEq_def in |- *.
 intro H0.
 generalize (Lim_less_so_seq_less _ _ H0); intro H1.
 elim H1; intros N H2.
 pose (c:=H N).
 rewrite -> leEq_def in c.
 apply c.
 apply H2.
 auto with arith.
Qed.

Lemma str_leEq_seq_so_leEq_Lim : forall (seq : CauchySeq IR) y,
 (exists N : nat, (forall i, N <= i -> y [<=] seq i)) -> y [<=] Lim seq.
Proof.
 intros.
 rewrite -> leEq_def; intro H0.
 generalize (Lim_less_so_seq_less _ _ H0).
 elim H; intros N HN.
 intro H1.
 elim H1; intros M HM.
 cut (y [<] y).
  apply less_irreflexive_unfolded.
 apply leEq_less_trans with (seq (max N M)).
  apply HN; apply le_max_l.
 apply HM; apply le_max_r.
Qed.

Lemma Lim_leEq_Lim : forall seq1 seq2 : CauchySeqR,
 (forall i, seq1 i [<=] seq2 i) -> Lim seq1 [<=] Lim seq2.
Proof.
 intros.
 rewrite -> leEq_def in |- *.
 intro H0.
 generalize (Lim_less_Lim_so_seq_less_seq _ _ H0); intro H1.
 elim H1; intros N H2.
 pose (c:=H N).
 rewrite -> leEq_def in c.
 apply c.
 apply H2.
 auto with arith.
Qed.

Lemma seq_leEq_so_Lim_leEq : forall (seq : CauchySeqR) y, (forall i, seq i [<=] y) -> Lim seq [<=] y.
Proof.
 intros.
 rewrite -> leEq_def in |- *.
 intro H0.
 generalize (less_Lim_so_less_seq _ _ H0); intro H1.
 elim H1; intros N H2.
 pose (c:=H N).
 rewrite -> leEq_def in c.
 apply c.
 apply H2.
 auto with arith.
Qed.

Lemma str_seq_leEq_so_Lim_leEq : forall (seq : CauchySeq IR) y,
 (exists N : nat, (forall i, N <= i -> seq i [<=] y)) -> Lim seq [<=] y.
Proof.
 intros.
 rewrite -> leEq_def; intro H0.
 generalize (less_Lim_so_less_seq _ _ H0).
 elim H; intros N HN.
 intro H1.
 elim H1; intros M HM.
 cut (y [<] y).
  apply less_irreflexive_unfolded.
 apply less_leEq_trans with (seq (max N M)).
  apply HM; apply le_max_r.
 apply HN; apply le_max_l.
Qed.

Lemma Limits_unique : forall (seq : CauchySeq IR) y,
 Cauchy_Lim_prop2 seq y -> y [=] Lim seq.
Proof.
 intros seq y H.
 apply not_ap_imp_eq.
 unfold not in |- *; intro H0.
 generalize (ap_imp_less _ _ _ H0); intro H1.
 elim H1; intro H2.
  elim (less_Lim_so _ _ H2); intro eps; intros H4 H5.
  elim H5; intro N; intro H6.
  unfold Cauchy_Lim_prop2 in H.
  elim (H _ H4); intro N'; intro H7.
  generalize (le_max_l N N'); intro H8.
  generalize (le_max_r N N'); intro H9.
  generalize (H6 _ H8); intro H10.
  generalize (H7 _ H9); intro H11.
  elim H11; intros H12 H13.
  apply (less_irreflexive_unfolded _ (y[+]eps)).
  eapply less_leEq_trans.
   apply H10.
  apply plus_cancel_leEq_rht with ([--]y).
  rstepr eps.
  exact H13.
 (* Second case similar to first case *)
 elim (Lim_less_so _ _ H2); intro eps; intros H4 H5.
 elim H5; intro N; intros H6.
 unfold Cauchy_Lim_prop2 in H.
 elim (H _ H4); intro N'; intros H7.
 generalize (le_max_l N N'); intro H8.
 generalize (le_max_r N N'); intro H9.
 generalize (H6 _ H8); intro H10.
 generalize (H7 _ H9); intro H11.
 elim H11; intros H12 H13.
 apply (less_irreflexive_unfolded _ y).
 eapply leEq_less_trans.
  2: apply H10.
 apply plus_cancel_leEq_rht with ([--]y[-]eps).
 rstepl ([--]eps).
 rstepr (seq (max N N') [-]y).
 assumption.
Qed.

Lemma Lim_wd : forall (seq : nat -> IR) x y,
 x [=] y -> Cauchy_Lim_prop2 seq x -> Cauchy_Lim_prop2 seq y.
Proof.
 intros seq x y H H0.
 red in |- *; red in H0.
 intros eps H1.
 elim (H0 _ H1).
 intros N HN.
 exists N.
 intros.
 astepr (seq m[-]x).
 apply HN; assumption.
Qed.

Lemma Lim_strext : forall seq1 seq2 : CauchySeq IR,
 Lim seq1 [#] Lim seq2 -> {n : nat | seq1 n [#] seq2 n}.
Proof.
 intros seq1 seq2 H.
 cut ({n : nat | seq1 n [<] seq2 n} or {n : nat | seq2 n [<] seq1 n}).
  intro H0; inversion_clear H0; rename X into H1; elim H1; intros n Hn.
   exists n; apply less_imp_ap; assumption.
  exists n; apply Greater_imp_ap; assumption.
 cut (Lim seq1 [<] Lim seq2 or Lim seq2 [<] Lim seq1). intros H0.
  2: apply ap_imp_less; assumption.
 inversion_clear H0; [ left | right ].
  cut {n : nat | forall m : nat, n <= m -> seq1 m [<] seq2 m}.
   2: apply Lim_less_Lim_so_seq_less_seq; assumption.
  intro H0; elim H0; intros N HN.
  exists N; apply HN; auto with arith.
 cut {n : nat | forall m : nat, n <= m -> seq2 m [<] seq1 m}.
  2: apply Lim_less_Lim_so_seq_less_seq; assumption.
 intro H0; elim H0; intros N HN.
 exists N; apply HN; auto with arith.
Qed.

Lemma Lim_ap_imp_seq_ap : forall seq1 seq2 : CauchySeq IR,
 Lim seq1 [#] Lim seq2 -> {N : nat | forall m, N <= m -> seq1 m [#] seq2 m}.
Proof.
 intros seq1 seq2 H.
 elim (ap_imp_less _ _ _ H); intro.
  elim (Lim_less_Lim_so_seq_less_seq _ _ a); intros N HN.
  exists N; intros.
  apply less_imp_ap; apply HN; assumption.
 elim (Lim_less_Lim_so_seq_less_seq _ _ b); intros N HN.
 exists N; intros.
 apply Greater_imp_ap; apply HN; assumption.
Qed.

Lemma Lim_ap_imp_seq_ap' : forall seq1 seq2 : CauchySeq IR,
 Lim seq1 [#] Lim seq2 -> {N : nat | seq1 N [#] seq2 N}.
Proof.
 intros seq1 seq2 H.
 elim (Lim_ap_imp_seq_ap _ _ H); intros N HN.
 exists N; apply HN.
 apply le_n.
Qed.

End Inequalities.

Section Equiv_Cauchy.

(**
*** Equivalence of formulations of Cauchy *)

Lemma Cauchy_prop1_prop : forall seq, Cauchy_prop1 seq -> Cauchy_prop seq.
Proof.
 intros seq H.
 unfold Cauchy_prop1 in H.
 unfold Cauchy_prop in |- *.
 intros.
 cut (e [#] [0]).
  intro eNZ.
  elim (Archimedes ([1][/] e[//]eNZ)).
  intros x H1.
  elim (H x).
  intros x0 H2.
  split with x0.
  intros m H3.
  generalize (H2 _ H3).
  intro.
  apply AbsSmall_leEq_trans with (one_div_succ (R:=IR) x).
   unfold one_div_succ in |- *.
   unfold Snring in |- *.
   apply shift_div_leEq'.
    apply nring_pos.
    auto with arith.
   astepr (e[*]nring (S x)).
   apply leEq_transitive with (e[*]nring x).
    apply shift_leEq_mult' with eNZ.
     assumption.
    assumption.
   apply less_leEq.
   apply mult_resp_less_lft.
    apply nring_less.
    auto.
   assumption.
  assumption.
 apply pos_ap_zero.
 assumption.
Qed.

Lemma Cauchy_prop2_prop : forall seq, Cauchy_prop2 seq -> Cauchy_prop seq.
Proof.
 intros seq H.
 unfold Cauchy_prop in |- *.
 intros e H0.
 unfold Cauchy_prop2 in H.
 elim H.
 intro y; intros H1.
 unfold Cauchy_Lim_prop2 in H1.
 elim (H1 (e [/]TwoNZ)).
  intro N.
  intros H2.
  exists N.
  intros m H3.
  generalize (H2 _ H3); intro H4.
  generalize (le_n N); intro H5.
  generalize (H2 _ H5); intro H6.
  generalize (AbsSmall_minus _ _ _ _ H6); intro H7.
  generalize (AbsSmall_plus _ _ _ _ _ H4 H7); intro H8.
  rstepl (e [/]TwoNZ[+]e [/]TwoNZ).
  rstepr (seq m[-]y[+] (y[-]seq N)).
  assumption.
 apply pos_div_two.
 assumption.
Qed.

Lemma Cauchy_Lim_prop3_prop2 : forall seq y,
 Cauchy_Lim_prop3 seq y -> Cauchy_Lim_prop2 seq y.
Proof.
 intros seq y H.
 unfold Cauchy_Lim_prop2 in |- *.
 intros eps H0.
 unfold Cauchy_Lim_prop3 in H.
 generalize (pos_ap_zero _ _ H0); intro Heps.
 elim (Archimedes ([1][/] eps[//]Heps)).
 intro K; intros H1.
 elim (H K).
 intro N; intros H2.
 exists N.
 intros m H3.
 generalize (H2 _ H3); intro H4.
 apply AbsSmall_leEq_trans with (one_div_succ (R:=IR) K); try assumption.
 unfold one_div_succ in |- *.
 unfold Snring in |- *.
 apply shift_div_leEq'.
  apply nring_pos.
  auto with arith.
 apply leEq_transitive with (eps[*]nring K).
  apply shift_leEq_mult' with Heps; assumption.
 astepl (nring K[*]eps).
 apply less_leEq.
 apply mult_resp_less; try assumption.
 apply nring_less.
 auto with arith.
Qed.

Lemma Cauchy_prop3_prop2 : forall seq, Cauchy_prop3 seq -> Cauchy_prop2 seq.
Proof.
 unfold Cauchy_prop2 in |- *.
 unfold Cauchy_prop3 in |- *.
 intros seq H.
 elim H; intros x H0.
 exists x.
 apply Cauchy_Lim_prop3_prop2.
 assumption.
Qed.

Lemma Cauchy_prop3_prop : forall seq, Cauchy_prop3 seq -> Cauchy_prop seq.
Proof.
 intros.
 apply Cauchy_prop2_prop.
 apply Cauchy_prop3_prop2.
 assumption.
Qed.

Definition Build_CauchySeq1 : forall seq, Cauchy_prop1 seq -> CauchySeqR.
Proof.
 intros.
 unfold CauchySeqR in |- *.
 apply Build_CauchySeq with seq.
 apply Cauchy_prop1_prop.
 assumption.
Defined.

Lemma Cauchy_Lim_prop4_prop3 : forall seq y,
 Cauchy_Lim_prop4 seq y -> Cauchy_Lim_prop3 seq y.
Proof.
 intros.
 unfold Cauchy_Lim_prop4 in H.
 unfold Cauchy_Lim_prop3 in |- *.
 intros.
 exists k.
 intros.
 apply AbsSmall_leEq_trans with (one_div_succ (R:=IR) m).
  2: apply H.
 apply one_div_succ_resp_leEq.
 assumption.
Qed.

Lemma Cauchy_Lim_prop4_prop2 : forall seq y,
 Cauchy_Lim_prop4 seq y -> Cauchy_Lim_prop2 seq y.
Proof.
 intros.
 apply Cauchy_Lim_prop3_prop2.
 apply Cauchy_Lim_prop4_prop3.
 assumption.
Qed.

Lemma Cauchy_prop4_prop3 : forall seq, Cauchy_prop4 seq -> Cauchy_prop3 seq.
Proof.
 unfold Cauchy_prop4 in |- *.
 unfold Cauchy_prop3 in |- *.
 intros seq H.
 elim H; intros.
 exists x.
 apply Cauchy_Lim_prop4_prop3.
 assumption.
Qed.

Lemma Cauchy_prop4_prop : forall seq, Cauchy_prop4 seq -> Cauchy_prop seq.
Proof.
 intros.
 apply Cauchy_prop3_prop.
 apply Cauchy_prop4_prop3.
 assumption.
Qed.

Definition Build_CauchySeq4 : forall seq, Cauchy_prop4 seq -> CauchySeqR.
Proof.
 intros.
 unfold CauchySeqR in |- *.
 apply Build_CauchySeq with seq.
 apply Cauchy_prop4_prop.
 assumption.
Defined.

Definition Build_CauchySeq4_y : forall seq y, Cauchy_Lim_prop4 seq y -> CauchySeqR.
Proof.
 intros.
 apply Build_CauchySeq4 with seq.
 unfold Cauchy_prop4 in |- *.
 exists y.
 assumption.
Defined.

Lemma Lim_CauchySeq4 : forall seq y H, Lim (Build_CauchySeq4_y seq y H) [=] y.
Proof.
 intros.
 apply eq_symmetric_unfolded.
 apply Limits_unique.
 apply Cauchy_Lim_prop3_prop2.
 apply Cauchy_Lim_prop4_prop3.
 unfold Build_CauchySeq4_y in |- *.
 unfold Build_CauchySeq4 in |- *.
 unfold CS_seq in |- *.
 assumption.
Qed.

Definition Build_CauchySeq2 : forall seq, Cauchy_prop2 seq -> CauchySeqR.
Proof.
 intros.
 unfold CauchySeqR in |- *.
 apply Build_CauchySeq with seq.
 apply Cauchy_prop2_prop.
 assumption.
Defined.

Definition Build_CauchySeq2_y : forall seq y, Cauchy_Lim_prop2 seq y -> CauchySeqR.
Proof.
 intros.
 apply Build_CauchySeq2 with seq.
 unfold Cauchy_prop2 in |- *.
 exists y.
 assumption.
Defined.

Lemma Lim_CauchySeq2 : forall seq y H, Lim (Build_CauchySeq2_y seq y H) [=] y.
Proof.
 intros.
 apply eq_symmetric_unfolded.
 apply Limits_unique.
 unfold Build_CauchySeq2_y in |- *.
 unfold Build_CauchySeq2 in |- *.
 unfold CS_seq in |- *.
 assumption.
Qed.

(** Well definedness. *)

Lemma Cauchy_prop_wd' : forall seq1 seq2 : nat -> IR,
 Cauchy_prop seq1 -> {N : nat | forall n, N <= n ->  seq1 n [=] seq2 n} -> Cauchy_prop seq2.
Proof.
 intros seq1 seq2 H H0.
 red in |- *.  intros e H1.
 elim (H (e[/]TwoNZ) (pos_div_two IR e H1)).
 intros N Hn.
 destruct H0 as [M H0].
 exists (max M N). intros.
 astepr (seq1 m[-]seq1 (max M N)).
  astepr ((seq1 m[-]seq1 N)[+](seq1 N [-]seq1 (max M N))).
   apply AbsSmall_eps_div_two.
    apply Hn. eauto with arith.
    apply AbsSmall_minus. apply Hn. eauto with arith.
   rational.
 apply cg_minus_wd; apply H0; eauto with arith.
Qed.

Lemma Cauchy_prop_wd : forall seq1 seq2 : nat -> IR,
 Cauchy_prop seq1 -> (forall n, seq1 n [=] seq2 n) -> Cauchy_prop seq2.
Proof.
 intros.
 apply Cauchy_prop_wd' with seq1; auto.
 exists 0.
 auto.
Qed.

Lemma Cauchy_Lim_prop2_wd' : forall seq1 seq2 c, Cauchy_Lim_prop2 seq1 c ->
 { N : nat | forall n, N <= n -> seq1 n [=] seq2 n} -> Cauchy_Lim_prop2 seq2 c.
Proof.
 intros seq1 seq2 c H1 H2.
 red in |- *. intros eps H3.
 elim (H1 eps H3).
 intros M H4.
 destruct H2 as [N H2].
 exists (max N M) .
 intros.
 assert (N <= m); eauto with arith.
 assert (M <= m); eauto with arith.
 astepr (seq1 m[-]c).
 apply H4; auto.
Qed.

Lemma Cauchy_Lim_prop2_wd : forall seq1 seq2 c, Cauchy_Lim_prop2 seq1 c ->
 (forall n, seq1 n [=] seq2 n) -> Cauchy_Lim_prop2 seq2 c.
Proof.
 intros.
 apply Cauchy_Lim_prop2_wd' with seq1; auto.
 exists 0.
 auto.
Qed.

Lemma Lim_wd'' : forall seq1 seq2 : CauchySeqR,
 {N : nat |  forall n : nat, N <= n  -> seq1 n [=] seq2 n} -> Lim seq1 [=] Lim seq2.
Proof.
 intros seq1 seq2 H. destruct H as [N H].
 cut (Cauchy_Lim_prop2 seq1 (Lim seq2)).
  intro.
  apply eq_symmetric_unfolded.
  apply Limits_unique; assumption.
 apply Cauchy_Lim_prop2_wd' with (seq2:nat -> IR).
  apply Cauchy_complete.
 exists N.
 intros; apply eq_symmetric_unfolded. auto.
Qed.

Lemma Lim_wd' : forall seq1 seq2 : CauchySeqR,
 (forall n : nat, seq1 n [=] seq2 n) -> Lim seq1 [=] Lim seq2.
Proof.
 intros.
 apply Lim_wd''; auto.
 exists 0.
 auto.
Qed.

Lemma Lim_unique : forall seq x y,
 Cauchy_Lim_prop2 seq x -> Cauchy_Lim_prop2 seq y -> x [=] y.
Proof.
 intros.
 cut (Cauchy_prop seq); [ intro | apply Cauchy_prop2_prop; exists y; auto ].
 apply eq_transitive_unfolded with (Lim (Build_CauchySeq _ _ X1)).
  apply Limits_unique; auto.
 apply eq_symmetric_unfolded; apply Limits_unique; auto.
Qed.

End Equiv_Cauchy.

Section Cauchy_props.

(**
*** Properties of Cauchy sequences

Some of these lemmas are now obsolete, because they were reproved for arbitrary ordered fields$\ldots$#...#

We begin by defining the constant sequence and proving that it is Cauchy with the expected limit.
*)

Definition Cauchy_const : IR -> CauchySeq IR.
Proof.
 intro x.
 apply Build_CauchySeq with (fun n : nat => x).
 intros; exists 0.
 intros; astepr ZeroR.
 apply zero_AbsSmall; apply less_leEq; assumption.
Defined.

Lemma Lim_const : forall x : IR, x [=] Lim (Cauchy_const x).
Proof.
 intros.
 apply Limits_unique.
 red in |- *; intro; exists 0.
 intros; unfold Cauchy_const in |- *; simpl in |- *.
 astepr ZeroR; apply zero_AbsSmall; apply less_leEq; assumption.
Qed.

Lemma Cauchy_Lim_plus : forall seq1 seq2 y1 y2,
 Cauchy_Lim_prop2 seq1 y1 -> Cauchy_Lim_prop2 seq2 y2 ->
 Cauchy_Lim_prop2 (fun n => seq1 n [+] seq2 n) (y1 [+] y2).
Proof.
 intros seq1 seq2 y1 y2 H H0.
 unfold Cauchy_Lim_prop2 in |- *.
 intros eps H1.
 cut ([0] [<] eps [/]TwoNZ).
  intro H2.
  elim (H _ H2); intros x H3.
  elim (H0 _ H2); intros x0 H4.
  exists (max x x0).
  intros.
  rstepr (seq1 m[-]y1[+] (seq2 m[-]y2)).
  apply AbsSmall_eps_div_two.
   apply H3.
   apply le_trans with (max x x0).
    apply le_max_l.
   assumption.
  apply H4.
  apply le_trans with (max x x0).
   apply le_max_r.
  assumption.
 apply pos_div_two.
 assumption.
Qed.

Lemma Cauchy_plus : forall seq1 seq2 : CauchySeqR,
 Cauchy_prop (fun n => seq1 n [+] seq2 n).
Proof.
 intros.
 apply Cauchy_prop2_prop.
 unfold Cauchy_prop2 in |- *.
 exists (Lim seq1[+]Lim seq2).
 apply Cauchy_Lim_plus.
  apply Cauchy_complete.
 apply Cauchy_complete.
Qed.

Lemma Lim_plus : forall seq1 seq2 : CauchySeqR,
 Lim (Build_CauchySeq _ _ (Cauchy_plus seq1 seq2)) [=] Lim seq1 [+] Lim seq2.
Proof.
 intros.
 apply eq_symmetric_unfolded.
 apply Limits_unique.
 simpl in |- *.
 apply Cauchy_Lim_plus.
  apply Cauchy_complete.
 apply Cauchy_complete.
Qed.

Lemma Cauchy_Lim_inv : forall seq y,
 Cauchy_Lim_prop2 seq y -> Cauchy_Lim_prop2 (fun n => [--] (seq n)) [--]y.
Proof.
 intros seq y H.
 unfold Cauchy_Lim_prop2 in |- *.
 intros eps H0.
 elim (H _ H0); intros x H1.
 exists x.
 intros.
 rstepr ([--] (seq m[-]y)).
 apply inv_resp_AbsSmall.
 apply H1.
 assumption.
Qed.

Lemma Cauchy_inv : forall seq : CauchySeqR, Cauchy_prop (fun n => [--] (seq n)).
Proof.
 intros.
 apply Cauchy_prop2_prop.
 unfold Cauchy_prop2 in |- *.
 exists ([--] (Lim seq)).
 apply Cauchy_Lim_inv.
 apply Cauchy_complete.
Qed.

Lemma Lim_inv : forall seq : CauchySeqR,
 Lim (Build_CauchySeq _ _ (Cauchy_inv seq)) [=] [--] (Lim seq).
Proof.
 intros.
 apply eq_symmetric_unfolded.
 apply Limits_unique.
 simpl in |- *.
 apply Cauchy_Lim_inv.
 apply Cauchy_complete.
Qed.

Lemma Cauchy_Lim_minus : forall seq1 seq2 y1 y2,
 Cauchy_Lim_prop2 seq1 y1 -> Cauchy_Lim_prop2 seq2 y2 ->
 Cauchy_Lim_prop2 (fun n => seq1 n[-]seq2 n) (y1[-]y2).
Proof.
 intros.
 unfold cg_minus in |- *.
 change (Cauchy_Lim_prop2 (fun n : nat => seq1 n[+] (fun m : nat => [--] (seq2 m)) n)
   (y1[+][--]y2)) in |- *.
 apply Cauchy_Lim_plus.
  assumption.
 apply Cauchy_Lim_inv.
 assumption.
Qed.

Lemma Cauchy_minus : forall seq1 seq2 : CauchySeqR,
 Cauchy_prop (fun n => seq1 n[-]seq2 n).
Proof.
 intros.
 apply Cauchy_prop2_prop.
 unfold Cauchy_prop2 in |- *.
 exists (Lim seq1[-]Lim seq2).
 apply Cauchy_Lim_minus.
  apply Cauchy_complete.
 apply Cauchy_complete.
Qed.

Lemma Lim_minus : forall seq1 seq2 : CauchySeqR,
 Lim (Build_CauchySeq _ _ (Cauchy_minus seq1 seq2)) [=] Lim seq1[-]Lim seq2.
Proof.
 intros.
 apply eq_symmetric_unfolded.
 apply Limits_unique.
 simpl in |- *.
 apply Cauchy_Lim_minus.
  apply Cauchy_complete.
 apply Cauchy_complete.
Qed.

Lemma Cauchy_Lim_mult : forall seq1 seq2 y1 y2,
 Cauchy_Lim_prop2 seq1 y1 -> Cauchy_Lim_prop2 seq2 y2 ->
 Cauchy_Lim_prop2 (fun n => seq1 n [*] seq2 n) (y1 [*] y2).
Proof.
 unfold Cauchy_Lim_prop2 in |- *. intros. rename X into H. rename X0 into H0. rename X1 into H1.
 elim (mult_contin _ y1 y2 eps H1). intro c. intros H2 H3.
 elim H3. clear H3. intro d. intros H3 H4.
 elim (H c H2). clear H. intro N1. intros H.
 elim (H0 d H3). clear H0. intro N2. intros H0.
 cut {N : nat | N1 <= N /\ N2 <= N}. intro H5.
  elim H5. clear H5. intro N. intro H5. elim H5. clear H5. intros.
  exists N. intros.
  apply AbsSmall_wdr_unfolded with ([--] (y1[*]y2[-]seq1 m[*]seq2 m)).
   apply inv_resp_AbsSmall.
   apply H4; clear H4; intros.
    apply AbsSmall_wdr_unfolded with ([--] (seq1 m[-]y1)).
     apply inv_resp_AbsSmall.
     apply H. apply le_trans with N; auto.
     rational.
   apply AbsSmall_wdr_unfolded with ([--] (seq2 m[-]y2)).
    apply inv_resp_AbsSmall.
    apply H0. apply le_trans with N; auto.
    rational.
  rational.
 elim (le_lt_dec N1 N2); intros.
  exists N2. auto.
  exists N1. split. auto. auto with arith.
Qed.

Lemma Cauchy_mult : forall seq1 seq2 : CauchySeqR,
 Cauchy_prop (fun n => seq1 n [*] seq2 n).
Proof.
 intros.
 apply Cauchy_prop2_prop.
 unfold Cauchy_prop2 in |- *.
 exists (Lim seq1[*]Lim seq2).
 apply Cauchy_Lim_mult.
  apply Cauchy_complete.
 apply Cauchy_complete.
Qed.

Lemma Lim_mult : forall seq1 seq2 : CauchySeqR,
 Lim (Build_CauchySeq _ _ (Cauchy_mult seq1 seq2)) [=] Lim seq1 [*] Lim seq2.
Proof.
 intros.
 apply eq_symmetric_unfolded.
 apply Limits_unique.
 simpl in |- *.
 apply Cauchy_Lim_mult.
  apply Cauchy_complete.
 apply Cauchy_complete.
Qed.

End Cauchy_props.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D E Eprime T Eprimeprime Cprime Dprime : Universe, ((wd_ C D /\ (wd_ A B /\ (wd_ A C /\ (wd_ A D /\ (wd_ Eprime A /\ (wd_ A T /\ (wd_ Eprimeprime T /\ (wd_ D Eprimeprime /\ (wd_ C Eprimeprime /\ (wd_ A Eprimeprime /\ (wd_ Dprime B /\ (wd_ Cprime B /\ (wd_ Eprimeprime B /\ (wd_ B C /\ (wd_ B D /\ (wd_ D Dprime /\ (wd_ C Cprime /\ (wd_ A E /\ (wd_ D Eprime /\ (wd_ Cprime A /\ (wd_ Dprime A /\ (col_ C D E /\ (col_ T A B /\ (col_ T C D /\ (col_ B C Cprime /\ (col_ B D Dprime /\ (col_ Cprime Dprime B /\ (col_ Cprime B D /\ (col_ D Eprimeprime C /\ col_ A Eprimeprime Eprime))))))))))))))))))))))))))))) -> col_ B C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime S U1 A AX B BX C CX BXMAX CXMAX AB AC IAC T A1 A2 BXprime : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ A1 A2 /\ (wd_ O E /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ S U1 /\ (col_ O E AX /\ (col_ O E BX /\ (col_ O E CX /\ (col_ O E BXMAX /\ (col_ O E CXMAX /\ (col_ O E T /\ (col_ O E AB /\ (col_ O E AC /\ (col_ O E IAC /\ (col_ A A1 A2 /\ (col_ A1 S U1 /\ (col_ A2 S U1 /\ (col_ S U1 BXprime /\ col_ A B C))))))))))))))))))))) -> col_ A1 A2 BXprime)).
Proof.
  time tac.
Qed.

End FOFProblem.