Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Structure.Cocartesian.
Require Export Category.Construction.Coproduct.
Require Export Category.Instance.Cat.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

(* Another way of reading this is that we're proving Cat^op is Cartesian. *)

Program Instance Cat_Cocartesian : @Cocartesian Cat := {
  product_obj := @Coproduct;
  fork := fun _ _ _ F G =>
    {| fobj := fun x =>
                 match x with
                 | Datatypes.inl x => F x
                 | Datatypes.inr x => G x
                 end
     ; fmap := fun x y f =>
                 match x with
                 | Datatypes.inl x =>
                   match y with
                   | Datatypes.inl y => _
                   | Datatypes.inr y => False_rect _ _
                   end
                 | Datatypes.inr x =>
                   match y with
                   | Datatypes.inl y => False_rect _ _
                   | Datatypes.inr y => _
                   end
                 end |};
  exl := fun _ _ =>
            {| fobj := Datatypes.inl
             ; fmap := fun _ _ => _ |};
  exr := fun _ _ =>
            {| fobj := Datatypes.inr
             ; fmap := fun _ _ => _ |};
}.
Next Obligation. exact (fmap f). Defined.
Next Obligation. exact (fmap f). Defined.
Next Obligation.
  proper.
  destruct x, y; simpl in *;
  solve [ apply fmap_respects; auto | contradiction ].
Qed.
Next Obligation.
  destruct x; simpl in *; cat.
Qed.
Next Obligation.
  destruct x, y, z; simpl in *; try tauto;
  apply fmap_comp.
Qed.
Next Obligation.
  rename x into A.
  rename y into B.
  rename z into C.
  proper.
  destruct x3, y1; simpl; auto; tauto.
Qed.
Next Obligation.
  rename x into A.
  rename y into B.
  rename z into C.
  split; intros; simplify.
  - apply (e (Datatypes.inl x0) (Datatypes.inl y)).
  - apply (e (Datatypes.inr x0) (Datatypes.inr y)).
  - destruct x1; auto.
  - destruct x1, y.
    + apply e0; tauto.
    + tauto.
    + tauto.
    + apply e; tauto.
Qed.


Require Import Coq.Lists.List.

Require Export SystemFR.Judgments.
Require Export SystemFR.AnnotatedTactics.
Require Export SystemFR.ErasedPrimitiveSize.

Lemma annotated_reducible_size:
  forall Θ Γ t A,
    [[ Θ; Γ ⊨ t : A ]] ->
    [[ Θ; Γ ⊨ tsize t : T_nat ]].
Proof.
  steps; eauto using open_reducible_tsize.
Qed.


From Fiat.Narcissus Require Import Examples.TutorialPrelude.

Record msg := { data : list (word 8) }.
Definition format := format_list format_word ◦ data.
Definition invariant (_ : msg) := True.

Definition dec : CorrectAlignedDecoderFor invariant format.
Proof.
  synthesize_aligned_decoder.
Defined.


(**
  This module defines common functions and data structures shared
  by the functional units that perform arithmetic integer operations.
*)

Require Import Kami.AllNotations.
Require Import FpuKami.Definitions.
Require Import ProcKami.FU.
Require Import List.
Import ListNotations.

Section ty.
  Context `{procParams: ProcParams}.
  Variable ty: Kind -> Type.
  Local Open Scope kami_expr.

  Definition neg (n : nat) (x : Bit n @# ty) := (~ x) + $1.

  Definition ssub n (x y : Bit n @# ty) : Bit n @# ty := x + (neg y).

  Definition intRegTag (val: Bit Rlen @# ty)
    :  PktWithException ExecUpdPkt @# ty
    := STRUCT {
         "fst"
           ::= (noUpdPkt ty)@%["val1"
                 <- (Valid (STRUCT {
                       "tag"  ::= Const ty (natToWord RoutingTagSz IntRegTag);
                       "data" ::= val
                     }))] ;
         "snd" ::= Invalid
       }.

  Close Scope kami_expr.

End ty.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal18.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (x:lst) (y:lst):@eq lst (rev (append (append (rev x) (Cons n Nil)) y))
  (append (rev y) (Cons n x)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal18_theorem0_41_append_assoc/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (x:lst) (y:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  x y.
QuickChick collect_data.
Success.


Require Import CoqlibC.
Require Import MemoryC.
Require Import Values.
Require Import Maps.
Require Import Events.
Require Import Globalenvs.
Require Import sflib.
Require Import RelationClasses.
Require Import FSets.
Require Import Ordered.
Require Import AST.
Require Import Integers.

Require Import ModSem.
Require Import Skeleton.
Require Import System.
Require Import Sound Preservation.

Set Implicit Arguments.
Section SOUNDPRODUCT.

  Variable SU0 SU1: Sound.class.

  (* Local Obligation Tactic := idtac. *)

  Global Program Instance sound_class_product: Sound.class :=
    { Sound.t := SU0.(@Sound.t) * SU1.(@Sound.t);
      Sound.mle su0 m0 m1 := SU0.(@Sound.mle) (fst su0) m0 m1 /\ SU1.(@Sound.mle) (snd su0) m0 m1;
      Sound.lepriv su0 su1 := SU0.(@Sound.lepriv) (fst su0) (fst su1) /\ SU1.(@Sound.lepriv) (snd su0) (snd su1);
      Sound.hle su0 su1 := SU0.(@Sound.hle) (fst su0) (fst su1) /\ SU1.(@Sound.hle) (snd su0) (snd su1);
      Sound.wf su0 := SU0.(@Sound.wf) (fst su0) /\ SU1.(@Sound.wf) (snd su0);
      Sound.val su0 v := SU0.(@Sound.val) (fst su0) v /\ SU1.(@Sound.val) (snd su0) v;
      Sound.mem su0 m := SU0.(@Sound.mem) (fst su0) m /\ SU1.(@Sound.mem) (snd su0) m;
      Sound.skenv su0 m ske := SU0.(@Sound.skenv) (fst su0) m ske /\ SU1.(@Sound.skenv) (snd su0) m ske
    }
  .
  Next Obligation.
    econs; eauto; ii; ss; des.
    - esplits; eauto; refl.
    - esplits; eauto; etrans; eauto.
  Qed.
  Next Obligation.
    econs; eauto; ii; ss; des.
    - esplits; eauto; refl.
    - esplits; eauto; etrans; eauto.
  Qed.
  Next Obligation.
    econs; eauto; ii; ss; des.
    - esplits; eauto; refl.
    - esplits; eauto; etrans; eauto.
  Qed.
  (* Next Obligation. *)
  (*   ii; ss. des. *)
  (*   (* destruct su0, su1; ss. *) *)
  (*   esplits; ss; eauto. *)
  (*   - eapply Sound.hle_le; et. *)
  (*   - eapply Sound.hle_le; et. *)
  (* Qed. *)
  Next Obligation.
    ii; ss. esplits; ss; eauto; eapply Sound.hle_lepriv; et.
  Qed.
  Next Obligation.
    ii; ss. esplits; ss; eauto; eapply Sound.hle_mle; et.
  Qed.
  Next Obligation.
    ii; ss. des. esplits; ss; eauto;  eapply Sound.hle_val; et.
  Qed.
  Next Obligation.
    exploit (@Sound.init_spec SU0); eauto. i; des.
    exploit (@Sound.init_spec SU1); eauto. i; des.
    exists (su_init, su_init0); eauto.
    inv SUARGS. inv SUARGS0. ss. des. esplits; ss; eauto.
  Qed.
  Next Obligation.
    ss. esplits; eauto; eapply Sound.skenv_lepriv; eauto.
  Qed.
  Next Obligation.
    ss. esplits; eauto; eapply Sound.skenv_mle; eauto.
  Qed.
  Next Obligation.
    ss. esplits; eauto; eapply Sound.skenv_project; eauto.
  Qed.
  Next Obligation.
    ss. esplits; eauto; eapply Sound.system_skenv; eauto.
  Qed.
  Next Obligation.
    ss. des.
    exploit (@Sound.system_axiom SU0); et.
    { des_ifs; ss. des. rr. esplits; eauto. rr. rewrite Forall_forall in *. ii; ss; eauto. eapply VALS; eauto. }
    intro T.
    exploit (@Sound.system_axiom SU1); et.
    { des_ifs; ss. des. rr. esplits; eauto. rr. rewrite Forall_forall in *. ii; ss; eauto. eapply VALS; eauto. }
    intro T0. des. unfold Sound.retv in *. ss. des.
    eexists (su0, su1). esplits; ss; eauto.
  Qed.

  Lemma sound_args_iff
        su0 su1 args:
      (@Sound.args SU0 su0 args) /\ (@Sound.args SU1 su1 args) <-> (@Sound.args sound_class_product (su0, su1) args)
  .
  Proof.
    unfold Sound.args. unfold Sound.vals. ss.
    des_ifs.
    - split; ii; des; esplits; eauto; rewrite Forall_forall in *; ii; ss; eauto.
      + eapply VALS; eauto.
      + eapply VALS; eauto.
    - split; ii; des; esplits; eauto; ii; ss; eauto.
      + eapply REGSET; eauto.
      + eapply REGSET; eauto.
  Qed.

  Lemma sound_skenv_iff
        su0 su1 m ske
    :
      (@Sound.skenv SU0 su0 m ske) /\ (@Sound.skenv SU1 su1 m ske) <-> (@Sound.skenv sound_class_product (su0, su1) m ske)
  .
  Proof.
    split; ii; des; esplits; ss; des; eauto.
  Qed.

  Lemma sound_retv_iff
        su0 su1 args:
      (@Sound.retv SU0 su0 args) /\ (@Sound.retv SU1 su1 args) <-> (@Sound.retv sound_class_product (su0, su1) args)
  .
  Proof.
    unfold Sound.retv. ss.
    des_ifs.
    - split; ii; des; esplits; eauto; rewrite Forall_forall in *; ii; ss; eauto.
    - split; ii; des; esplits; eauto; ii; ss; eauto.
      + eapply REGSET.
      + eapply REGSET.
  Qed.

  Theorem preservation_product
          ms sound_state0 sound_state1
          (PRSV0: @local_preservation SU0 ms sound_state0)
          (PRSV1: @local_preservation SU1 ms sound_state1):
      <<PRSV: @local_preservation sound_class_product ms
                                  (fun su m st => sound_state0 (fst su) m st /\ sound_state1 (snd su) m st)>>.
  Proof.
    inv PRSV0. inv PRSV1. econs; eauto.
    - clear - INIT INIT0. ii. ss.
      specialize (INIT (fst su_init)).
      specialize (INIT0 (snd su_init)).
      split; ss.
      + eapply INIT; eauto.
        { destruct su_init; ss. eapply sound_args_iff in SUARG; eauto. ss; des; ss. }
        { destruct su_init; ss. eapply sound_skenv_iff in SKENV; eauto. ss; des; ss. }
        { destruct su_init; ss. eapply sound_skenv_iff in SKENV; eauto. ss; des; ss. }
      + eapply INIT0; eauto.
        { destruct su_init; ss. eapply sound_args_iff in SUARG; eauto. des. ss. }
        { destruct su_init; ss. eapply sound_skenv_iff in SKENV; eauto. ss; des; ss. }
        { destruct su_init; ss. eapply sound_skenv_iff in SKENV; eauto. ss; des; ss. }
    - clear - STEP STEP0. ii. ss. des.
      specialize (STEP m_arg (fst su0)). specialize (STEP0 m_arg (snd su0)).
      split; ss.
      + eapply STEP; eauto.
      + eapply STEP0; eauto.
    - clear - CALL CALL0. ii. ss. des.
      exploit CALL; eauto. i; des.
      exploit CALL0; eauto. i; des.
      esplits; eauto.
      { instantiate (1:= (su_gr, su_gr0)). eapply sound_args_iff; eauto. }
      { ss. }
      { ss. }
      i. ss. des. split; ss.
      + eapply K; eauto. destruct su_ret; ss. eapply sound_retv_iff in RETV. des; ss.
      + eapply K0; eauto. destruct su_ret; ss. eapply sound_retv_iff in RETV. des; ss.
    - clear - RET RET0. ii. ss. des.
      specialize (RET m_arg (fst su0)). specialize (RET0 m_arg (snd su0)).
      exploit RET; eauto. i; des.
      exploit RET0; eauto. i; des.
      exists (su_ret, su_ret0). esplits; eauto. eapply sound_retv_iff. ss.
  Qed.

End SOUNDPRODUCT.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^255 - 19
Base: 25.5
***)

Definition curve : CurveParameters :=
  {|
    sz := 10%nat;
    base := 25 + 1/2;
    bitwidth := 32;
    s := 2^255;
    c := [(1, 19)];
    carry_chains := Some [seq 0 (pred 10); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := Some (fun a b =>
      (* Micro-optimized form from curve25519-donna by Adam Langley (Google) and Daniel Bernstein. See <https://github.com/agl/curve25519-donna/blob/master/LICENSE.md>. *)
      let '(in9, in8, in7, in6, in5, in4, in3, in2, in1, in0) := a in
      let '(in29, in28, in27, in26, in25, in24, in23, in22, in21, in20) := b in
      dlet output0 :=       in20 * in0 in
      dlet output1 :=       in20 * in1 +
                            in21 * in0 in
      dlet output2 :=  2 *  in21 * in1 +
                            in20 * in2 +
                            in22 * in0 in
      dlet output3 :=       in21 * in2 +
                            in22 * in1 +
                            in20 * in3 +
                            in23 * in0 in
      dlet output4 :=       in22 * in2 +
                       2 * (in21 * in3 +
                            in23 * in1) +
                            in20 * in4 +
                            in24 * in0 in
      dlet output5 :=       in22 * in3 +
                            in23 * in2 +
                            in21 * in4 +
                            in24 * in1 +
                            in20 * in5 +
                            in25 * in0 in
      dlet output6 :=  2 * (in23 * in3 +
                            in21 * in5 +
                            in25 * in1) +
                            in22 * in4 +
                            in24 * in2 +
                            in20 * in6 +
                            in26 * in0 in
      dlet output7 :=       in23 * in4 +
                            in24 * in3 +
                            in22 * in5 +
                            in25 * in2 +
                            in21 * in6 +
                            in26 * in1 +
                            in20 * in7 +
                            in27 * in0 in
      dlet output8 :=       in24 * in4 +
                       2 * (in23 * in5 +
                            in25 * in3 +
                            in21 * in7 +
                            in27 * in1) +
                            in22 * in6 +
                            in26 * in2 +
                            in20 * in8 +
                            in28 * in0 in
      dlet output9 :=       in24 * in5 +
                            in25 * in4 +
                            in23 * in6 +
                            in26 * in3 +
                            in22 * in7 +
                            in27 * in2 +
                            in21 * in8 +
                            in28 * in1 +
                            in20 * in9 +
                            in29 * in0 in
      dlet output10 := 2 * (in25 * in5 +
                            in23 * in7 +
                            in27 * in3 +
                            in21 * in9 +
                            in29 * in1) +
                            in24 * in6 +
                            in26 * in4 +
                            in22 * in8 +
                            in28 * in2 in
      dlet output11 :=      in25 * in6 +
                            in26 * in5 +
                            in24 * in7 +
                            in27 * in4 +
                            in23 * in8 +
                            in28 * in3 +
                            in22 * in9 +
                            in29 * in2 in
      dlet output12 :=      in26 * in6 +
                       2 * (in25 * in7 +
                            in27 * in5 +
                            in23 * in9 +
                            in29 * in3) +
                            in24 * in8 +
                            in28 * in4 in
      dlet output13 :=      in26 * in7 +
                            in27 * in6 +
                            in25 * in8 +
                            in28 * in5 +
                            in24 * in9 +
                            in29 * in4 in
      dlet output14 := 2 * (in27 * in7 +
                            in25 * in9 +
                            in29 * in5) +
                            in26 * in8 +
                            in28 * in6 in
      dlet output15 :=      in27 * in8 +
                            in28 * in7 +
                            in26 * in9 +
                            in29 * in6 in
      dlet output16 :=      in28 * in8 +
                       2 * (in27 * in9 +
                            in29 * in7) in
      dlet output17 :=      in28 * in9 +
                            in29 * in8 in
      dlet output18 := 2 *  in29 * in9 in
      dlet output8 := output8 + output18 << 4 in
      dlet output8 := output8 + output18 << 1 in
      dlet output8 := output8 + output18 in
      dlet output7 := output7 + output17 << 4 in
      dlet output7 := output7 + output17 << 1 in
      dlet output7 := output7 + output17 in
      dlet output6 := output6 + output16 << 4 in
      dlet output6 := output6 + output16 << 1 in
      dlet output6 := output6 + output16 in
      dlet output5 := output5 + output15 << 4 in
      dlet output5 := output5 + output15 << 1 in
      dlet output5 := output5 + output15 in
      dlet output4 := output4 + output14 << 4 in
      dlet output4 := output4 + output14 << 1 in
      dlet output4 := output4 + output14 in
      dlet output3 := output3 + output13 << 4 in
      dlet output3 := output3 + output13 << 1 in
      dlet output3 := output3 + output13 in
      dlet output2 := output2 + output12 << 4 in
      dlet output2 := output2 + output12 << 1 in
      dlet output2 := output2 + output12 in
      dlet output1 := output1 + output11 << 4 in
      dlet output1 := output1 + output11 << 1 in
      dlet output1 := output1 + output11 in
      dlet output0 := output0 + output10 << 4 in
      dlet output0 := output0 + output10 << 1 in
      dlet output0 := output0 + output10 in
      (output9, output8, output7, output6, output5, output4, output3, output2, output1, output0)
            );

    square_code := Some (fun a =>
      (* Micro-optimized form from curve25519-donna by Adam Langley (Google) and Daniel Bernstein. See <https://github.com/agl/curve25519-donna/blob/master/LICENSE.md>. *)
      let '(in9, in8, in7, in6, in5, in4, in3, in2, in1, in0) := a in
      dlet output0 :=       in0 * in0 in
      dlet output1 :=  2 *  in0 * in1 in
      dlet output2 :=  2 * (in1 * in1 +
                            in0 * in2) in
      dlet output3 :=  2 * (in1 * in2 +
                            in0 * in3) in
      dlet output4 :=       in2 * in2 +
                       4 *  in1 * in3 +
                       2 *  in0 * in4 in
      dlet output5 :=  2 * (in2 * in3 +
                            in1 * in4 +
                            in0 * in5) in
      dlet output6 :=  2 * (in3 * in3 +
                            in2 * in4 +
                            in0 * in6 +
                       2 *  in1 * in5) in
      dlet output7 :=  2 * (in3 * in4 +
                            in2 * in5 +
                            in1 * in6 +
                            in0 * in7) in
      dlet output8 :=       in4 * in4 +
                       2 * (in2 * in6 +
                            in0 * in8 +
                       2 * (in1 * in7 +
                            in3 * in5)) in
      dlet output9 :=  2 * (in4 * in5 +
                            in3 * in6 +
                            in2 * in7 +
                            in1 * in8 +
                            in0 * in9) in
      dlet output10 := 2 * (in5 * in5 +
                            in4 * in6 +
                            in2 * in8 +
                       2 * (in3 * in7 +
                            in1 * in9)) in
      dlet output11 := 2 * (in5 * in6 +
                            in4 * in7 +
                            in3 * in8 +
                            in2 * in9) in
      dlet output12 :=      in6 * in6 +
                       2 * (in4 * in8 +
                       2 * (in5 * in7 +
                            in3 * in9)) in
      dlet output13 := 2 * (in6 * in7 +
                            in5 * in8 +
                            in4 * in9) in
      dlet output14 := 2 * (in7 * in7 +
                            in6 * in8 +
                       2 *  in5 * in9) in
      dlet output15 := 2 * (in7 * in8 +
                            in6 * in9) in
      dlet output16 :=      in8 * in8 +
                       4 *  in7 * in9 in
      dlet output17 := 2 *  in8 * in9 in
      dlet output18 := 2 *  in9 * in9 in
      dlet output8 := output8 + output18 << 4 in
      dlet output8 := output8 + output18 << 1 in
      dlet output8 := output8 + output18 in
      dlet output7 := output7 + output17 << 4 in
      dlet output7 := output7 + output17 << 1 in
      dlet output7 := output7 + output17 in
      dlet output6 := output6 + output16 << 4 in
      dlet output6 := output6 + output16 << 1 in
      dlet output6 := output6 + output16 in
      dlet output5 := output5 + output15 << 4 in
      dlet output5 := output5 + output15 << 1 in
      dlet output5 := output5 + output15 in
      dlet output4 := output4 + output14 << 4 in
      dlet output4 := output4 + output14 << 1 in
      dlet output4 := output4 + output14 in
      dlet output3 := output3 + output13 << 4 in
      dlet output3 := output3 + output13 << 1 in
      dlet output3 := output3 + output13 in
      dlet output2 := output2 + output12 << 4 in
      dlet output2 := output2 + output12 << 1 in
      dlet output2 := output2 + output12 in
      dlet output1 := output1 + output11 << 4 in
      dlet output1 := output1 + output11 << 1 in
      dlet output1 := output1 + output11 in
      dlet output0 := output0 + output10 << 4 in
      dlet output0 := output0 + output10 << 1 in
      dlet output0 := output0 + output10 in
      (output9, output8, output7, output6, output5, output4, output3, output2, output1, output0)
            );

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import timel_insat_t_spec.

Definition type_LF_155 :=  PLAN ->  nat ->  nat ->  nat ->  nat -> (Prop * (List.list term)).

Definition F_155 : type_LF_155:= (fun   u1 u2 u3 _ _ => ((timel (insAt u1 u2 u3)) = u2, (Term id_timel ((Term id_insAt ((model_PLAN u1):: (model_nat u2):: (model_nat u3)::nil))::nil))::(model_nat u2)::nil)).
Definition F_167 : type_LF_155:= (fun    _ u2 u3 _ _ => ((timel (Cons (C u2 u3) Nil)) = u2, (Term id_timel ((Term id_Cons ((Term id_C ((model_nat u2):: (model_nat u3)::nil)):: (Term id_Nil nil)::nil))::nil))::(model_nat u2)::nil)).
Definition F_173 : type_LF_155:= (fun   u6 u2 u3 u8 u9 => ((le (time (C u8 u9)) u2) = true -> (timel (Cons (C u2 u3) (Cons (C u8 u9) u6))) = u2, (Term id_le ((Term id_time ((Term id_C ((model_nat u8):: (model_nat u9)::nil))::nil)):: (model_nat u2)::nil))::(Term id_true nil)::(Term id_timel ((Term id_Cons ((Term id_C ((model_nat u2):: (model_nat u3)::nil)):: (Term id_Cons ((Term id_C ((model_nat u8):: (model_nat u9)::nil)):: (model_PLAN u6)::nil))::nil))::nil))::(model_nat u2)::nil)).
Definition F_179 : type_LF_155:= (fun   u6 u2 u3 u8 u9 => ((le (time (C u8 u9)) u2) = false -> (timel (insAt u6 u2 u3)) = u2, (Term id_le ((Term id_time ((Term id_C ((model_nat u8):: (model_nat u9)::nil))::nil)):: (model_nat u2)::nil))::(Term id_false nil)::(Term id_timel ((Term id_insAt ((model_PLAN u6):: (model_nat u2):: (model_nat u3)::nil))::nil))::(model_nat u2)::nil)).
Definition F_182 : type_LF_155:= (fun    _ u2 u3 _ _ => ((time (C u2 u3)) = u2, (Term id_time ((Term id_C ((model_nat u2):: (model_nat u3)::nil))::nil))::(model_nat u2)::nil)).
Definition F_193 : type_LF_155:= (fun    _ u2 _ _ _ => (u2 = u2, (model_nat u2)::(model_nat u2)::nil)).
Definition F_185 : type_LF_155:= (fun   u6 u2 u3 u8 u9 => ((le u8 u2) = true -> (timel (Cons (C u2 u3) (Cons (C u8 u9) u6))) = u2, (Term id_le ((model_nat u8):: (model_nat u2)::nil))::(Term id_true nil)::(Term id_timel ((Term id_Cons ((Term id_C ((model_nat u2):: (model_nat u3)::nil)):: (Term id_Cons ((Term id_C ((model_nat u8):: (model_nat u9)::nil)):: (model_PLAN u6)::nil))::nil))::nil))::(model_nat u2)::nil)).
Definition F_190 : type_LF_155:= (fun   u6 u2 u3 u8 _ => ((le u8 u2) = false -> (timel (insAt u6 u2 u3)) = u2, (Term id_le ((model_nat u8):: (model_nat u2)::nil))::(Term id_false nil)::(Term id_timel ((Term id_insAt ((model_PLAN u6):: (model_nat u2):: (model_nat u3)::nil))::nil))::(model_nat u2)::nil)).
Definition F_202 : type_LF_155:= (fun    _ u2 u8 _ _ => ((le u8 u2) = false -> u2 = u2, (Term id_le ((model_nat u8):: (model_nat u2)::nil))::(Term id_false nil)::(model_nat u2)::(model_nat u2)::nil)).
Definition F_197 : type_LF_155:= (fun    _ u2 u3 u8 _ => ((le u8 u2) = true -> (time (C u2 u3)) = u2, (Term id_le ((model_nat u8):: (model_nat u2)::nil))::(Term id_true nil)::(Term id_time ((Term id_C ((model_nat u2):: (model_nat u3)::nil))::nil))::(model_nat u2)::nil)).
Definition F_206 : type_LF_155:= (fun    _ u2 u8 _ _ => ((le u8 u2) = true -> u2 = u2, (Term id_le ((model_nat u8):: (model_nat u2)::nil))::(Term id_true nil)::(model_nat u2)::(model_nat u2)::nil)).

Definition LF_155 := [F_155, F_167, F_173, F_179, F_182, F_193, F_185, F_190, F_202, F_197, F_206].

Function f_155 (u1: PLAN) (u2: nat) (u3: nat) {struct u1} : PLAN :=
 match u1, u2, u3 with
| Nil, _, _ => Nil
| (Cons (C u8 u9) u6), _, _ => Nil
end.

Lemma main_155 : forall F, In F LF_155 -> forall u1, forall u2, forall u3, forall u4, forall u5, (forall F', In F' LF_155 -> forall e1, forall e2, forall e3, forall e4, forall e5, less (snd (F' e1 e2 e3 e4 e5)) (snd (F u1 u2 u3 u4 u5)) -> fst (F' e1 e2 e3 e4 e5)) -> fst (F u1 u2 u3 u4 u5).
Proof.
intros F HF u1 u2 u3 u4 u5; case_In HF; intro Hind.

	(* GENERATE on [ 155 ] *)

rename u1 into _u1. rename u2 into _u2. rename u3 into _u3. rename u4 into d_u4. rename u5 into d_u5.
rename _u1 into u1. rename _u2 into u2. rename _u3 into u3.

revert Hind.

pattern u1, u2, u3, (f_155 u1 u2 u3). apply f_155_ind.

(* case [ 167 ] *)

intros _u1 _u2 _u3.  intro eq_1. intro. intro Heq2. rewrite <- Heq2. intro. intro Heq3. rewrite <- Heq3.  intro HFabs0.
assert (Hind := HFabs0 F_167). clear HFabs0.
assert (HFabs0 : fst (F_167 Nil _u2 _u3 0 0)).
apply Hind. trivial_in 1. unfold snd. unfold F_167. unfold F_155. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_155. unfold F_167.
auto.

intros _u1 _u2 _u3. intro u8. intro u9. intro u6.  intro eq_1. intro. intro Heq2. rewrite <- Heq2. intro. intro Heq3. rewrite <- Heq3.  intro HFabs0.
case_eq (le (time (C u8 u9)) _u2); [intro H | intro H].

(* case [ 173 ] *)

assert (Hind := HFabs0 F_173). clear HFabs0.
assert (HFabs0 : fst (F_173 u6 _u2 _u3 u8 u9)).
apply Hind. trivial_in 2. unfold snd. unfold F_173. unfold F_155. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_155. unfold F_173. simpl in H. repeat(simpl; rewrite H). repeat(simpl in HFabs0; rewrite H in HFabs0). try (auto || (intro H0; contradict H0)).
auto.

(* case [ 179 ] *)

assert (Hind := HFabs0 F_179). clear HFabs0.
assert (HFabs0 : fst (F_179 u6 _u2 _u3 u8 u9)).
apply Hind. trivial_in 3. unfold snd. unfold F_179. unfold F_155. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_155. unfold F_179. simpl in H. repeat(simpl; rewrite H). repeat(simpl in HFabs0; rewrite H in HFabs0). try (auto || (intro H0; contradict H0)).
auto.

	(* REWRITING on [ 167 ] *)

rename u1 into d_u1. rename u2 into _u2. rename u3 into _u3. rename u4 into d_u4. rename u5 into d_u5.
rename _u2 into u2. rename _u3 into u3.
assert (Res := Hind F_182). clear Hind.
assert (HFabs1 : fst (F_182 Nil u2 u3 0 0)).
apply Res. trivial_in 4. unfold snd. unfold F_182. unfold F_167. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_167. unfold fst in HFabs1. unfold F_182 in HFabs1.
pattern (C u2 u3), Nil. simpl (timel _). cbv beta.
 simpl. auto.

	(* REWRITING on [ 173 ] *)

rename u1 into _u6. rename u2 into _u2. rename u3 into _u3. rename u4 into _u8. rename u5 into _u9.
rename _u6 into u6. rename _u2 into u2. rename _u3 into u3. rename _u8 into u8. rename _u9 into u9.
assert (Res := Hind F_185). clear Hind.
assert (HFabs1 : fst (F_185 u6 u2 u3 u8 u9)).
apply Res. trivial_in 6. unfold snd. unfold F_185. unfold F_173. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_173. unfold fst in HFabs1. unfold F_185 in HFabs1.
pattern u8, u9. simpl (time _). cbv beta.
 simpl. auto.

	(* REWRITING on [ 179 ] *)

rename u1 into _u6. rename u2 into _u2. rename u3 into _u3. rename u4 into _u8. rename u5 into _u9.
rename _u6 into u6. rename _u2 into u2. rename _u3 into u3. rename _u8 into u8. rename _u9 into u9.
assert (Res := Hind F_190). clear Hind.
assert (HFabs1 : fst (F_190 u6 u2 u3 u8 0)).
apply Res. trivial_in 7. unfold snd. unfold F_190. unfold F_179. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_179. unfold fst in HFabs1. unfold F_190 in HFabs1.
pattern u8, u9. simpl (time _). cbv beta.
 simpl. auto.

	(* REWRITING on [ 182 ] *)

rename u1 into d_u1. rename u2 into _u2. rename u3 into _u3. rename u4 into d_u4. rename u5 into d_u5.
rename _u2 into u2. rename _u3 into u3.
assert (Res := Hind F_193). clear Hind.
assert (HFabs1 : fst (F_193 Nil u2 0 0 0)).
apply Res. trivial_in 5. unfold snd. unfold F_193. unfold F_182. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_182. unfold fst in HFabs1. unfold F_193 in HFabs1.
pattern u2, u3. simpl (time _). cbv beta.
 simpl. auto.

	(* TAUTOLOGY on [ 193 ] *)

unfold fst. unfold F_193.
auto.

	(* REWRITING on [ 185 ] *)

rename u1 into _u6. rename u2 into _u2. rename u3 into _u3. rename u4 into _u8. rename u5 into _u9.
rename _u6 into u6. rename _u2 into u2. rename _u3 into u3. rename _u8 into u8. rename _u9 into u9.
assert (Res := Hind F_197). clear Hind.
assert (HFabs1 : fst (F_197 Nil u2 u3 u8 0)).
apply Res. trivial_in 9. unfold snd. unfold F_197. unfold F_185. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_185. unfold fst in HFabs1. unfold F_197 in HFabs1.
pattern (C u2 u3), (Cons (C u8 u9) u6). simpl (timel _). cbv beta.
 simpl. auto.

	(* REWRITING on [ 190 ] *)

rename u1 into _u6. rename u2 into _u2. rename u3 into _u3. rename u4 into _u8. rename u5 into d_u5.
rename _u6 into u6. rename _u2 into u2. rename _u3 into u3. rename _u8 into u8.
assert (H := Hind F_155).
assert (Res := Hind F_202). clear Hind.
assert (HFabs0 : fst (F_155 u6 u2 u3 0 0)).
apply H. trivial_in 0. unfold snd. unfold F_155. unfold F_190. rewrite_model. abstract solve_rpo_mul.
unfold fst in HFabs0. unfold F_155 in HFabs0. simpl in HFabs0.

assert (HFabs1 : fst (F_202 Nil u2 u8 0 0)).
apply Res. trivial_in 8. unfold snd. unfold F_202. unfold F_190. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_190. unfold fst in HFabs1. unfold F_202 in HFabs1.
pattern u6, u2, u3. simpl (timel _). cbv beta.
try rewrite  HFabs0.  simpl. auto.

	(* TAUTOLOGY on [ 202 ] *)

unfold fst. unfold F_202.
auto.

	(* REWRITING on [ 197 ] *)

rename u1 into d_u1. rename u2 into _u2. rename u3 into _u3. rename u4 into _u8. rename u5 into d_u5.
rename _u2 into u2. rename _u3 into u3. rename _u8 into u8.
assert (Res := Hind F_206). clear Hind.
assert (HFabs1 : fst (F_206 Nil u2 u8 0 0)).
apply Res. trivial_in 10. unfold snd. unfold F_206. unfold F_197. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_197. unfold fst in HFabs1. unfold F_206 in HFabs1.
pattern u2, u3. simpl (time _). cbv beta.
 simpl. auto.

	(* TAUTOLOGY on [ 206 ] *)

unfold fst. unfold F_206.
auto.

Qed.

(* the set of all formula instances from the proof *)
Definition S_155 := fun f => exists F, In F LF_155 /\ exists e1, exists e2, exists e3, exists e4, exists e5, f = F e1 e2 e3 e4 e5.

Theorem all_true_155: forall F, In F LF_155 -> forall u1: PLAN, forall u2: nat, forall u3: nat, forall u4: nat, forall u5: nat, fst (F u1 u2  u3  u4  u5).
Proof.
let n := constr:(5) in
let p := constr:(S(S(n))) in
intros;
let G := fresh "G" in
let x := fresh "x" in
apply wf_subset with (R:=@snd_rpo_mul P Prop max_size) (S:=S_155);
[(* 1 *) apply wf_snd_rpo_mul, prec_wf
|(* 2 *) idtac
|(* 3 *) eexists; split; [ eassumption | idtac]; do_nat n ltac:(eexists); reflexivity
];

intros x G;
do_nat p ltac:(elim G; intro; clear G; intro G);
rewrite G in * |- *; clear G; clear x;
intro G;
apply main_155;
 [assumption | idtac];
intros;
apply G;
 [ idtac | assumption ];
eexists; split;
 [idtac | do_nat n ltac:(eexists); reflexivity];
assumption.
Qed.

Theorem true_155: forall (u1: PLAN) (u2: nat) (u3: nat), (timel (insAt u1 u2 u3)) = u2.
Proof.
do 3 intro.
apply (all_true_155 F_155);
 (trivial_in 0) ||
 (repeat constructor).
Qed.


(** ** lB0-systems

By Vladimir Voevodsky, split off lB0systems.v on March 3, 2015 *)

Unset Automatic Introduction.

Require Export lB0_non_unital.

(** ** lB0-systems (unital) *)

(** *** The kain layers *)

(** **** The layer associated with operations dlt *)

Definition dlt_layer { BB : lBsystem_carrier } ( T : T_ops_type BB ) :=
  total2 ( fun dlt : dlt_layer_0 BB => dlt_ax1_type T dlt ) .

Definition dlt_layer_pr1 { BB : lBsystem_carrier }
           ( T : T_ops_type BB )
           ( dlt : dlt_layer T ) : dlt_layer_0 BB := pr1 dlt .
Coercion dlt_layer_pr1 : dlt_layer >-> dlt_layer_0 .

Definition dlt_ax1 { BB : lBsystem_carrier } { T : T_ops_type BB } ( dlt : dlt_layer T ) :
  dlt_ax1_type T dlt := pr2 dlt .

(** **** Complete definition of a unital lB0-system *)

Definition lB0system :=
  total2 ( fun BB : lB0system_non_unital => dlt_layer ( @T_op BB ) ) .

Definition lB0system_pr1 : lB0system -> lB0system_non_unital := pr1 .
Coercion lB0system_pr1 : lB0system >-> lB0system_non_unital .

Definition lB0system_pr2 ( BB : lB0system ) : dlt_layer ( @T_op BB ) := pr2 BB .
Coercion lB0system_pr2 : lB0system >-> dlt_layer .

Definition lB0system_to_prelBystem ( BB : lB0system ) : prelBsystem :=
  tpair ( fun X : prelBsystem_non_unital => _ ) BB ( pr1 ( pr2 BB ) ) .
Coercion lB0system_to_prelBystem : lB0system >-> prelBsystem .

(* End of the file lB0.v *)


(* Natural Deduction for First-Order Intuitionistic Logic *)

From Coq Require Import Wf_nat Lia.
From OLlibs Require Import List_more.
From Quantifiers Require Export foformulas.

Set Implicit Arguments.

(** * Proofs *)

Section Proofs.

Context { vatom : DecType } { tatom fatom : Type }.

Arguments tvar {_} {_} {T} _.

Notation term := (@term vatom tatom nat).
Notation closed t := (tvars t = nil).
Notation rclosed r := (forall n, closed (r n)).
Notation "↑ r" := (felift (evar 0) r) (at level 25, format "↑ r").
Notation "v ⇓" := (fesubs v) (at level 18, format "v ⇓").
Notation "A ⟦ r ⟧" := (esubs r A) (at level 8, left associativity, format "A ⟦ r ⟧").
Notation "A [ u // x ]" := (subs x u A) (at level 8, format "A [ u // x ]").
Notation "⇑" := fup.
Notation "A ↑" := (A⟦⇑⟧) (at level 8, format "A ↑").
Notation "l ⇈" := (map (fun F => F↑) l) (at level 8, format "l ⇈").

Inductive FQcon := frl_con.
Notation frl := (fqtf frl_con).

Notation formula := (@formula vatom tatom fatom Nocon Nocon Icon FQcon nat).

Hint Rewrite (@fsize_esubs vatom tatom fatom Nocon Nocon Icon FQcon) : term_db.
Hint Rewrite (@fsize_subs vatom tatom fatom Nocon Nocon Icon FQcon nat) : term_db.
Hint Rewrite (@tvars_tesubs_closed vatom tatom) using intuition; fail : term_db.
Hint Rewrite (@subs_esubs vatom tatom fatom Nocon Nocon Icon FQcon nat)
                         using intuition; fail : term_db.
Hint Rewrite (@felift_esubs vatom tatom fatom Nocon Nocon Icon FQcon) : term_db.
Hint Rewrite (@esubs_fup vatom tatom fatom Nocon Nocon Icon FQcon) : term_db.

Hint Resolve closed_felift : term_db.
Hint Resolve closed_fesubs : term_db.

(** Proofs *)
Inductive prove : list formula -> formula -> Type :=
| ax : forall l1 l2 A, prove (l1 ++ A :: l2) A
| impi l A B : prove (A :: l) B -> prove l (imp A B)
| impe l B : forall A, prove l (imp A B) -> prove l A -> prove l B
| frli x l A : prove l⇈ A↑[evar 0//x] -> prove l (frl x A)
| frle x l A : forall u, closed u -> prove l (frl x A) -> prove l (subs x u A).
Hint Constructors prove : term_db.
Global Arguments impe { l B }.

(* This [weakening] lemma is not required in the development, see rather [rweakening] below *)
(* It is given here for comparison with alternative formalizations of Natural Deduction *)
Lemma weakening : forall l A, prove l A -> forall l0, prove (l ++ l0) A.
Proof.
intros l A pi; induction pi; intros; subst;
  try (econstructor; rewrite_all map_app; rewrite ? app_comm_cons; intuition; fail).
rewrite <- app_assoc, <- app_comm_cons; intuition.
Qed.
(* an alternative slightly more general statement:
Lemma weakening_middle : forall l A,
  prove l A -> forall l0 l1 l2, l = l1 ++ l2 -> prove (l1 ++ l0 ++ l2) A.
Proof.
intros l A pi; induction pi; intros; subst;
  try (econstructor; rewrite_all map_app; rewrite ? app_comm_cons; intuition; fail).
destruct (elt_eq_app _ _ _ _ _ H) as [ [? [? ?]] | [? [? ?]] ]; subst;
  rewrite ? (app_assoc _ _ (A::_)), <- ? (app_assoc _ (A::_)), <- ? app_comm_cons;
  intuition.
Qed.
*)

(** Normal Forms *)
Inductive nprove : list formula -> formula -> Type := (* neutral terms *)
| nax : forall l1 l2 A, nprove (l1 ++ A :: l2) A
| nimpe l B : forall A, nprove l (imp A B) -> rprove l A -> nprove l B
| nfrle x l A : forall u, closed u -> nprove l (frl x A) -> nprove l (subs x u A)
with rprove : list formula -> formula -> Type := (* normal forms *)
| rninj l A : nprove l A -> rprove l A
| rimpi l A B : rprove (A :: l) B -> rprove l (imp A B)
| rfrli x l A : rprove l⇈ A↑[evar 0//x] -> rprove l (frl x A).
Hint Constructors nprove rprove : term_db.
Global Arguments rfrli { x l A }.
Global Arguments nimpe { l B }.

Scheme nrprove_rect := Induction for nprove Sort Type
  with rnprove_rect := Induction for rprove Sort Type.
Combined Scheme rnprove_mutrect from nrprove_rect, rnprove_rect.

Fixpoint nsize {l A} (pi : nprove l A) : nat :=
match pi with
| nax _ _ _  => 1
| nimpe _ pi1 pi2 => S (nsize pi1 + rsize pi2)
| nfrle _ _ pi0 => S (nsize pi0)
end
with rsize {l A} (pi : rprove l A) : nat :=
match pi with
| rninj pi0 => S (nsize pi0)
| rimpi pi0 => S (rsize pi0)
| rfrli pi0 => S (rsize pi0)
end.

Theorem denormalization :
   (forall l A, nprove l A -> prove l A)
 * (forall l A, rprove l A -> prove l A).
Proof. now apply rnprove_mutrect; intros; try (econstructor; eassumption). Qed.

(** * Normalization *)

(** apply [r] on normal form *)
Theorem rnpesubs r (Hc : rclosed r) {l A} :
   (nprove l A -> nprove (map (esubs r) l) A⟦r⟧)
 * (rprove l A -> rprove (map (esubs r) l) A⟦r⟧).
Proof.
revert l A.
enough ((forall l A, nprove l A -> forall r, rclosed r -> nprove (map (esubs r) l) A⟦r⟧)
      * (forall l A, rprove l A -> forall r, rclosed r -> rprove (map (esubs r) l) A⟦r⟧))
  as He by (split; intros; apply He; assumption).
clear r Hc; apply rnprove_mutrect; intros; (try simpl in X);
  (try assert (IH1 := X r H)); (try assert (IH2 := X0 r H));
  (try (econstructor; (eassumption + intuition); fail)).
- rewrite map_app. apply nax.
- rcauto. rnow apply nfrle.
- specialize X with (↑r0).
  revert X. rcauto.
  rewrite map_map, (map_ext _ _ (felift_esubs (evar 0) _)), <- map_map in X. intuition.
Qed.

Lemma rpsubsz {l A x u} : closed u -> rprove l⇈ A↑[evar 0//x] -> rprove l (subs x u A).
Proof.
intros Hc pi.
apply (rnpesubs (u⇓)) in pi; [ | intuition ].
rnow simpl in pi then simpl in pi.
now rewrite map_map, (map_ext _ _ (esubs_fup _)), map_id in pi.
Qed.

Lemma rweakening :
   (forall l A, nprove l A -> forall l0 l1 l2, l = l1 ++ l2 -> nprove (l1 ++ l0 ++ l2) A)
 * (forall l A, rprove l A -> forall l0 l1 l2, l = l1 ++ l2 -> rprove (l1 ++ l0 ++ l2) A).
Proof.
apply rnprove_mutrect; intros; subst;
  try (econstructor; rewrite_all map_app; rewrite ? app_comm_cons; intuition; fail).
destruct (dichot_elt_app_inf _ _ _ _ _ H) as [ [? [? ?]] | [? [? ?]] ]; subst;
  rewrite ? (app_assoc _ _ (A::_)), <- ? (app_assoc _ (A::_)), <- ? app_comm_cons;
  intuition.
Qed.

Lemma substitution : forall l A B, rprove l A -> rprove (A :: l) B -> rprove l B.
Proof.
pose (IH := (fun n m =>
 forall A, fsize A = n ->
   (forall B l1 l2 (pi : nprove (l1 ++ A :: l2) B),
      nsize pi < m -> fsize A < fsize B -> rprove (l1 ++ l2) A -> nprove (l1 ++ l2) B)
 * (forall B l1 l2 (pi : nprove (l1 ++ A :: l2) B),
      nsize pi < m -> rprove (l1 ++ l2) A -> rprove (l1 ++ l2) B)
 * (forall B l1 l2 (pi : rprove (l1 ++ A :: l2) B),
      rsize pi < m -> rprove (l1 ++ l2) A -> rprove (l1 ++ l2) B))).
enough (forall n m, IH n m) as Hsub.
{ intros l A B pi1 pi2.
  rewrite <- (app_nil_l (A :: l)) in pi2; rewrite <- (app_nil_l l).
  refine (snd (Hsub _ (S (rsize pi2)) _ _) _ _ _ _ _ _); intuition. }
apply lt_wf_double_rect; unfold IH; clear IH; simpl;
 intros n m IHn IHm A HA; (split; [ split | ] ); subst;
 intros B l1 l2 pi2 Hpi; [ intros HF | | ]; intros pi1;
 remember (l1 ++ A :: l2) as ll; destruct pi2; subst; simpl in Hpi.
(* first statement *)
- destruct (dichot_elt_app_inf _ _ _ _ _ Heqll)
    as [ (l' & Heq0 & Heq) | (l' & Heq0 & Heq) ]; subst.
  + rewrite <- app_assoc; apply nax.
  + destruct l'; inversion Heq; subst.
    * exfalso; lia.
    * rewrite app_assoc; apply nax.
- assert (nsize pi2 < S (nsize pi2 + rsize r)) as IH1 by lia.
  assert (rsize r < S (nsize pi2 + rsize r)) as IH2 by lia.
  eapply nimpe; eapply (IHm (S (nsize pi2 + rsize r))); simpl; eauto; lia.
- apply nfrle; auto.
  rnow eapply (IHm _ Hpi).
(* second statement *)
- enough (forall l l1 l2, l0 ++ A0 :: l3 = l1 ++ A :: l2 ->
      rprove (l ++ l1 ++ l2) A -> rprove (l ++ l1 ++ l2) A0)
    as HI by (eapply (HI nil); eassumption) ; clear.
  induction l0; intros l l1 l2 Heq pi; destruct l1; inversion Heq; subst; auto.
  + rewrite <- app_comm_cons; apply rninj, nax.
  + rewrite 2 app_assoc; apply rninj, nax.
  + rewrite <- app_comm_cons, <- (app_nil_l l1), <- app_assoc, app_comm_cons, app_assoc.
    apply IHl0; auto.
    now rewrite <- ? app_assoc, <- app_comm_cons.
- assert (nsize pi2 < S (nsize pi2 + rsize r)) as IH1 by lia.
  assert (rsize r < S (nsize pi2 + rsize r)) as IH2 by lia.
  eapply IHm in IH2; eauto.
  assert ({fsize (imp A0 B) <= fsize A} + {fsize A < fsize (imp A0 B)}) as [ Ho | Ho ]
    by (case (CompareSpec2Type (Nat.compare_spec (fsize (imp A0 B)) (fsize A))); intros Ho;
          [ left | left | right ]; lia); simpl in Ho.
  + eapply IHm in IH1; eauto.
    inversion_clear IH1 as [ l' A' pi1' | l' A' B' pi1' | ].
    * apply rninj; eapply nimpe; eauto.
    * rewrite <- (app_nil_l _) in pi1'.
      refine (snd (IHn (fsize A0) (S (rsize pi1')) _ _ _) _ _ _ pi1' _ IH2); lia.
  + apply rninj, (nimpe A0); auto.
    eapply IHm; eauto; lia.
- assert (nsize pi2 < S (nsize pi2)) as IH1 by lia.
  apply IHm in IH1; auto.
  inversion_clear IH1.
  + now apply rninj, nfrle.
  + now apply rpsubsz.
(* third statement *)
- refine (snd (fst (IHm _ _ _ _)) _ _ _ n _ _); auto; lia.
- revert pi2 Hpi; rewrite app_comm_cons; intros pi2 Hpi.
  apply rimpi.
  refine (snd (IHm _ _ _ _) _ _ _ pi2 _ _); auto; try lia.
  rewrite <- app_comm_cons, <- (app_nil_l (l1 ++ l2)), app_comm_cons, <- (app_nil_l _).
  eapply rweakening; eauto.
- apply rfrli; rewrite map_app.
  apply (rnpesubs ⇑) in pi1; intuition.
  revert pi1 pi2 Hpi; rewrite ? map_app; simpl; intros pi1 pi2 Hpi.
  rnow (refine (snd (IHm _ _ _ _) _ _ _ pi2 _ _); auto).
Qed.

Theorem normalization : forall l A, prove l A -> rprove l A.
Proof.
intros l A pi; induction pi; try (econstructor; (idtac + econstructor); eassumption).
- inversion_clear IHpi1.
  + apply rninj; eapply nimpe; eassumption.
  + eapply substitution; eassumption.
- inversion_clear IHpi.
  + apply rninj; now eapply nfrle.
  + now apply rpsubsz.
Qed.

End Proofs.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Definition synth (lf1 : lst) (y : lst) : lst := append Nil y.


Require Export ProjectiveGeometry.Dev.projective_plane_axioms.

(**  PG(2,5). **)

(** To show that our axiom system is consistent we build a finite model. **)

Section s_fanoPlaneModelPG25Generated.

(** We can not use directly the inductive type for a technical reason related to Coq's implementation. **)

Inductive ind_Point : Set := p0 | p1 | p2 | p3 | p4 | p5 | p6 | p7 | p8 | p9 | p10 | p11 | p12 | p13 | p14 | p15 | p16 | p17 | p18 | p19 | p20 | p21 | p22 | p23 | p24 | p25 | p26 | p27 | p28 | p29 | p30.

Inductive ind_line : Set := l0 | l1 | l2 | l3 | l4 | l5 | l6 | l7 | l8 | l9 | l10 | l11 | l12 | l13 | l14 | l15 | l16 | l17 | l18 | l19 | l20 | l21 | l22 | l23 | l24 | l25 | l26 | l27 | l28 | l29 | l30.

Definition Point : Set := ind_Point.
Definition Line : Set := ind_line.

Definition Incid_bool : Point -> Line -> bool := fun P l =>
 match P with
| p0 =>
	match l with
	| l12| l18| l22| l27| l29| l30=> true
	| _ => false
	end
| p1 =>
	match l with
	| l0| l13| l19| l23| l28| l30=> true
	| _ => false
	end
| p2 =>
	match l with
	| l0| l1| l14| l20| l24| l29=> true
	| _ => false
	end
| p3 =>
	match l with
	| l1| l2| l15| l21| l25| l30=> true
	| _ => false
	end
| p4 =>
	match l with
	| l0| l2| l3| l16| l22| l26=> true
	| _ => false
	end
| p5 =>
	match l with
	| l1| l3| l4| l17| l23| l27=> true
	| _ => false
	end
| p6 =>
	match l with
	| l2| l4| l5| l18| l24| l28=> true
	| _ => false
	end
| p7 =>
	match l with
	| l3| l5| l6| l19| l25| l29=> true
	| _ => false
	end
| p8 =>
	match l with
	| l4| l6| l7| l20| l26| l30=> true
	| _ => false
	end
| p9 =>
	match l with
	| l0| l5| l7| l8| l21| l27=> true
	| _ => false
	end
| p10 =>
	match l with
	| l1| l6| l8| l9| l22| l28=> true
	| _ => false
	end
| p11 =>
	match l with
	| l2| l7| l9| l10| l23| l29=> true
	| _ => false
	end
| p12 =>
	match l with
	| l3| l8| l10| l11| l24| l30=> true
	| _ => false
	end
| p13 =>
	match l with
	| l0| l4| l9| l11| l12| l25=> true
	| _ => false
	end
| p14 =>
	match l with
	| l1| l5| l10| l12| l13| l26=> true
	| _ => false
	end
| p15 =>
	match l with
	| l2| l6| l11| l13| l14| l27=> true
	| _ => false
	end
| p16 =>
	match l with
	| l3| l7| l12| l14| l15| l28=> true
	| _ => false
	end
| p17 =>
	match l with
	| l4| l8| l13| l15| l16| l29=> true
	| _ => false
	end
| p18 =>
	match l with
	| l5| l9| l14| l16| l17| l30=> true
	| _ => false
	end
| p19 =>
	match l with
	| l0| l6| l10| l15| l17| l18=> true
	| _ => false
	end
| p20 =>
	match l with
	| l1| l7| l11| l16| l18| l19=> true
	| _ => false
	end
| p21 =>
	match l with
	| l2| l8| l12| l17| l19| l20=> true
	| _ => false
	end
| p22 =>
	match l with
	| l3| l9| l13| l18| l20| l21=> true
	| _ => false
	end
| p23 =>
	match l with
	| l4| l10| l14| l19| l21| l22=> true
	| _ => false
	end
| p24 =>
	match l with
	| l5| l11| l15| l20| l22| l23=> true
	| _ => false
	end
| p25 =>
	match l with
	| l6| l12| l16| l21| l23| l24=> true
	| _ => false
	end
| p26 =>
	match l with
	| l7| l13| l17| l22| l24| l25=> true
	| _ => false
	end
| p27 =>
	match l with
	| l8| l14| l18| l23| l25| l26=> true
	| _ => false
	end
| p28 =>
	match l with
	| l9| l15| l19| l24| l26| l27=> true
	| _ => false
	end
| p29 =>
	match l with
	| l10| l16| l20| l25| l27| l28=> true
	| _ => false
	end
| p30 =>
	match l with
	| l11| l17| l21| l26| l28| l29=> true
	| _ => false
	end
end.

Definition Incid : Point -> Line -> Prop := fun P L => (Incid_bool P L = true).

Hint Unfold Incid Incid_bool.

Lemma incid_dec : forall (A:Point) (l:Line), {Incid A l} + {~Incid A l}.
Proof.
intros.
unfold Incid.
elim l;elim A;unfold Incid_bool;simpl;auto;right;discriminate.
Qed.

Ltac solve_ex L := solve [exists L;auto].

(** A tactic which tries all possible lines **)
Ltac solve_ex_l := first [
        solve_ex l0
     |  solve_ex l1
     |  solve_ex l2
     |  solve_ex l3
     |  solve_ex l4
     |  solve_ex l5
     |  solve_ex l6
     |  solve_ex l7
     |  solve_ex l8
     |  solve_ex l9
     |  solve_ex l10
     |  solve_ex l11
     |  solve_ex l12
     |  solve_ex l13
     |  solve_ex l14
     |  solve_ex l15
     |  solve_ex l16
     |  solve_ex l17
     |  solve_ex l18
     |  solve_ex l19
     |  solve_ex l20
     |  solve_ex l21
     |  solve_ex l22
     |  solve_ex l23
     |  solve_ex l24
     |  solve_ex l25
     |  solve_ex l26
     |  solve_ex l27
     |  solve_ex l28
     |  solve_ex l29
     |  solve_ex l30
 ].

(** A tactic which tries all possible points **)
Ltac solve_ex_p := first [
        solve_ex p0
     |  solve_ex p1
     |  solve_ex p2
     |  solve_ex p3
     |  solve_ex p4
     |  solve_ex p5
     |  solve_ex p6
     |  solve_ex p7
     |  solve_ex p8
     |  solve_ex p9
     |  solve_ex p10
     |  solve_ex p11
     |  solve_ex p12
     |  solve_ex p13
     |  solve_ex p14
     |  solve_ex p15
     |  solve_ex p16
     |  solve_ex p17
     |  solve_ex p18
     |  solve_ex p19
     |  solve_ex p20
     |  solve_ex p21
     |  solve_ex p22
     |  solve_ex p23
     |  solve_ex p24
     |  solve_ex p25
     |  solve_ex p26
     |  solve_ex p27
     |  solve_ex p28
     |  solve_ex p29
     |  solve_ex p30
 ].

(** A1 : any two points lie on a unique line **)
Lemma a1_exist : forall ( A B :Point) ,{l:Line | Incid A l /\ Incid B l}.
Proof with auto.
intros.
elim A;elim B;solve_ex_l.
Qed.

Lemma degen_point: forall A:Point, forall P: Prop, ~A=A -> P.
Proof.
intuition.
Qed.

Lemma degen_line: forall A:Line, forall P: Prop, A<>A -> P.
Proof.
intuition.
Qed.

Ltac remove_degen := match goal with
| H: ~ ?A=?A |- ?G => apply (degen_point A G H)
| H: ?A<>?A |- ?G => apply (degen_line A G H)
end.

Lemma uniqueness : forall A B :Point, forall l m : Line,
 Incid A l -> Incid B l  -> Incid A m -> Incid B m -> A=B\/l=m.
Proof.
intros P Q l m H1 H2 H3 H4.
 induction P; induction Q; try (left;reflexivity);
 induction l; try discriminate;
 induction m; try discriminate;try (left; reflexivity);try (right; reflexivity).
Qed.

Lemma a1_unique:forall (A B :Point)(l1 l2:Line),
  ~A=B -> Incid A l1 -> Incid B l1 -> Incid A l2 -> Incid B l2 -> l1=l2.
Proof.
intros X Y l1 l2 HXY H1 H2 H3 H4.
induction X;induction Y; try remove_degen;
induction l1;try discriminate; induction l2; discriminate || reflexivity.
Qed.

Lemma a2_unique : forall(l1 l2 :Line)(A B :Point),
  ~l1=l2 -> Incid A l1 -> Incid A l2 -> Incid B l1 -> Incid B l2 -> A=B.
Proof.
intros l1 l2 X Y H H1 H2 H3 H4.
 induction X;induction Y;try reflexivity;
 induction l1;try discriminate;
 induction l2;try discriminate;try remove_degen.
Qed.

(** A2 : any two lines meet in a unique point **)
Lemma a2_exist : forall (l1 l2:Line), {A:Point | Incid A l1 /\ Incid A l2}.
Proof.
intros l1 l2.
induction l1;induction l2;solve_ex_p.
Qed.

(** A3 : there exist four points with no three collinear **)
Lemma a3 : {A:Point & {B :Point & {C:Point & {D :Point |
  (forall l :Line, ~A = B /\ ~A = C /\ ~A = D /\ ~B = C /\ ~B = D /\ ~C = D /\
    (Incid A l /\ Incid B l -> ~Incid C l /\ ~Incid D l)
    /\ (Incid A l /\ Incid C l -> ~Incid B l /\ ~Incid D l)
    /\  (Incid A l /\ Incid D l -> ~Incid C l /\ ~Incid B l)
    /\  (Incid C l /\ Incid B l -> ~Incid A l /\ ~Incid D l)
    /\ (Incid D l /\ Incid B l -> ~Incid C l /\ ~Incid A l)
    /\  (Incid C l /\ Incid D l -> ~Incid B l /\ ~Incid A l))}}}}.
Proof.
exists p1.
exists p2.
exists p6.
exists p11.
intros.
elim l;unfold Incid, Incid_bool;intuition;try discriminate.
Qed.

Instance ObjectPointFano : ObjectPoint := {
Point := Point
}.

Instance ProjectiveStructureFano : ProjectiveStructure ObjectPointFano := {
Line := Line;
Incid := Incid;
incid_dec := incid_dec
}.

Instance ProjectiveStructureLEFano : ProjectiveStructureLE ProjectiveStructureFano := {
a1_exist := a1_exist
}.

Instance ProjectiveStructureLEUFano : ProjectiveStructureLEU ProjectiveStructureLEFano := {
uniqueness := uniqueness
}.

Instance PreProjectivePlaneFano : PreProjectivePlane ProjectiveStructureLEUFano := {
a2_exist := a2_exist
}.

Instance ProjectivePlaneFano : ProjectivePlane PreProjectivePlaneFano := {
a3 := a3
}.

End s_fanoPlaneModelPG25Generated.


From discprob.basic Require Import base sval order monad bigop_ext nify.
From mathcomp Require Import ssrfun ssreflect eqtype ssrbool seq fintype choice.
Require Import Reals Psatz.
From discprob.monad.idxval Require Import fin_ival fin_ival_dist.

Record ival_couplingP {A1 A2} (Is1: ival A1) (Is2: ival A2) (P: A1 → A2 → Prop) : Type :=
  mkICoupling { ic_witness :> ival {xy: A1 * A2 | P (fst xy) (snd xy)};
     ic_proj1: eq_ival Is1 (x ← ic_witness; mret (fst (sval x)));
     ic_proj2: eq_ival Is2 (x ← ic_witness; mret (snd (sval x)));
     }.

Record idist_couplingP {A1 A2} (Is1: ivdist A1) (Is2: ivdist A2) (P: A1 → A2 → Prop) : Type :=
  mkIdCoupling { idc_witness :> ivdist {xy: A1 * A2 | P (fst xy) (snd xy)};
     idc_proj1: eq_ivd Is1 (x ← idc_witness; mret (fst (sval x)));
     idc_proj2: eq_ivd Is2 (x ← idc_witness; mret (snd (sval x)));
     }.
From mathcomp Require Import bigop.

Lemma ic_coupling_to_id {A1 A2} (I1: ivdist A1) (I2: ivdist A2) P:
  ival_couplingP I1 I2 P →
  idist_couplingP I1 I2 P.
Proof.
  intros [Ic Hproj1 Hproj2].
  assert (Hsum1: \big[Rplus/0%R]_i fin_ival.val Ic i = 1%R).
  {
    replace 1%R with R1 by auto.
    rewrite -(val_sum1 I1).
    eapply (eq_ival_sum _ _ (λ x, true)) in Hproj1. rewrite Hproj1.
    unshelve (eapply sum_reidx_surj1).
    - intros ic. exact (existT ic tt).
    - rewrite //= => *. by rewrite Rmult_1_r.
    - rewrite //= => *; split; auto.
      rewrite /index_enum -enumT. apply mem_enum.
    - intros (b&[]) _ _.
      exists b. repeat split; auto.
    - by rewrite /index_enum -enumT enum_uniq.
    - by rewrite /index_enum -enumT enum_uniq.
    - intros ??. inversion 1; auto.
  }
  exists {| ivd_ival := Ic; val_sum1 := Hsum1 |}; auto.
Qed.

Local Open Scope R_scope.
Record ival_coupling_nondepP {A1 A2} (Is1: ival A1) (Is2: ival A2) (P: A1 → A2 → Prop) : Type :=
  mkNonDepICoupling { ic_nondep_witness :> ival (A1 * A2);
               ic_nondep_support :
                 ∀ xy, (∃ i, ind ic_nondep_witness i = xy
                            ∧ val ic_nondep_witness i > 0) → P (fst xy) (snd xy);
     ic_nondep_proj1: eq_ival Is1 (x ← ic_nondep_witness; mret (fst x));
     ic_nondep_proj2: eq_ival Is2 (x ← ic_nondep_witness; mret (snd x));
     }.

Lemma ival_coupling_nondep_suffice {A1 A2} Is1 Is2 (P: A1 → A2 → Prop):
      ival_coupling_nondepP Is1 Is2 P →
      ival_couplingP Is1 Is2 P.
Proof.
  intros [Ic Isupp Hp1 Hp2].
  exists (ival_equip Ic _ Isupp).
  - setoid_rewrite Hp1.
    setoid_rewrite (ival_bind_P Ic).
    eapply ival_bind_congr; first reflexivity.
    intros (a1&a2) => //=; reflexivity.
  - setoid_rewrite Hp2.
    setoid_rewrite (ival_bind_P Ic).
    eapply ival_bind_congr; first reflexivity.
    intros (a1&a2) => //=; reflexivity.
Qed.

Lemma ival_coupling_refl {A} (I: ival A) : ival_couplingP I I (λ x y, x = y).
Proof.
  unshelve (eexists).
  { refine (x ← I; mret (exist _ (x, x) _)).
    done. }
  - setoid_rewrite ival_bind_mret_mret. setoid_rewrite ival_right_id. reflexivity.
  - setoid_rewrite ival_bind_mret_mret. setoid_rewrite ival_right_id. reflexivity.
Qed.

Lemma ival_coupling_sym {A1 A2} (Is1: ival A1) (Is2: ival A2) P
      (Ic: ival_couplingP Is1 Is2 P): ival_couplingP Is2 Is1 (λ x y, P y x).
Proof.
  destruct Ic as [Ic Hp1 Hp2].
  unshelve (eexists).
  { refine (mbind _ Ic). intros ((x&y)&HP).
    refine (mret (exist _ (y, x) _)); auto. }
  * setoid_rewrite Hp2. setoid_rewrite ival_assoc. apply ival_bind_congr; first by reflexivity.
    intros ((x&y)&Hpf). setoid_rewrite ival_left_id => //=. reflexivity.
  * setoid_rewrite Hp1. setoid_rewrite ival_assoc; apply ival_bind_congr; first by reflexivity.
    intros ((x&y)&Hpf). setoid_rewrite ival_left_id => //=. reflexivity.
Qed.

Lemma ival_coupling_eq {A} (Is1 Is2: ival A)
      (Ic: ival_couplingP Is1 Is2 (λ x y, x = y)): eq_ival Is1 Is2.
Proof.
  destruct Ic as [Ic Hp1 Hp2].
  setoid_rewrite Hp1. setoid_rewrite Hp2.
  apply ival_bind_congr; first by reflexivity.
  intros ((x&y)&Heq) => //=. rewrite //= in Heq; subst; reflexivity.
Qed.

Lemma ival_coupling_bind {A1 A2 B1 B2} (f1: A1 → ival B1) (f2: A2 → ival B2)
      Is1 Is2 P Q (Ic: ival_couplingP Is1 Is2 P):
  (∀ x y, P x y → ival_couplingP (f1 x) (f2 y) Q) →
  ival_couplingP (mbind f1 Is1) (mbind f2 Is2) Q.
Proof.
  intros Hfc.
  destruct Ic as [Ic Hp1 Hp2].
  unshelve (eexists).
  { refine (xy ← Ic; _). destruct xy as ((x&y)&HP).
    exact (Hfc _ _ HP).
  }
  - setoid_rewrite Hp1; setoid_rewrite ival_assoc;
      apply ival_bind_congr; first by reflexivity.
    intros ((x&y)&HP). setoid_rewrite ival_left_id => //=.
    destruct (Hfc x y); auto.
  - setoid_rewrite Hp2; setoid_rewrite ival_assoc;
      apply ival_bind_congr; first by reflexivity.
    intros ((x&y)&HP). setoid_rewrite ival_left_id => //=.
    destruct (Hfc x y); auto.
Qed.

Lemma ival_coupling_mret {A1 A2} x y (P: A1 → A2 → Prop):
  P x y →
  ival_couplingP (mret x) (mret y) P.
Proof.
  intros HP. exists (mret (exist _ (x, y) HP)); setoid_rewrite ival_left_id => //=; reflexivity.
Qed.

Lemma ival_coupling_conseq {A1 A2} (P1 P2: A1 → A2 → Prop) (I1: ival A1) (I2: ival A2):
  (∀ x y, P1 x y → P2 x y) →
  ival_couplingP I1 I2 P1 →
  ival_couplingP I1 I2 P2.
Proof.
  intros HP [Ic Hp1 Hp2].
  unshelve (eexists).
  { refine (x ← Ic; mret _).
    destruct x as (x&P).
    exists x. auto. }
  - setoid_rewrite Hp1.
    setoid_rewrite ival_assoc.
    eapply ival_bind_congr; first reflexivity; intros (?&?).
    setoid_rewrite ival_left_id; reflexivity.
  - setoid_rewrite Hp2.
    setoid_rewrite ival_assoc.
    eapply ival_bind_congr; first reflexivity; intros (?&?).
    setoid_rewrite ival_left_id; reflexivity.
Qed.

Lemma ival_coupling_plus' {A1 A2} p
      (P : A1 → A2 → Prop) (I1 I1': ival A1) (I2 I2': ival A2) :
  ival_couplingP I1 I2 P →
  ival_couplingP I1' I2' P →
  ival_couplingP (iplus (iscale p I1) (iscale (1 - p) I1'))
    (iplus (iscale p I2) (iscale (1 - p) I2')) P.
Proof.
  intros [Ic Hp1 Hp2] [Ic' Hp1' Hp2'].
  exists (fin_ival.iplus (fin_ival.iscale p Ic) (fin_ival.iscale (1 - p) Ic')).
  - setoid_rewrite fin_ival.ival_plus_bind.
    setoid_rewrite fin_ival.ival_scale_bind.
    setoid_rewrite Hp1.
    setoid_rewrite Hp1'.
    reflexivity.
  - setoid_rewrite fin_ival.ival_plus_bind.
    setoid_rewrite fin_ival.ival_scale_bind.
    setoid_rewrite Hp2.
    setoid_rewrite Hp2'.
    reflexivity.
Qed.

Lemma ival_coupling_plus {A1 A2} p Hpf Hpf'
      (P : A1 → A2 → Prop) (I1 I1': ivdist A1) (I2 I2': ivdist A2) :
  ival_couplingP I1 I2 P →
  ival_couplingP I1' I2' P →
  ival_couplingP (ivdplus p Hpf I1 I1') (ivdplus p Hpf' I2 I2') P.
Proof.
  rewrite //=. apply ival_coupling_plus'.
Qed.

Lemma ival_coupling_idxOf {A1 A2} I1 I2 (P: A1 → A2 → Prop):
  ival_couplingP I1 I2 P →
  { Q :  {Q: idx I1 → idx I2 → Prop | (∀ i1 i1' i2, Q i1 i2 → Q i1' i2 → i1 = i1')} &
  ival_couplingP (idxOf I1) (idxOf I2) (λ i1 i2, P (ind I1 i1) (ind I2 i2) ∧
                                                 val I1 i1 > 0 ∧ val I2 i2 > 0 ∧
                                                 (sval Q) i1 i2  )}.
Proof.
  intros [Ic Hp1 Hp2].
  symmetry in Hp1. symmetry in Hp2.
  apply ClassicalEpsilon.constructive_indefinite_description in Hp1.
  destruct Hp1 as (h1&Hp1).
  apply ClassicalEpsilon.constructive_indefinite_description in Hp1.
  destruct Hp1 as (h1'&Hp1).
  apply ClassicalEpsilon.constructive_indefinite_description in Hp2.
  destruct Hp2 as (h2&Hp2).
  apply ClassicalEpsilon.constructive_indefinite_description in Hp2.
  destruct Hp2 as (h2'&Hp2).
  assert (Hgt_coerce: ∀ xy : countable.support (val Ic),
             Rgt_dec (val Ic (projT1 (@existT _ (λ _, unit) (sval xy) tt)) * 1) 0).
  { abstract (intros (?&?); rewrite Rmult_1_r => //=; destruct Rgt_dec; auto). }
  unshelve (eexists).
  exists (λ i1 i2, ∃ ic1 ic2, sval (h1 ic1) = i1 ∧ sval (h2 ic2) = i2 ∧ sval ic1 = sval ic2).
  {
    abstract (intros i1 i1' i2 (ic1&ic2&Heq1&Heq2&Hcoh) (ic1'&ic2'&Heq1'&Heq2'&Hcoh');
    assert (ic2' = ic2);
    first ( abstract (destruct Hp2 as (Hbij2&?);
      rewrite -(Hbij2 ic2');
      rewrite -(Hbij2 ic2);
      f_equal; apply sval_inj_pred; congruence));
    abstract (subst; do 2 f_equal; apply sval_inj_pred; auto; congruence)). }
  unshelve (eexists).
  - refine (xy ← supp_idxOf Ic; mret _).
    unshelve (refine (exist _ ((sval (h1 _)), sval (h2 _)) _)).
      * exact (exist _ (existT (sval xy) tt) (Hgt_coerce xy)).
      * exact (exist _ (existT (sval xy) tt) (Hgt_coerce xy)).
      *
        abstract(
        split; [ by
        (abstract  (rewrite //=;
                   destruct Hp1 as (?&?&->&?) => //=;
                   destruct Hp2 as (?&?&->&?) => //=;
                   destruct (ind Ic (sval xy)) => //=)) |];
        split; [ by
        (abstract (rewrite //=; try destruct (h1 _); try destruct (h2 _); rewrite //=;
                   destruct Rgt_dec => //=)) |];
        split; [ by
        (abstract (rewrite //=; try destruct (h1 _); try destruct (h2 _); rewrite //=;
                   destruct Rgt_dec => //=)) |];
        abstract (
        rewrite //=;
        exists ((exist _ (existT (sval xy) tt) (Hgt_coerce xy)));
        exists ((exist _ (existT (sval xy) tt) (Hgt_coerce xy))); done)
        ).
  - setoid_rewrite ival_bind_mret_mret.
    symmetry.
    unshelve (eexists).
    {
      simpl. intros ((ic&?)&Hgt).
      simpl in h1.
      rewrite Rmult_1_r in Hgt.
      destruct ic as (ic&Hgtc).
      apply h1.
      exists (existT ic tt).
      simpl in *. rewrite Rmult_1_r. done.
    }
    unshelve (eexists).
    { simpl. intros ix.
      destruct (h1' ix) as ((i1&?)&Hgt).
      simpl in Hgt.
      unshelve (eexists).
      { unshelve (refine (existT _ tt)).
        exists i1. rewrite Rmult_1_r in Hgt. done.
      }
      rewrite //=.
    }
    rewrite //=.
    repeat split.
    *  intros (((a&Hgt)&[])&?). destruct Hp1 as (Hinv1&Hinv1'&?).
      rewrite //=. destruct (Rmult_1_r _). rewrite /eq_rect_r //=.
      rewrite Hinv1 => //=.
      apply sval_inj_pred => //=.
      f_equal.
      apply sval_inj_pred => //=.
    * rewrite //= => a. destruct Hp1 as (Hinv1&Hinv1'&?).
      specialize (Hinv1' a).
      destruct (h1' a) as ((?&[])&?).
      rewrite //=.
      rewrite -Hinv1'. destruct (Rmult_1_r (val Ic x)) => //=.
    * rewrite //=. intros (((a&Hgt)&[])&?). destruct Hp1 as (Hinv1&Hinv1'&?).
      rewrite //=. destruct (Rmult_1_r _). rewrite /eq_rect_r //=.
      f_equal. f_equal.
      apply sval_inj_pred => //=.
    * rewrite //=. intros (((a&Hgt)&[])&?). destruct Hp1 as (Hinv1&Hinv1'&?&Hval).
      rewrite //=. destruct (Rmult_1_r _). rewrite /eq_rect_r //=.
      rewrite Hval //= !Rmult_1_r //.
  -  setoid_rewrite ival_bind_mret_mret.
    symmetry.
    unshelve (eexists).
    {
      simpl. intros ((ic&?)&Hgt).
      simpl in h1.
      rewrite Rmult_1_r in Hgt.
      destruct ic as (ic&Hgtc).
      apply h2.
      exists (existT ic tt).
      simpl in *. rewrite Rmult_1_r. done.
    }
    unshelve (eexists).
    { simpl. intros ix.
      destruct (h2' ix) as ((i1&?)&Hgt).
      simpl in Hgt.
      unshelve (eexists).
      { unshelve (refine (existT _ tt)).
        exists i1. rewrite Rmult_1_r in Hgt. done.
      }
      rewrite //=.
    }
    rewrite //=.
    repeat split.
    * rewrite //=. intros (((a&Hgt)&[])&?). destruct Hp2 as (Hinv1&Hinv1'&?).
      rewrite //=. destruct (Rmult_1_r _). rewrite /eq_rect_r //=.
      rewrite Hinv1 => //=.
      apply sval_inj_pred => //=.
      f_equal.
      apply sval_inj_pred => //=.
    * rewrite //= => a. destruct Hp2 as (Hinv1&Hinv1'&?).
      specialize (Hinv1' a).
      destruct (h2' a) as ((?&[])&?).
      rewrite //=.
      rewrite -Hinv1'. destruct (Rmult_1_r (val Ic x)) => //=.
    * rewrite //=. intros (((a&Hgt)&[])&?). destruct Hp1 as (Hinv1&Hinv1'&?).
      rewrite //=. destruct (Rmult_1_r _). rewrite /eq_rect_r //=.
      f_equal. f_equal.
      apply sval_inj_pred => //=.
    * rewrite //=. intros (((a&Hgt)&[])&?). destruct Hp2 as (Hinv1&Hinv1'&?&Hval).
      rewrite //=. destruct (Rmult_1_r _). rewrite /eq_rect_r //=.
      rewrite Hval //= !Rmult_1_r //.
Qed.

Lemma ival_coupling_equip {X} I1 (P: X → Prop) Hpf:
  ival_couplingP I1 (ival_equip I1 P Hpf) (λ x y, x = (sval y)).
Proof.
  unshelve eexists.
  refine ((x ← ival_equip I1 P Hpf; mret (exist _ (sval x, x) _))); auto.
  - setoid_rewrite ival_bind_mret_mret.
    rewrite /sval.
    etransitivity; first (symmetry; apply ival_right_id).
    apply ival_bind_P.
  - setoid_rewrite ival_bind_mret_mret.
    rewrite /sval.
    etransitivity; first (symmetry; apply ival_right_id).
    eapply ival_bind_congr; first reflexivity.
    intros (?&?) => //=. reflexivity.
Qed.

Lemma ival_coupling_support {X Y} I1 I2 (P: X → Y → Prop)
  (Ic: ival_couplingP I1 I2 P) :
  ival_couplingP I1 I2 (λ x y, ∃ Hpf: P x y,  In_isupport x I1 ∧ In_isupport y I2 ∧
                        In_isupport (exist _ (x, y) Hpf) Ic).
Proof.
  destruct Ic as [Ic Hp1 Hp2].
  cut (ival_couplingP I1 I2 (λ x y, ∃ (Hpf: P x y), In_isupport (exist _ (x, y) Hpf) Ic)).
  { intros. eapply ival_coupling_conseq; last eauto.
    intros x y (Hpf&Hin).
    destruct Hin as (ic&Hind&Hval).
    exists Hpf.
    repeat split; auto.
      - rewrite //=. symmetry in Hp1.
        destruct Hp1 as (h1&?&?&?&Hind1&Hval1).
        unshelve (eexists).
        { refine (sval (h1 _ )).
          exists (existT ic tt). rewrite //= Rmult_1_r. destruct Rgt_dec => //=.  }
        split; rewrite //=.
        * rewrite Hind1 //= Hind //=.
        * rewrite Hval1 //= Rmult_1_r //.
      - rewrite //=. symmetry in Hp2.
        destruct Hp2 as (h1&?&?&?&Hind1&Hval1).
        unshelve eexists.
        { refine (sval (h1 _)).
          exists (existT ic tt). rewrite //= Rmult_1_r. destruct Rgt_dec => //=.  }
        split; rewrite //=.
        * rewrite Hind1 //= Hind //=.
        * rewrite Hval1 //= Rmult_1_r //.
      - rewrite //=. exists ic; split => //=.
  }
  unshelve (eexists).
  refine (z ← ival_equip Ic (λ xy, In_isupport xy Ic) _; mret _).
  { destruct z as ((xy&HP)&Hin).  exists xy. abstract (exists HP; destruct xy; eauto). }
  { auto. }
  - setoid_rewrite Hp1.
    setoid_rewrite ival_bind_mret_mret.
    eapply ival_coupling_eq.
    eapply ival_coupling_bind; first eapply ival_coupling_equip.
    intros (xy&HP) ((xy'&HP')&Hin).
    rewrite //=.
    inversion 1; subst; auto. apply ival_coupling_refl.
  - setoid_rewrite Hp2.
    setoid_rewrite ival_bind_mret_mret.
    eapply ival_coupling_eq.
    eapply ival_coupling_bind; first eapply ival_coupling_equip.
    intros (xy&HP) ((xy'&HP')&Hin).
    rewrite //=.
    inversion 1; subst; auto. apply ival_coupling_refl.
Qed.

Lemma ival_coupling_proper {X Y} I1 I1' I2 I2' (P: X → Y → Prop) :
  eq_ival I1 I1' →
  eq_ival I2 I2' →
  ival_couplingP I1 I2 P →
  ival_couplingP I1' I2' P.
Proof.
  intros Heq1 Heq2 [Ic Hp1 Hp2].
  exists Ic; etransitivity; eauto; by symmetry.
Qed.


Require Import AutoSep.
Require Import TimeAbstract.

(** Read from pointers in variables *)

Definition indirS : spec := SPEC("x") reserving 1
  Al v,
  PRE[V] V "x" =*> v
  POST[R] [| R = v |] * V "x" =*> v.

Definition indir := bmodule "indir" {{
  bfunction "indir"("x", "y") [indirS]
    "y" <-* "x";;
    Return "y"
  end
}}.

Theorem indirOk : moduleOk indir.
  vcgen; time_abstract ltac:(sep_auto).
Qed.

Definition doubleIndirS : spec := SPEC("x") reserving 1
  Al p, Al v,
  PRE[V] V "x" =*> p * p =*> v
  POST[R] [| R = v |] * V "x" =*> p * p =*> v.

Definition doubleIndir := bmodule "doubleIndir" {{
  bfunction "doubleIndir"("x", "y") [doubleIndirS]
    "y" <-* "x";;
    "y" <-* "y";;
    Return "y"
  end
}}.

Theorem doubleIndirOk : moduleOk doubleIndir.
(*TIME Clear Timing Profile. *)
(*TIME  (time "vcgen:all" *) vcgen
(*TIME ) *); time_abstract ltac:(sep_auto).
(*TIME Print Timing Profile. *)
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Export OrderedType OrderedTypeEx OrderedTypeAlt.
Require Export DecidableType DecidableTypeEx.
Require Export FMapInterface.
Require Export FMapPositive.
Require Export FMapFacts.
Require Export FMapWeakList.
Require Export FMapList.


Require Export Coq.Strings.String.
Require Export Iron.Language.DelayedSimpleUS.Tactics.Chargueraud.
Require Export Iron.Language.DelayedSimpleUS.Data.Lists.

(********************************************************************)
(* Variables want to be named. *)
Definition name := string.

(********************************************************************)
(* Bindings. *)
Inductive bind {A: Type}: Type :=
 | Bind   : name -> A -> @bind A.
Hint Constructors bind.

(* Get the name of a binding. *)
Definition nameOfBind {X}
  (b: @bind X): name :=
 match b with
 | Bind n _ => n
 end.

(* Get the expression of a binding. *)
Definition expOfBind {X}
  (b: @bind X): X :=
 match b with
 | Bind _ x => x
 end.

(* Apply a function to the expression component of a binding. *)
Definition mapExpOfBind {X}
  (f: X -> X) (b: @bind X): @bind X :=
 match b with
 | Bind n x => Bind n (f x)
 end.

(********************************************************************)
(* An environment is a list of bindings. *)
Definition env (A: Type)
 := list (@bind A).

(* Lookup expression bound to the given variable in an environment. *)
Fixpoint lookupEnv {A: Type} (var: string) (ee: env A) : option A :=
 match ee with
 |  nil
 => None

 |  Bind v x :: rest
 => match string_dec var v with
    | left  _ => Some x
    | right _ => lookupEnv var rest
    end
 end.

Lemma lookupEnv_some_app
 :  forall {A} env1 env2 n x
 ,  @lookupEnv A n (env1 ++ env2) = Some x
 -> @lookupEnv A n env1 = Some x
 \/ @lookupEnv A n env2 = Some x.
Proof.
 intros. gen x.
 induction env1; intros.
 - simpl in *. firstorder.
 - simpl in *.
   destruct a.
   remember (string_dec n n0) as b.
   destruct b.
   + firstorder.
   + firstorder.
Qed.

Lemma lookupEnv_app_infront
 :  forall A n env1 env2 x1 x2
 ,  @lookupEnv A n  env1          = Some x2
 -> @lookupEnv A n (env1 ++ env2) = Some x1
 -> x1 = x2.
Proof.
 intros A n env1 env2 x1 x2 HL1 HL2.
 induction env1.
 - simpl in *. congruence.
 - simpl in *. destruct a.
   remember (string_dec n n0) as X.
   destruct X.
   + inverts HL1. congruence.
   + firstorder.
Qed.

Lemma lookupEnv_app_inback
 :  forall A n env1 env2 x1
 ,  @lookupEnv A n  env1          = None
 -> @lookupEnv A n (env1 ++ env2) = Some x1
 -> @lookupEnv A n  env2          = Some x1.
Proof.
 intros A n env1 env2 x1 HL1 HL12.
 induction env1.
 - simpl in *. assumption.
 - simpl in *. destruct a.
   remember (string_dec n n0) as X.
   destruct X.
   + congruence.
   + firstorder.
Qed.

(********************************************************************)
Inductive EnvZip {A B} : env A -> env B -> env (A * B) -> Prop :=
 | EnvZipNil
   : EnvZip nil nil nil

 | EnvZipCons
   :  forall n a (aa : env A) b (bb : env B) ab
   ,  EnvZip aa bb ab
   -> EnvZip (Bind n a :: aa) (Bind n b :: bb) (Bind n (a, b) :: ab).
Hint Constructors EnvZip.

Lemma EnvZip_some_1of2
 :  forall {A B} e1 e2 e12 n x2
 ,  EnvZip e1 e2 e12
 -> @lookupEnv A n e2 = Some x2
 -> exists x1,
    @lookupEnv B n e1 = Some x1.
Proof.
 intros.
 induction H.
 - simpl in H0.
   congruence.
 - simpl in *.
   remember (string_dec n n0) as X.
   destruct X.
   + subst.
     inverts H0.
     exists a. trivial.
   + specializes IHEnvZip H0.
     trivial.
Qed.

Lemma EnvZip_some_2of1
 :  forall {A B} e1 e2 e12 n x1
 ,  EnvZip e1 e2 e12
 -> @lookupEnv A n e1 = Some x1
 -> exists x2,
    @lookupEnv B n e2 = Some x2.
Proof.
 intros.
 induction H.
 - simpl in H0.
   congruence.
 - simpl in *.
   remember (string_dec n n0) as X.
   destruct X.
   + subst.
     inverts H0.
     exists b. trivial.
   + specializes IHEnvZip H0.
     trivial.
Qed.

Lemma EnvZip_none_1of2
 :  forall {A B} e1 e2 e12 n
 ,  EnvZip e1 e2 e12
 -> @lookupEnv A n e1 = None
 -> @lookupEnv B n e2 = None.
Proof.
 intros A B e1 e2 e12 n HZ HL1.
 induction HZ.
 - simpl in *.
   congruence.
 - simpl in *.
   remember (string_dec n n0) as X.
   destruct X.
   + congruence.
   + firstorder.
Qed.

Lemma EnvZip_none_2of1
 :  forall {A B} e1 e2 e12 n
 ,  EnvZip e1 e2 e12
 -> @lookupEnv A n e2 = None
 -> @lookupEnv B n e1 = None.
Proof.
 intros A B e1 e2 e12 n HZ HL2.
 induction HZ.
 - simpl in *.
   congruence.
 - simpl in *.
   remember (string_dec n n0) as X.
   destruct X.
   + congruence.
   + firstorder.
Qed.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^166 - 5
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 6%nat;
    base := 32;
    bitwidth := 32;
    s := 2^166;
    c := [(1, 5)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


From Undecidability.Synthetic Require Import DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts MoreEnumerabilityFacts reductions.
From Undecidability.Shared Require Import ListAutomation.
Require Import List Lia.
Import ListNotations ListAutomationNotations.

Set Implicit Arguments.

(** ** Definitions *)

(** ** Pre-order properties *)

(** BEGIN LEGACY CODE FOR LIBRARY  *)

Section Properties.

  Variables (X : Type) (P : X -> Prop)
            (Y : Type) (Q : Y -> Prop)
            (Z : Type) (R : Z -> Prop).

  Fact reduces_reflexive : P ⪯ P.
  Proof. exists (fun x => x); red; tauto. Qed.

  Fact reduces_transitive : P ⪯ Q -> Q ⪯ R -> P ⪯ R.
  Proof.
    unfold reduces, reduction.
    intros (f & Hf) (g & Hg).
    exists (fun x => g (f x)).
    intro; rewrite Hf, Hg; tauto.
  Qed.

  (* ** An equivalent dependent definition *)

  Fact reduces_dependent :
    P ⪯ Q <-> inhabited (forall x, { y | P x <-> Q y }).
  Proof.
    constructor.
    - intros [f Hf]. constructor. intros x. now exists (f x).
    - intros [f]. exists (fun x => proj1_sig (f x)).
      intros x. exact (proj2_sig (f x)).
  Qed.

End Properties.

(*Module ReductionChainNotations.

 (* DLW: Thx to M. Wuttke for the tip, see coq-club ML *)

Ltac redchain2Prop_rec xs :=
  lazymatch xs with
  | pair ?x (pair ?y ?xs) =>
    let z := redchain2Prop_rec (pair y xs) in
    constr:(x ⪯ y /\ z)
  | pair ?x ?y => constr:(x ⪯ y)
  end.

Ltac redchain2Prop xs :=
  let z := redchain2Prop_rec xs
  in  exact z.

Declare Scope reduction_chain.
Delimit Scope reduction_chain with redchain_scope.
Notation "x '⪯ₘ' y" := (pair x y) (at level 80, right associativity, only parsing) : reduction_chain.
Notation "'⎩' xs '⎭'" := (ltac:(redchain2Prop (xs % redchain_scope))) (only parsing).
 *)
(** END LEGACY  *)

Lemma red_comp X (p : X -> Prop) Y (q : Y -> Prop) :
  p ⪯ q -> (fun x => ~ p x) ⪯ (fun y => ~ q y).
Proof.
  intros [f]. exists f. intros x. red in H. now rewrite H.
Qed.

Section enum_red.

  Variables (X Y : Type) (p : X -> Prop) (q : Y -> Prop).
  Variables (f : X -> Y) (Hf : forall x, p x <-> q (f x)).

  Variables (Lq : _) (qe : list_enumerator Lq q).

  Variables (x0 : X).

  Variables (d : eq_dec Y).

  Local Fixpoint L L' n :=
    match n with
    | 0 => []
    | S n => L L' n ++ [ x | x ∈ cumul L' n , In (f x) (cumul Lq n) ]
    end.

  Lemma enum_red L' :
    list_enumeratorᵗ L' X ->
    list_enumerator (L L') p.
  Proof.
    intros HL'.
    split.
    + intros H.
      eapply Hf in H. eapply (cumul_spec qe) in H as [m1]. destruct (cumul_specᵗ HL' x) as [m2 ?].
      exists (1 + m1 + m2). cbn. in_app 2.
      in_collect x.
      eapply cum_ge'; eauto; try lia.
      eapply cum_ge'; eauto; try lia.
    + intros [m H]. induction m.
      * inversion H.
      * cbn in H. inv_collect.
        eapply Hf. eauto.
  Qed.

End enum_red.

Lemma enumerable_red X Y (p : X -> Prop) (q : Y -> Prop) :
  p ⪯ q -> enumerableᵗ X -> discrete Y -> enumerable q -> enumerable p.
Proof.
  intros [f] [] % enum_enumT [] % discrete_iff [L] % enumerable_enum.
  eapply list_enumerable_enumerable.
  eexists. eapply enum_red; eauto.
Qed.

Theorem not_decidable X Y (p : X -> Prop) (q : Y -> Prop) :
  p ⪯ q -> enumerableᵗ X -> ~ enumerable (compl p) ->
  ~ decidable q /\ ~ decidable (compl q).
Proof.
  intros. split; intros ?.
  - eapply H1. eapply red_m_transports in H2; eauto.
    eapply decidable_complement in H2. eapply decidable_enumerable; eauto.
  - eapply H1. eapply red_m_transports in H2. 2: eapply red_m_complement; eauto.
    eapply decidable_enumerable; eauto.
Qed.

Theorem not_coenumerable X Y (p : X -> Prop) (q : Y -> Prop) :
  p ⪯ q -> enumerableᵗ X -> ~ enumerable (compl p) -> discrete Y ->
  ~ enumerable (compl q).
Proof.
  intros. intros ?. eapply H1. eapply enumerable_red in H3; eauto.
  now eapply red_comp.
Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2011-05-06

Properties of infinite sequences of terms. Uses classical logic, the
axiom of indefinite description, and the axiom WF_notIS for
WF_absorb. *)

Set Implicit Arguments.

From Coq Require Import IndefiniteDescription ClassicalChoice ProofIrrelevance
     Lia.
From CoLoR Require Import RelUtil ATrs LogicUtil ACalls SN InfSeq LeastNat
     ListUtil BoundNat NatUtil VecUtil ADP NotSN_IS ASN BoolUtil ClassicUtil.

Section S.

  Variable Sig : Signature.

  Notation term := (term Sig).
  Notation subterm_eq := (@subterm_eq Sig).
  Notation supterm_eq := (@supterm_eq Sig).

(*****************************************************************************)
(** general boolean conditions for which [WF (hd_red_mod R D)] is
equivalent to [WF (hd_red_Mod (int_red R #) D)] *)

  Section WF_hd_red_mod_of_WF_hd_red_Mod_int.

    Variables R D : rules Sig.

    Lemma undef_red_is_int_red :
      forall (hyp1 : forallb (@is_notvar_lhs Sig) R = true),
      forall t u, red R t u ->
      undefined R t = true -> int_red R t u /\ undefined R u = true.

    Proof.
      intros hyp1 t u tu ht. unfold undefined in ht. destruct t. discr.
      redtac. destruct l.
      rewrite forallb_forall in hyp1. ded (hyp1 _ lr). discr.
      ded (fun_eq_fill xl). decomp H.
      subst. simpl in xl. Funeqtac. rewrite (lhs_fun_defined lr) in ht. discr.
      split. rewrite xl, yr. ex (Fun f0 t0) r c s. split_all. congruence.
      subst. hyp.
    Qed.

    Lemma undef_rtc_red_is_rtc_int_red
      (hyp1 : forallb (@is_notvar_lhs Sig) R = true) :
      forall t u, red R # t u ->
      undefined R t = true -> int_red R # t u /\ undefined R u = true.

    Proof.
      induction 1; intro hx.
      ded (undef_red_is_int_red hyp1 H hx). intuition.
      split_all. refl.
      split_all. apply rt_trans with y; tauto. tauto.
    Qed.

    Lemma WF_hd_red_Mod_int :
      forall (hyp1 : forallb (@is_notvar_lhs Sig) R = true)
             (hyp2 : forallb (undefined_rhs R) D = true),
      WF (hd_red_Mod (int_red R #) D) -> WF (hd_red_mod R D).

    Proof.
      intros hyp1 hyp2.
      intro wf. unfold hd_red_mod. apply WF_mod_rev2. apply WF_mod_rev in wf.
      intro t. gen (wf t). induction 1.
      apply SN_intro. intros z [y [xy yz]]. apply H0. exists y. split_all.
      assert (hy : undefined R y = true). redtac.
      rewrite forallb_forall in hyp2. gen (hyp2 _ lr).
      unfold undefined_rhs. simpl. unfold undefined. subst. destruct r.
      discr. simpl. auto.
      destruct (undef_rtc_red_is_rtc_int_red hyp1 yz hy). hyp.
    Qed.

  End WF_hd_red_mod_of_WF_hd_red_Mod_int.

(*****************************************************************************)
(** subtype of minimal non-terminating terms *)

  Section NTM.

    Variable R : relation term.

    Record NTM : Type := mkNTM {
      NTM_val :> term;
      NTM_prop :> NT_min R NTM_val }.

  End NTM.

(*****************************************************************************)
(** get a minimal non-terminating subterm *)

  Section NT_min.

    Variables (R : relation term) (t : term) (ht : NT R t).

    Lemma NT_min_intro : exists u, subterm_eq u t /\ NT_min R u.

    Proof.
      set (P := fun n => exists u, subterm_eq u t /\ size u = n /\ NT R u).
      assert (exP : exists n, P n). ex (size t) t. split_all. refl.
      destruct (ch_min exP) as [n [[Pn nleP] nmin]].
      destruct Pn as [u [ut [un hu]]]. subst n. exists u. unfold NT_min, min.
      split_all. rename u0 into v.
      assert (size u <= size v). apply nleP. exists v. split_all.
      eapply subterm_eq_trans. apply subterm_strict. apply H. hyp.
      ded (subterm_size H). lia.
    Qed.

    Definition min_term :=
      proj1_sig (constructive_indefinite_description _ NT_min_intro).

    Lemma NT_min_term : NT_min R min_term.

    Proof.
      unfold min_term. destruct (constructive_indefinite_description
      (fun u : term => subterm_eq u t /\ NT_min R u) NT_min_intro) as [u hu].
      simpl. tauto.
    Qed.

    Lemma subterm_eq_min_term : subterm_eq min_term t.

    Proof.
      unfold min_term. destruct (constructive_indefinite_description
      (fun u : term => subterm_eq u t /\ NT_min R u) NT_min_intro) as [u hu].
      simpl. tauto.
    Qed.

    Definition min_NTM := mkNTM NT_min_term.

  End NT_min.

(*****************************************************************************)
(** get a minimal infinite (R @ supterm_eq)-sequence from an infinite
R-sequence *)

  Section IS_Min_supterm.

    Variable R : relation term.

    Definition Rsup : relation (NTM R) := R @ supterm_eq.

    Lemma Rsup_left_total : forall t, exists u, Rsup t u.

    Proof.
      intros [t [[f [h0 hf]] ht]]. exists (min_NTM (NT_IS_elt 1 hf)).
      unfold Rsup. simpl. exists (f 1). subst t. split_all.
      apply subterm_eq_min_term.
    Qed.

    Lemma IS_Min_supterm : forall f,
      IS R f -> exists g, IS (R @ supterm_eq) g /\ Min R g.

    Proof.
      intros f hf. set (Min' := fun f : nat -> NTM R =>
        forall i x, subterm x (f i) -> forall g, g 0 = x -> ~IS R g).
      cut (exists g : nat -> NTM R, IS Rsup g /\ Min' g).
      intros [g [h1 h2]]. exists (fun i => g i). split_all.
      destruct (choice _ Rsup_left_total) as [next hnext].
      set (a := min_NTM (NT_IS_elt 0 hf)). exists (iter a next). split.
      apply IS_iter. hyp.
      intros i x hx g g0 hg. destruct (iter a next i) as [t [[h [h0 hh]] ht]].
      simpl in hx. ded (ht _ hx). absurd (NT R x). hyp. exists g. tauto.
    Qed.

  End IS_Min_supterm.

(*****************************************************************************)
(** get an infinite (red R)-sub-sequence from an infinite
(int_red R)-sequence *)

  Lemma NT_int_red_subterm_NT_red : forall (R : rules Sig) f,
    IS (int_red R) f -> exists u, subterm u (f 0) /\ NT (red R) u.

  Proof.
    intros R f hf. subst. ded (hf 0). redtac. destruct c. cong.
    simpl in xl. clear yr lr cne r.
    (* forall i, exists v, f i = Fun f1 v *)
    assert (h : forall i, exists v, f i = Fun f0 v).
    induction i0. fo. clear xl s t0 c t e j i l.
    destruct IHi0 as [w hw]. ded (hf i0). redtac. destruct c. cong.
    simpl in xl, yr. rewrite hw in xl. Funeqtac. rewrite yr.
    exists (Vcast (Vapp t (Vcons (fill c (sub s r)) t0)) e). refl.
    clear xl s t0 c t e j i l. destruct (choice _ h) as [v hv]. clear h.
    (* forall i, exists k, exists hk : k < arity f0,
       int_red_pos_at k (f i) (f (S i)) *)
    assert (h : forall i, exists k, exists hk : k < arity f0,
      int_red_pos_at R k (f i) (f (S i))).
    intro i. ded (hf i). apply int_red_pos_eq in H. destruct H as [k H].
    cut (int_red_pos_at R k (f i) (f (S i))). 2: hyp.
    intro H'. destruct H as [g [hk [w [e H]]]]. rewrite hv in e. Funeqtac.
    exists k. exists hk. hyp. destruct (choice _ h) as [k hk]. clear h.
    (* infinite constant sub-sequence *)
    set (As := nats_decr_lt (arity f0)).
    assert (h : forall i, In (k i) As). intro i. destruct (hk i) as [hi ri].
    unfold As. rewrite <- In_nats_decr_lt. hyp.
    destruct (finite_codomain eq_nat_dec h) as [a [g [h1 [h2 h3]]]]. clear h As.
    assert (ha : a < arity f0). rewrite <- (h2 0). destruct (hk (g 0)). hyp.
    (* monotony of g *)
    assert (me : forall x y, x <= y -> g x <= g y). intros x y xy.
    destruct (lt_dec x y). ded (monS lt_trans h1). ded (H _ _ l). lia.
    assert (x=y). lia. subst. refl.
    (* forall j, j < g 0 -> k j <> a *)
    assert (hg0 : forall j, j < g 0 -> k j <> a).
    intros j hj e. destruct (h3 _ e) as [l hl]. subst.
    destruct (le_dec 0 l). ded (me _ _ l0). lia. lia.
    (* forall i j, g i < j < g (S i) -> k j <> a *)
    assert (hg : forall i j, g i < j < g (S i) -> k j <> a).
    intros i j hj e. destruct (h3 _ e) as [l hl]. subst.
    destruct (ge_dec i l). ded (me _ _ g0). lia.
    destruct (ge_dec l (S i)). ded (me _ _ g0). lia. lia.
    (* Vnth (v 0) ha = Vnth (v (g 0)) ha *)
    assert (h0 : Vnth (v 0) ha = Vnth (v (g 0)) ha).
    cut (forall l, l <= g 0 -> Vnth (v 0) ha = Vnth (v l) ha).
    intro h. apply h. refl.
    induction l; simpl. refl. intro h. rewrite IHl. 2: lia.
    destruct (hk l) as [_ r]. destruct r as [f' [hi [ts [e [w [p1 p2]]]]]].
    rewrite hv in e, p2. Funeqtac. Funeqtac. rewrite H, H0.
    rewrite Vnth_replace_neq. refl. apply (hg0 l). lia.
    (* forall i, Vnth (v (S (g i))) ha = Vnth (v (g (S i))) ha *)
    assert (h : forall i, Vnth (v (S (g i))) ha = Vnth (v (g (S i))) ha).
    intro i. ded (h1 i). cut (forall l, l < g (S i) - g i ->
      Vnth (v (S (g i))) ha = Vnth (v (S (g i) + l)) ha).
    intro hi. assert (e : g (S i) = S (g i) + (g (S i) - g i - 1)). lia.
    rewrite e. apply hi. clear e. clear -H; lia.
    induction l; intro. rewrite plus_0_r. refl.
    assert (hl : l < g (S i) - g i). clear -H0; lia. rewrite (IHl hl).
    rewrite <- plus_Snm_nSm. simpl. set (x := S (g i + l)).
    destruct (hk x) as [_ r]. destruct r as [f' [hi [ts [e [w [p1 p2]]]]]].
    rewrite hv in e, p2. Funeqtac. Funeqtac. rewrite H1, H2.
    rewrite Vnth_replace_neq. refl. apply (hg i). unfold x. clear -H0; lia.
    (* [Vnth (v 0) ha] is a subterm of [f 0] *)
    exists (Vnth (v 0) ha). split.
    rewrite hv. apply subterm_fun. apply Vnth_in.
    (* [Vnth (v 0) ha] is non-terminating *)
    exists (fun i => Vnth (v (g i)) ha). split. sym. hyp.
    intro i. rewrite <- h. destruct (hk (g i)) as [_ r].
    destruct r as [f' [hi [ts [e [w [p1 p2]]]]]].
    rewrite hv in e, p2. Funeqtac. Funeqtac. rewrite H, H0.
    rewrite Vreplace_pi with (h2:=ha). 2: apply h2. rewrite Vnth_replace.
    rewrite Vnth_eq with (h2:=hi). 2: sym; apply h2. hyp.
  Qed.

(*****************************************************************************)
(** get a minimal infinite (hd_red_mod R (dp R))-sequence from a
minimal infinite R-sequence *)

  Section IS_Min_dp.

    Variable R : rules Sig.

    Variable hyp1 : forallb (@is_notvar_lhs Sig) R = true.
    Variable hyp2 : rules_preserve_vars R.

    Lemma min_hd_red_dp : forall t u v, NT_min (red R) t -> hd_red R t u ->
      subterm_eq v u -> NT_min (red R) v -> hd_red (dp R) t v.

    Proof.
      intros t u v ht tu vu hv. redtac. subst.
      (* forall x, ~NT (red R) (s x) *)
      assert (hs : forall x, In x (vars l) -> ~NT (red R) (s x)).
      intros x vx nx. assert (hx : subterm (Var x) l).
      destruct (in_vars_subterm_eq vx) as [c hx]. destruct c.
      rewrite forallb_forall in hyp1. ded (hyp1 _ lr). rewrite hx in H. discr.
      exists (Cont f e t c t0). split_all. discr.
      ded (subterm_sub s hx). destruct ht as [ht1 ht2].
      ded (ht2 _ H). contr.
      destruct (subterm_eq_sub_elim vu) as [w [hw1 hw2]]. destruct w.
      (* w = Var n *)
      assert (hn : In n (vars l)). eapply hyp2. apply lr.
      eapply subterm_eq_vars. apply hw1. simpl. auto.
      destruct hv as [hv1 hv2]. absurd (NT (red R) v).
      rewrite <- SN_notNT_eq. eapply subterm_eq_sn. rewrite SN_notNT_eq.
      eapply hs. apply hn. hyp. hyp.
      (* w = Fun f v0 *)
      subst. ex l (Fun f t) s. split_all. eapply dp_intro. apply lr.
      (* In (Fun f v0) (calls R r) *)
      apply subterm_in_calls. 2: hyp. case_eq (defined f R); intro H. refl.
      destruct hv as [hv1 hv2].
      absurd (NT (red R) (sub s (Fun f t))). 2: hyp.
      rewrite <- SN_notNT_eq. apply sn_args_sn_fun. hyp. hyp.
      apply Vforall_intro. intros a ha. rewrite SN_notNT_eq.
      apply hv2. apply subterm_fun. hyp.
      (* nebg_subterm l (Fun f t) = true *)
      unfold negb_subterm. rewrite negb_ok. 2: apply bsubterm_ok. intro h.
      destruct ht as [ht1 ht2]. absurd (NT (red R) (sub s (Fun f t))).
      apply ht2. apply subterm_sub. hyp. destruct hv as [hv1 hv2]. hyp.
    Qed.

    Definition Rdp : relation (NTM (red R)) := hd_red_Mod (int_red R #) (dp R).

    Lemma Rdp_left_total : forall t, exists u, Rdp t u.

    Proof.
      intros [t [[f [h0 hf]] ht]]. subst.
      (* f has a top reduct *)
      destruct (classic (IS (int_red R) f)).
      destruct (NT_int_red_subterm_NT_red H). ded (ht x). intuition.
      unfold IS in H. rewrite not_forall_eq in H.
      set (k := proj1_sig (ch_min H)).
      assert (hk : hd_red R (f k) (f (S k))). ded (hf k).
      destruct (red_split H0). hyp. ded (ch_minP _ H). contr.
      assert (hk' : int_red R # (f 0) (f k)).
      cut (forall i, i <= k -> int_red R # (f 0) (f i)).
      intro h. apply h. refl.
      induction i; intro hi. apply rt_refl. apply rt_trans with (f i).
      apply IHi. lia. apply rt_step. apply NNPP. intro h.
      assert (k <= i). apply is_min_ch. hyp. lia.
      (* (f k) is minimal *)
      assert (NT_min (red R) (f k)). split.
      exists (fun i => f (i+k)). intuition. intro i. apply hf.
      eapply int_red_rtc_min. apply hk'. hyp.
      (* take the minimal non-terminating subterm of [f (S k)] *)
      assert (NT (red R) (f (S k))). apply NT_IS_elt. hyp.
      exists (min_NTM H1). exists (mkNTM H0). simpl. intuition.
      eapply min_hd_red_dp. hyp. apply hk. apply subterm_eq_min_term.
      apply NT_min_term.
    Qed.

    Lemma IS_Min_dp : forall f, IS (red R) f ->
      exists g, IS (hd_red_Mod (int_red R #) (dp R)) g /\ Min (red R) g.

    Proof.
      intros f hf. set (Min' := fun f : nat -> NTM (red R) =>
        forall i x, subterm x (f i) -> forall g, g 0 = x -> ~IS (red R) g).
      cut (exists g : nat -> NTM (red R), IS Rdp g /\ Min' g).
      intros [g [h1 h2]]. exists (fun i => g i). intuition.
      destruct (choice _ Rdp_left_total) as [next hnext].
      set (a := min_NTM (NT_IS_elt 0 hf)). exists (iter a next). split.
      apply IS_iter. hyp.
      intros i x hx g g0 hg. destruct (iter a next i) as [t [[h [h0 hh]] ht]].
      simpl in hx. ded (ht _ hx). absurd (NT (red R) x). hyp.
      exists g. intuition.
    Qed.

  End IS_Min_dp.

End S.


From Minirust.def Require Import ty encoding utils thm wf.

Section defs.

Context {memory: Memory}.

Definition canonicalize ty l := decode ty l >>= encode ty.

Definition encode_len (ty: Ty) :=
  forall v, forall l,
  encode ty v = Some l ->
  length l = ty_size ty.

(* relevant properties satisfied by all well-formed types *)
Record Props ty := {
  PR_WF : wf ty;
  PR_RT1 : rt1 ty;
  PR_RT2 : rt2 ty;
  PR_MONO1 : mono1 ty;
  PR_MONO2 : mono2 ty;
  PR_ENCODE_LEN : encode_len ty
}.

End defs.


(** **********************************************************

Ralph Matthes

August 2022
*)

(** **********************************************************

constructs the final object of the bicategory of whiskered monoidal categories

this resides in a separate file because of the heavy dependencies

 ************************************************************)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.categories.StandardCategories.

Require Import UniMath.Bicategories.Core.Examples.BicatOfCats.

Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.Limits.Final.
Require Import UniMath.Bicategories.Limits.Examples.BicatOfCatsLimits.
Require Import UniMath.Bicategories.Limits.Examples.TotalBicategoryLimits.

Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.

Require Import UniMath.Bicategories.MonoidalCategories.BicatOfWhiskeredMonCats.

Local Open Scope cat.

Definition unit_monoidal : monoidal (pr1 unit_category).
Proof.
  use tpair.
  - use tpair.
    + use make_bifunctor_data.
      * exact (fun _ _ => tt).
      * intros. apply idpath.
      * intros. apply idpath.
    + exists tt.
      repeat split; intro x; induction x; apply isapropunit.
  - split.
    + abstract (repeat split).
    + abstract (
        do 2 (split; [split; red; intros; [apply isasetunit | split; apply isasetunit] |]);
        split;
        [ do 3 (split; [red; intros; apply isasetunit |]);
          split; apply isasetunit |
          split; red; intros; apply isasetunit]).
Defined.

Definition unit_monoidal_disp_bifinal_obj : disp_bifinal_obj_stronger bidisp_monbicat_disp_bicat (_,,bifinal_cats).
Proof.
  exists unit_monoidal.
  use tpair.
  - intros C M.
    cbn.
    use tpair.
    + use tpair.
      * split; red; intros; apply idpath.
      * abstract (repeat split).
    + split; red; intros; exists (idpath tt); abstract (split; apply isasetunit).
  - intros x xx f g ff gg.
    red; cbn; red; cbn.
    split; red; intros; apply isasetunit.
Defined.

Definition bifinal_moncats : bifinal_obj monbicat.
Proof.
  use total_bicat_final_stronger.
  - exact monbicat_disp_2cells_isaprop.
  - exact (_,,bifinal_cats).
  - exact unit_monoidal_disp_bifinal_obj.
Defined.