Require Import
        Coq.Strings.String
        Coq.Vectors.Vector
        Coq.ZArith.ZArith.

Require Import
        Fiat.Common.SumType
        Fiat.Common.EnumType
        Fiat.Common.BoundedLookup
        Fiat.Common.ilist
        Fiat.Computation
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple
        Fiat.Narcissus.BinLib
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.WordFacts
        Fiat.Narcissus.Common.ComposeCheckSum
        Fiat.Narcissus.Common.ComposeIf
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.Formats
        Fiat.Narcissus.BaseFormats
        Fiat.Narcissus.Stores.EmptyStore
        Fiat.Narcissus.Automation.Solver
        Fiat.Narcissus.Automation.AlignedAutomation.

Require Import Bedrock.Word.

Import Vectors.Vector.VectorNotations.
Open Scope format_scope.

Section TCPPacketDecoder.

  Record TCP_Packet :=
    {SourcePort : word 16;
     DestPort : word 16;
     SeqNumber : word 32;
     AckNumber : word 32;
     NS : bool; (* ECN-nonce concealment protection flag *)
     CWR : bool; (* Congestion Window Reduced (CWR) flag *)
     ECE : bool; (* ECN-Echo flag *)
    (* We can infer the URG flag from the Urgent Pointer field *)
     ACK : bool; (* Acknowledgment field is significant flag *)
     PSH : bool; (* Push function flag *)
     RST : bool; (* Reset the connection flag *)
     SYN : bool; (* Synchronize sequence numbers flag *)
     FIN : bool; (* No more data from sender flag*)
     WindowSize : word 16;
     UrgentPointer : option (word 16);
     Options : list (word 32);
     Payload : { n : _ & ByteBuffer.t n }}.

  (* These values are provided by the IP header for checksum calculation.*)

  (* These values are provided by the IP header for checksum calculation.*)
  Variable srcAddr : ByteBuffer.t 4.
  Variable destAddr : ByteBuffer.t 4.
  Variable tcpLength : word 16.

  Definition TCP_Packet_Format
    : FormatM TCP_Packet ByteString  :=
         (format_word ◦ SourcePort
          ++ format_word ◦ DestPort
          ++ format_word ◦ SeqNumber
          ++ format_word ◦ AckNumber
          ++ format_nat 4 ◦ (plus 5) ◦ (@length _) ◦ Options
          ++ format_unused_word 3 (* These bits are reserved for future use. *)
          ++ format_bool ◦ NS
          ++ format_bool ◦ CWR
          ++ format_bool ◦ ECE
          ++ format_bool ◦ (fun urg_opt => Ifopt urg_opt as urg Then true Else false) ◦ UrgentPointer
          ++ format_bool ◦ ACK
          ++ format_bool ◦ PSH
          ++ format_bool ◦ RST
          ++ format_bool ◦ SYN
          ++ format_bool ◦ FIN
          ++ format_word ◦ WindowSize)
          ThenChecksum (Pseudo_Checksum_Valid srcAddr destAddr tcpLength (natToWord 8 6)) OfSize 16
          ThenCarryOn (format_option format_word (format_unused_word 16) ◦ UrgentPointer
                                            ++ format_list format_word ◦ Options
                                            ++ format_bytebuffer ◦ Payload).

  Definition TCP_Packet_OK (tcp : TCP_Packet) :=
    lt (|tcp.(Options)|) 11
    /\ wordToNat tcpLength
       = 20 (* length of packet header *)
         + (4 * |tcp.(Options)|) (* length of option field *)
         + (projT1 tcp.(Payload)).

  Local Arguments NPeano.modulo : simpl never.

  Definition TCP_Length :=
    (fun _ : ByteString => wordToNat tcpLength).

  Ltac new_encoder_rules ::=
    eapply @CorrectAlignedEncoderForPseudoChecksumThenC;
    [ normalize_encoder_format
    | normalize_encoder_format
    | repeat calculate_length_ByteString
    | solve_mod_16
    | repeat calculate_length_ByteString
    | solve_mod_8
    ].

  (* Step One: Synthesize an encoder and a proof that it is correct. *)
  Definition TCP_encoder :
    CorrectAlignedEncoderFor TCP_Packet_Format.
  Proof.
    synthesize_aligned_encoder.
    Grab Existential Variables.
    eauto.
    eauto.
  Defined.

  (* Step Two: Extract the encoder function, and have it start encoding
     at the start of the provided ByteString [v]. *)
  Definition TCP_encoder_impl r {sz} v :=
    Eval simpl in (projT1 TCP_encoder sz v 0 r tt).

  (* Step Two and a Half: Add some simple facts about correct packets
   for the decoder automation. *)

  Ltac apply_new_combinator_rule ::=
    match goal with
    | H : cache_inv_Property ?mnd _
      |- CorrectDecoder _ _ _ _ (?fmt1 ThenChecksum _ OfSize _ ThenCarryOn ?format2) _ _ _ =>
      eapply compose_PseudoChecksum_format_correct';
      [ repeat calculate_length_ByteString
      | repeat calculate_length_ByteString
      | exact H
      | solve_mod_8
      | solve_mod_8
      | normalize_format; apply_rules
      | normalize_format; apply_rules
      | solve_Prefix_Format ]
    end.

  (* Step Three: Synthesize a decoder and a proof that /it/ is correct. *)
  Definition TCP_Packet_Header_decoder
    : CorrectAlignedDecoderFor TCP_Packet_OK TCP_Packet_Format.
  Proof.
    synthesize_aligned_decoder.
    Grab Existential Variables.
    eauto.
    eauto.
  Defined.

Definition TCP_decoder_impl {sz} v :=
  Eval simpl in (projT1 TCP_Packet_Header_decoder sz v 0 ()).

End TCPPacketDecoder.

Print TCP_decoder_impl.

Local Transparent weqb.
Local Transparent natToWord.

Definition tcp_decode_input :=
  Vector.map
    (natToWord 8)
    [144; 42; 0; 80; 19; 125; 120; 241; 243; 111; 68; 47; 128; 24;
     0; 229; 29; 216; 0; 0; 1; 1; 8; 10; 228; 110; 2; 137;
     80; 206; 41; 110; 71; 69; 84; 32; 47; 32; 72; 84; 84; 80;
     47; 49; 46; 49; 13; 10; 72; 111; 115; 116; 58; 32; 110; 121;
     116; 105; 109; 101; 115; 46; 99; 111; 109; 13; 10; 85; 115; 101;
     114; 45; 65; 103; 101; 110; 116; 58; 32; 99; 117; 114; 108; 47;
     55; 46; 52; 55; 46; 48; 13; 10; 65; 99; 99; 101; 112; 116;
     58; 32; 42; 47; 42; 13; 10; 13; 10].

Definition srcAddr := (Vector.map (natToWord 8) [192; 168; 1; 109]).
Definition destAddr := (Vector.map (natToWord 8) [151; 101; 129; 164]).
Definition Vector_length {A n} (v: Vector.t A n) := n.

Definition out :=
Eval compute in
    match (@TCP_decoder_impl srcAddr destAddr (natToWord _ (Vector_length tcp_decode_input)) _ tcp_decode_input) with
    | Some (p, _, _) =>
      (Some (Vector.fold_right (fun c s => String (Ascii.ascii_of_N (wordToN c)) s) (projT2 p.(Payload)) EmptyString),
       match (@TCP_encoder_impl srcAddr destAddr (natToWord _ (Vector_length tcp_decode_input))
                                p _ (Vector.const (natToWord 8 0) (Vector_length tcp_decode_input))) with
       | Some (v, _, _) => Some (Vector.map (@wordToNat 8) v)
       | None => None
       end)
    | None => (None, None)
    end.


Require Import ExtLib.Core.Any.

Set Implicit Arguments.
Set Strict Implicit.

Polymorphic Class Functor@{d c} (F : Type@{d} -> Type@{c}) : Type :=
{ fmap : forall {A B : Type@{d}}, (A -> B) -> F A -> F B }.

Polymorphic Definition ID@{d} {T : Type@{d}} (f : T -> T) : Prop :=
  forall x : T, f x = x.

Polymorphic Class PFunctor@{d c p} (F : Type@{d} -> Type@{c}) : Type :=
{ FunP : Type@{d} -> Type@{p}
; pfmap : forall {A B : Type@{d}} {P : FunP B}, (A -> B) -> F A -> F B
}.

Existing Class FunP.
Hint Extern 0 (@FunP _ _ _) => progress (simpl FunP) : typeclass_instances.

(** TODO: This is due to a but in current 8.5 **)
Polymorphic Definition PFunctor_From_Functor@{d c p}
       (F : Type@{d} -> Type@{c}) (FunF : Functor@{d c} F) : PFunctor@{d c p} F :=
{| FunP := Any
; pfmap := fun _ _ _ f x => fmap f x
|}.
Global Existing Instance PFunctor_From_Functor.

Module FunctorNotation.
  Notation "f <$> x" := (@pfmap _ _ _ _ _ f x) (at level 51, right associativity).
End FunctorNotation.


From Hammer Require Import Tactics Reflect Hints.
From Hammer Require Import Hammer.

From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat ssralg seq fintype tuple eqtype.

From Coq Require Import FunctionalExtensionality.
From Coq Require Import Relation_Definitions RelationClasses.

Require Import CoqArith.Utils.

Require Import CoqArith.Sigma_1_1_UnFree.
Require Import Program.

Section NoQuantDef.

Variables D : RingData.

Inductive PolyTermVS {exiV exiF uniV} {exiFA : |[exiF]| -> nat} : Type :=
| PolyFVarVS : nat -> PolyTermVS
| PolyEVarVS : |[exiV]| -> PolyTermVS
| PolyUVarVS : |[uniV]| -> PolyTermVS
| PolyFFunVS : forall (i a : nat), (|[a]| -> PolyTermVS) -> PolyTermVS
| PolyEFunVS : forall (i : |[exiF]|), (|[exiFA i]| -> PolyTermVS) -> PolyTermVS
| PolyMinusOneVS : PolyTermVS
| PolyPlusOneVS : PolyTermVS
| PolyZeroVS : PolyTermVS
| PolyPlusVS : PolyTermVS -> PolyTermVS -> PolyTermVS
| PolyTimesVS : PolyTermVS -> PolyTermVS -> PolyTermVS
| PolyIndVS : PolyTermVS -> PolyTermVS -> PolyTermVS.

Inductive ZerothOrderFormulaVS {exiV exiF uniV} {exiFA : |[exiF]| -> nat} : Type :=
| ZONotVS : ZerothOrderFormulaVS -> ZerothOrderFormulaVS
| ZOAndVS : ZerothOrderFormulaVS -> ZerothOrderFormulaVS -> ZerothOrderFormulaVS
| ZOOrVS : ZerothOrderFormulaVS -> ZerothOrderFormulaVS -> ZerothOrderFormulaVS
| ZOImpVS : ZerothOrderFormulaVS -> ZerothOrderFormulaVS -> ZerothOrderFormulaVS
| ZOEqVS : @PolyTermVS exiV exiF uniV exiFA
      -> @PolyTermVS exiV exiF uniV exiFA
      -> ZerothOrderFormulaVS.

Record NoQuant {exiV exiF uniV} {exiFA : |[exiF]| -> nat} : Type :=
  mkNoQuant {
    nu : {s : |[exiV]| -> { m : nat | m <= uniV } | forall i j : |[exiV]|, (` i) <= (` j) -> (` (s i)) <= (` (s j))};
    uniVBounds : |[uniV]| -> @PolyTermVS exiV exiF uniV exiFA;
    exiVBounds : |[exiV]| -> @PolyTermVS exiV exiF uniV exiFA;
    exiFOutputBounds : |[exiF]| -> @PolyTermVS exiV exiF uniV exiFA;
    exiFInputBounds : forall (i : |[exiF]|), |[exiFA i]| -> @PolyTermVS exiV exiF uniV exiFA;
    formula : @ZerothOrderFormulaVS exiV exiF uniV exiFA
  }.

Record NoQuantAdvice {exiV exiF uniV} {exiFA : |[exiF]| -> nat} : Type :=
  mkNoQuantAdvice {
    exiVAdv : |[exiV]| -> (|[uniV]| -> T D) -> T D;
    exiFAdv : forall i : |[exiF]|, (|[exiFA i]| -> T D) -> option (T D);
  }.

Fixpoint PolyVSDenotation
  {exiV exiF uniV} {exiFA : |[exiF]| -> nat}
  (p : PolyTermVS)
  (M : Sigma11Model D)
  (adv : @NoQuantAdvice exiV exiF uniV exiFA) :
  (|[uniV]| -> T D) -> option (T D) :=
  match p with
  | PolyFVarVS i => fun _ => Some (V_F D M i)
  | PolyEVarVS i => fun u => Some (exiVAdv adv i u)
  | PolyUVarVS i =>  fun u => Some (u i)
  | PolyFFunVS i a t => fun u =>
    obind (fun t => F_S D M i a t) (option_tuple (fun x => PolyVSDenotation (t x) M adv u))
  | PolyEFunVS i t => fun u =>
    obind (fun t => exiFAdv adv i t) (option_tuple (fun x => PolyVSDenotation (t x) M adv u))
  | PolyMinusOneVS => fun _ => Some (-1)%R
  | PolyPlusOneVS => fun _ => Some 1%R
  | PolyZeroVS => fun _ => Some 0%R
  | PolyPlusVS p1 p2 => fun u =>
    let d1 := PolyVSDenotation p1 M adv u in
    let d2 := PolyVSDenotation p2 M adv u in
    obind (fun r1 => obind (fun r2 => Some (r1 + r2)%R) d2) d1
  | PolyTimesVS p1 p2 => fun u =>
    let r1 := PolyVSDenotation p1 M adv u in
    let r2 := PolyVSDenotation p2 M adv u in
    obind (fun r1 => obind (fun r2 => Some (r1 * r2)%R) r2) r1
  | PolyIndVS p1 p2 => fun u =>
    let r1 := PolyVSDenotation p1 M adv u in
    let r2 := PolyVSDenotation p2 M adv u in
    obind (fun r1 => obind (fun r2 => Some (indFun D r1 r2)) r2) r1
  end.

Program Fixpoint NoQuantZODenotation
  {exiV exiF uniV} {exiFA : |[exiF]| -> nat}
  (p : ZerothOrderFormulaVS)
  (M : Sigma11Model D)
  (adv : @NoQuantAdvice exiV exiF uniV exiFA) :
  (|[uniV]| -> T D) -> Prop :=
  match p with
  | ZONotVS p => fun u =>
    let r := NoQuantZODenotation p M adv u in
    not r
  | ZOAndVS p1 p2 => fun u =>
    let r1 := NoQuantZODenotation p1 M adv u in
    let r2 := NoQuantZODenotation p2 M adv u in
    r1 /\ r2
  | ZOOrVS p1 p2 => fun u =>
    let r1 := NoQuantZODenotation p1 M adv u in
    let r2 := NoQuantZODenotation p2 M adv u in
    r1 \/ r2
  | ZOImpVS p1 p2 => fun u =>
    let r1 := NoQuantZODenotation p1 M adv u in
    let r2 := NoQuantZODenotation p2 M adv u in
    r1 -> r2
  | ZOEqVS p1 p2 => fun u =>
    let r1 := PolyVSDenotation p1 M adv u in
    let r2 := PolyVSDenotation p2 M adv u in
    match r1 with
    | None => false
    | Some r1 =>
      match r2 with
      | None => false
      | Some r2 => r1 = r2
      end
    end
  end.

Definition InBound
  {exiV exiF uniV} {exiFA : |[exiF]| -> nat}
  (M : Sigma11Model D)
  (adv : @NoQuantAdvice exiV exiF uniV exiFA)
  (r : T D)
  (b : @PolyTermVS exiV exiF uniV exiFA)
  (t : |[uniV]| -> T D) : Prop :=
  match PolyVSDenotation b M adv t with
  | None => False
  | Some e => lt D r e
  end.

Program Definition MakeU {A uniV} {n : {m : nat | m <= uniV}}
  (a : |[n]| -> A)
  (b : |[uniV - n]| -> A) :
  |[uniV]| -> A := TupConcat a b.
Next Obligation.
  replace (n + (uniV - n)) with uniV; auto.
  sfirstorder use: subnKC.
Qed.

Program Definition U
  {exiV exiF} {exiFA : |[exiF]| -> nat}
  {uniV}
  (f : @NoQuant exiV exiF uniV exiFA)
  (M : Sigma11Model D) (adv : NoQuantAdvice)
  (i : |[exiV]|) : Type
  := { u : |[nu f i]| -> T D |
       forall j : |[nu f i]|,
       forall v : |[uniV - nu f i]| -> T D,
       InBound M adv (u j) (uniVBounds f j) (MakeU u v)
    }.
Next Obligation.
  destruct ((` (nu f)) _).
  simpl in *.
  strivial use: @NoFractions, leq_trans.
Qed.

Definition NoQuantFormulaCondition
  {exiV exiF uniV} {exiFA : |[exiF]| -> nat}
  (f : @NoQuant exiV exiF uniV exiFA)
  (M : Sigma11Model D) (adv : NoQuantAdvice) : Prop :=
  forall u, NoQuantZODenotation (formula f) M adv u.

Program Definition NoQuantFOBoundCondition
  {exiV exiF uniV} {exiFA : |[exiF]| -> nat}
  (f : @NoQuant exiV exiF uniV exiFA)
  (M : Sigma11Model D) (adv : NoQuantAdvice) : Prop :=
  forall i : |[exiV]|,
  forall u : U f M adv i,
  forall n : |[uniV - nu f i]| -> T D,
  InBound M adv (exiVAdv adv i (MakeU u n)) (exiVBounds f i) (MakeU u n).

(* Note: This covers both conditions 5 and 6 in the paper *)
Definition NoQuantSOBoundCondition
  {exiV exiF uniV} {exiFA : |[exiF]| -> nat}
  (f : @NoQuant exiV exiF uniV exiFA)
  (M : Sigma11Model D) (adv : NoQuantAdvice) : Prop :=
  forall u : |[uniV]| -> T D, forall i : |[exiF]|,
  let B := PolyVSDenotation (exiFOutputBounds f i) M adv u in
  let G (j : |[exiFA i]|) := PolyVSDenotation (exiFInputBounds f i j) M adv u in
  forall (t : |[exiFA i]| -> T D) (out : T D),
  exiFAdv adv i t = Some out ->
  match B with
  | None => false
  | Some B => lt D out B /\ forall x,
    match G x with
    | None => false
    | Some Gx => lt D (t x) Gx
    end
  end.

Program Definition NoQuantExiStratCondition
  {exiV exiF uniV} {exiFA : |[exiF]| -> nat}
  (f : @NoQuant exiV exiF uniV exiFA)
  (M : Sigma11Model D)
  (adv : @NoQuantAdvice exiV exiF uniV exiFA) : Prop :=
  forall i : |[exiV]|, forall m : |[nu f i]| -> T D,
  exists C, forall n : |[uniV - nu f i]| -> T D,
  exiVAdv adv i (MakeU m n) = C.

Definition NoQuantDenotation
  {exiV exiF uniV} {exiFA : |[exiF]| -> nat}
  (f : @NoQuant exiV exiF uniV exiFA)
  (i : Sigma11Model D): Prop :=
  exists (a : NoQuantAdvice),
    NoQuantFormulaCondition f i a /\
    NoQuantFOBoundCondition f i a /\
    NoQuantSOBoundCondition f i a /\
    NoQuantExiStratCondition f i a.

End NoQuantDef.

Section NoQuantTranslation.

Variables D : RingData.

Fixpoint PolyTerm_PolyTermVS (p : PolyTerm) : @PolyTermVS 0 0 0 emptyTuple :=
  match p with
  | PolyVar m => PolyFVarVS m
  | PolyFun i a t => PolyFFunVS i a (fun x => PolyTerm_PolyTermVS (t x))
  | PolyMinusOne => PolyMinusOneVS
  | PolyPlusOne => PolyPlusOneVS
  | PolyZero => PolyZeroVS
  | PolyPlus r1 r2 => PolyPlusVS (PolyTerm_PolyTermVS r1) (PolyTerm_PolyTermVS r2)
  | PolyTimes r1 r2 => PolyTimesVS (PolyTerm_PolyTermVS r1) (PolyTerm_PolyTermVS r2)
  | PolyInd r1 r2 => PolyIndVS (PolyTerm_PolyTermVS r1) (PolyTerm_PolyTermVS r2)
  end.

Definition EmptyAdvice : @NoQuantAdvice D 0 0 0 emptyTuple :=
  {| exiVAdv := emptyTuple
   ; exiFAdv := emptyTuple
  |}.

Theorem EmptyAdviceUnique : forall a, a = EmptyAdvice.
Proof.
  intros [a b].
  unfold EmptyAdvice.
  f_equal.
  apply functional_extensionality;move=> [lti i]; fcrush.
  apply functional_extensionality_dep;move=> [lti i]; fcrush.
Qed.

Definition PolyVSDenotation0
  (p : @PolyTermVS 0 0 0 emptyTuple)
  (M : Sigma11Model D) : option (T D) :=
  PolyVSDenotation D p M EmptyAdvice emptyTuple.

Theorem PolyTerm_PolyTermVS_Correct (p : PolyTerm) :
  Poly_Denote D p = PolyVSDenotation0 (PolyTerm_PolyTermVS p).
Proof.
  induction p; auto; apply functional_extensionality; intro.
  - unfold PolyVSDenotation0; simpl.
    do 2 f_equal; apply functional_extensionality; qauto.
  all: unfold PolyVSDenotation0; simpl;
      f_equal;[|by rewrite IHp1];
      apply functional_extensionality; intro;
      f_equal; by rewrite IHp2.
Qed.

Fixpoint ZerothOrder_ZerothOrderVS (p : ZerothOrderFormula) : @ZerothOrderFormulaVS 0 0 0 emptyTuple :=
  match p with
  | ZONot m => ZONotVS (ZerothOrder_ZerothOrderVS m)
  | ZOAnd r1 r2 => ZOAndVS (ZerothOrder_ZerothOrderVS r1) (ZerothOrder_ZerothOrderVS r2)
  | ZOOr r1 r2 => ZOOrVS (ZerothOrder_ZerothOrderVS r1) (ZerothOrder_ZerothOrderVS r2)
  | ZOImp r1 r2 => ZOImpVS (ZerothOrder_ZerothOrderVS r1) (ZerothOrder_ZerothOrderVS r2)
  | ZOEq a b => ZOEqVS (PolyTerm_PolyTermVS a) (PolyTerm_PolyTermVS b)
  end.

Definition NoQuantZODenotation0
  (p : @ZerothOrderFormulaVS 0 0 0 emptyTuple)
  (M : Sigma11Model D) : Prop :=
  NoQuantZODenotation D p M EmptyAdvice emptyTuple.

Theorem ZerothOrder_ZerothOrderVS_Correct (p : ZerothOrderFormula) :
  ZerothOrder_Denote D p = NoQuantZODenotation0 (ZerothOrder_ZerothOrderVS p).
Proof.
  induction p; apply functional_extensionality; intro; try qauto.
  unfold NoQuantZODenotation0; simpl.
  do 2 rewrite PolyTerm_PolyTermVS_Correct.
  unfold PolyVSDenotation0.
  do 2 (destruct (PolyVSDenotation  _ _ _ _); auto).
Qed.

Program Definition ZO_NoQuant
  (f : ZerothOrderFormula) : @NoQuant 0 0 0 emptyTuple :=
  {| nu := emptyTuple
   ; uniVBounds := emptyTuple
   ; exiVBounds := emptyTuple
   ; exiFOutputBounds := emptyTuple
   ; exiFInputBounds := emptyTuple
   ; formula := ZerothOrder_ZerothOrderVS f
  |}.

Lemma ZO_NoQuant_Correct_NoQuantFormulaCondition
  (f : ZerothOrderFormula) (M : Sigma11Model D) :
  ZerothOrder_Denote D f M <->
  exists a, NoQuantFormulaCondition D (ZO_NoQuant f) M a.
Proof.
  rewrite ZerothOrder_ZerothOrderVS_Correct.
  split;move=> H.
  - exists EmptyAdvice.
    intro t; replace t with (@emptyTuple (fun _ => T D));auto.
    apply functional_extensionality;move=> [x ltx]; fcrush.
  - destruct H as [adv H].
    unfold NoQuantFormulaCondition in H.
    remember (H emptyTuple) as H'; clear HeqH' H.
    rewrite (EmptyAdviceUnique adv) in H'; auto.
Qed.

Lemma ZO_NoQuant_Correct_NoQuantFOBoundCondition
  (f : ZerothOrderFormula) (M : Sigma11Model D) :
  forall a, NoQuantFOBoundCondition D (ZO_NoQuant f) M a.
Proof. move=> a [u ltu]; fcrush. Qed.

Lemma ZO_NoQuant_Correct_NoQuantSOBoundCondition
  (f : ZerothOrderFormula) (M : Sigma11Model D) :
  forall a, NoQuantSOBoundCondition D (ZO_NoQuant f) M a.
Proof. move=> a u [i lti]; fcrush. Qed.

Lemma ZO_NoQuant_Correct_NoQuantExiStratCondition
  (f : ZerothOrderFormula) (M : Sigma11Model D) :
  forall a, NoQuantExiStratCondition D (ZO_NoQuant f) M a.
Proof. move=> a [i lti]; fcrush. Qed.

Theorem ZO_NoQuant_Correct (p : ZerothOrderFormula) (M : Sigma11Model D) :
  ZerothOrder_Denote D p M <-> NoQuantDenotation D (ZO_NoQuant p) M.
Proof.
  hauto use: ZO_NoQuant_Correct_NoQuantFormulaCondition
           , ZO_NoQuant_Correct_NoQuantFOBoundCondition
           , ZO_NoQuant_Correct_NoQuantSOBoundCondition
           , ZO_NoQuant_Correct_NoQuantExiStratCondition.
Qed.

Fixpoint FOUni (f : FirstOrderFormula) : nat :=
  match f with
  | ZO z => 0
  | FOExists p f => FOUni f
  | FOForall p f => (FOUni f).+1
  end.

Fixpoint FOExi (f : FirstOrderFormula) : nat :=
  match f with
  | ZO z => 0
  | FOExists p f => (FOExi f).+1
  | FOForall p f => FOExi f
  end.

Program Fixpoint PolyTermVSLiftExi
  {exiV uniV}
  (p : @PolyTermVS exiV 0 uniV emptyTuple):
  @PolyTermVS (exiV.+1) 0 uniV emptyTuple :=
  match p with
  | PolyFVarVS i =>
    if i == 0
    then PolyEVarVS 0
    else PolyFVarVS (i.-1)
  | PolyEVarVS i => PolyEVarVS (i.+1)
  | PolyUVarVS i => PolyUVarVS i
  | PolyFFunVS i a t => PolyFFunVS i a (fun x => PolyTermVSLiftExi (t x))
  | PolyEFunVS i t => emptyTuple i
  | PolyMinusOneVS => PolyMinusOneVS
  | PolyPlusOneVS => PolyPlusOneVS
  | PolyZeroVS => PolyZeroVS
  | PolyPlusVS p1 p2 => PolyPlusVS (PolyTermVSLiftExi p1) (PolyTermVSLiftExi p2)
  | PolyTimesVS p1 p2 => PolyTimesVS (PolyTermVSLiftExi p1) (PolyTermVSLiftExi p2)
  | PolyIndVS p1 p2 => PolyIndVS (PolyTermVSLiftExi p1) (PolyTermVSLiftExi p2)
  end.

Fixpoint PropTermVSLiftExi
  {exiV uniV}
  (f : @ZerothOrderFormulaVS exiV 0 uniV emptyTuple):
  @ZerothOrderFormulaVS (exiV.+1) 0 uniV emptyTuple :=
  match f with
  | ZONotVS f => ZONotVS (PropTermVSLiftExi f)
  | ZOAndVS f1 f2 => ZOAndVS (PropTermVSLiftExi f1) (PropTermVSLiftExi f2)
  | ZOOrVS f1 f2 => ZOOrVS (PropTermVSLiftExi f1) (PropTermVSLiftExi f2)
  | ZOImpVS f1 f2 => ZOImpVS (PropTermVSLiftExi f1) (PropTermVSLiftExi f2)
  | ZOEqVS r1 r2 => ZOEqVS (PolyTermVSLiftExi r1) (PolyTermVSLiftExi r2)
  end.

Program Fixpoint PolyTermVSLiftUni
  {exiV uniV}
  (p : @PolyTermVS exiV 0 uniV emptyTuple):
  @PolyTermVS exiV 0 (uniV.+1) emptyTuple :=
  match p with
  | PolyFVarVS i =>
    if i == 0
    then PolyUVarVS 0
    else PolyFVarVS (i.-1)
  | PolyEVarVS i => PolyEVarVS i
  | PolyUVarVS i => PolyUVarVS (i.+1)
  | PolyFFunVS i a t => PolyFFunVS i a (fun x => PolyTermVSLiftUni (t x))
  | PolyEFunVS i t => emptyTuple i
  | PolyMinusOneVS => PolyMinusOneVS
  | PolyPlusOneVS => PolyPlusOneVS
  | PolyZeroVS => PolyZeroVS
  | PolyPlusVS p1 p2 => PolyPlusVS (PolyTermVSLiftUni p1) (PolyTermVSLiftUni p2)
  | PolyTimesVS p1 p2 => PolyTimesVS (PolyTermVSLiftUni p1) (PolyTermVSLiftUni p2)
  | PolyIndVS p1 p2 => PolyIndVS (PolyTermVSLiftUni p1) (PolyTermVSLiftUni p2)
  end.

Fixpoint PropTermVSLiftUni
  {exiV uniV}
  (f : @ZerothOrderFormulaVS exiV 0 uniV emptyTuple):
  @ZerothOrderFormulaVS exiV 0 (uniV.+1) emptyTuple :=
  match f with
  | ZONotVS f => ZONotVS (PropTermVSLiftUni f)
  | ZOAndVS f1 f2 => ZOAndVS (PropTermVSLiftUni f1) (PropTermVSLiftUni f2)
  | ZOOrVS f1 f2 => ZOOrVS (PropTermVSLiftUni f1) (PropTermVSLiftUni f2)
  | ZOImpVS f1 f2 => ZOImpVS (PropTermVSLiftUni f1) (PropTermVSLiftUni f2)
  | ZOEqVS r1 r2 => ZOEqVS (PolyTermVSLiftUni r1) (PolyTermVSLiftUni r2)
  end.

Program Fixpoint PolyTermVSCastFO
  {exiV uniV}
  (p : @PolyTermVS 0 0 0 emptyTuple):
  @PolyTermVS exiV 0 uniV emptyTuple :=
  match p with
  | PolyFVarVS i => PolyFVarVS i
  | PolyEVarVS i => emptyTuple i
  | PolyUVarVS i => emptyTuple i
  | PolyFFunVS i a t => PolyFFunVS i a (fun x => PolyTermVSCastFO (t x))
  | PolyEFunVS i t => emptyTuple i
  | PolyMinusOneVS => PolyMinusOneVS
  | PolyPlusOneVS => PolyPlusOneVS
  | PolyZeroVS => PolyZeroVS
  | PolyPlusVS p1 p2 => PolyPlusVS (PolyTermVSCastFO p1) (PolyTermVSCastFO p2)
  | PolyTimesVS p1 p2 => PolyTimesVS (PolyTermVSCastFO p1) (PolyTermVSCastFO p2)
  | PolyIndVS p1 p2 => PolyIndVS (PolyTermVSCastFO p1) (PolyTermVSCastFO p2)
  end.

Program Definition NoQuantAddExi
  {exiV uniV}
  (b : @PolyTermVS 0 0 0 emptyTuple)
  (q : @NoQuant exiV 0 uniV emptyTuple) :
  @NoQuant (exiV.+1) 0 uniV emptyTuple :=
  {| nu := ExtendAt0N 0 (nu q)
  ; uniVBounds := fun x => PolyTermVSLiftExi (uniVBounds q x)
  ; exiVBounds :=
    ExtendAt0N (PolyTermVSCastFO b)
               (fun x => PolyTermVSLiftExi (exiVBounds q x))
  ; exiFOutputBounds := emptyTuple
  ; exiFInputBounds := emptyTuple
  ; formula := PropTermVSLiftExi (formula q)
  |}.
Next Obligation.
  unfold ExtendAt0N.
  dep_if_case (x == 0); auto.
  by destruct ((` (nu q)) _).
Qed.
Next Obligation.
  destruct (nu q).
  unfold ExtendAt0N.
  dep_if_case (i == 0); auto.
  dep_if_case (j == 0); auto;[|apply i0]; by destruct i, j.
Qed.

Program Definition NoQuantAddUni
  {exiV uniV}
  (b : @PolyTermVS 0 0 0 emptyTuple)
  (q : @NoQuant exiV 0 uniV emptyTuple) :
  @NoQuant exiV 0 (uniV.+1) emptyTuple :=
  {| nu := fun x => (nu q x).+1
  ; uniVBounds :=
    ExtendAt0N (PolyTermVSCastFO b)
               (fun x => PolyTermVSLiftUni (uniVBounds q x))
  ; exiVBounds := fun x => PolyTermVSLiftUni (exiVBounds q x)
  ; exiFOutputBounds := emptyTuple
  ; exiFInputBounds := emptyTuple
  ; formula := PropTermVSLiftUni (formula q)
  |}.
Next Obligation. by destruct ((` (nu q)) _). Qed.
Next Obligation.
  destruct (nu q).
  by apply i0.
Qed.

Fixpoint FO_NoQuant
  (f : FirstOrderFormula) : @NoQuant (FOExi f) 0 (FOUni f) emptyTuple :=
  match f with
  | ZO z => ZO_NoQuant z
  | FOExists p f => NoQuantAddExi (PolyTerm_PolyTermVS p) (FO_NoQuant f)
  | FOForall p f => NoQuantAddUni (PolyTerm_PolyTermVS p) (FO_NoQuant f)
  end.

Definition AdviceExiExtend {exiV uniV}
  (r : T D)
  (adv : @NoQuantAdvice D exiV 0 uniV emptyTuple) :
  @NoQuantAdvice D (exiV.+1) 0 uniV emptyTuple :=
  {| exiVAdv := ExtendAt0N (fun _ => r) (exiVAdv D adv)
  ; exiFAdv := exiFAdv D adv
  |}.

Program Definition AdviceUniExtend {exiV uniV}
  (M : Sigma11Model D)
  (adv : @NoQuantAdvice D exiV 0 uniV emptyTuple)
  (f : {f : |[exiV]| -> (|[uniV.+1]| -> T D) -> T D | forall i x, f i (ExtendAt0N (V_F D M 0) x) = exiVAdv D adv i x }):
  @NoQuantAdvice D exiV 0 (uniV.+1) emptyTuple :=
  {| exiVAdv := f
  ; exiFAdv := exiFAdv D adv
  |}.

Lemma FO_NoQuant_Correct_Lem_0_0
  {exiV uniV}
  (p : @PolyTermVS exiV 0 uniV emptyTuple)
  (adv : @NoQuantAdvice D exiV 0 uniV emptyTuple)
  (M : Sigma11Model D) (r : T D) :
  forall u,
  PolyVSDenotation D p (AddModelV D M r) adv u =
  PolyVSDenotation D (PolyTermVSLiftExi p) M (AdviceExiExtend r adv) u.
Proof.
  elim: p; try qauto.
  - move=> n u.
    simpl.
    unfold ExtendAt0.
    dep_if_case (n == 0); auto.
    rewrite H.
    simpl.
    f_equal.
    by rewrite H.
  - move=> n u.
    simpl.
    f_equal.
    unfold ExtendAt0N; simpl.
    f_equal.
    by destruct n; apply subset_eq_compat.
  - move=> i a p IH u.
    simpl.
    do 2 f_equal.
    by apply functional_extensionality;move=> x.
  - move=> [i lti]; fcrush.
Qed.

Lemma FO_NoQuant_Correct_Lem_0
  {exiV uniV}
  (f: @ZerothOrderFormulaVS exiV 0 uniV emptyTuple)
  (adv : @NoQuantAdvice D exiV 0 uniV emptyTuple)
  (M : Sigma11Model D) (r : T D) :
  forall u,
  NoQuantZODenotation D f (AddModelV D M r) adv u <->
  NoQuantZODenotation D (PropTermVSLiftExi f) M (AdviceExiExtend r adv) u.
Proof.
  elim: f; try qauto.
  move=> p1 p2 u.
  simpl.
  by do 2 rewrite FO_NoQuant_Correct_Lem_0_0.
Qed.

Lemma FO_NoQuant_Correct_Lem_1
  {exiV uniV}
  (adv : @NoQuantAdvice D exiV 0 uniV emptyTuple)
  (p : @PolyTermVS 0 0 0 emptyTuple)
  (M : Sigma11Model D) :
  forall u,
  PolyVSDenotation D (PolyTermVSCastFO p) M adv u
  = (PolyVSDenotation0 p M).
Proof.
  move=> u; elim p; try qauto.
  - move=> [n ltn]; fcrush.
  - move=> [n ltn]; fcrush.
  - move=> i a t IH.
    unfold PolyVSDenotation0; simpl.
    do 2 f_equal.
    apply functional_extensionality;move=> x.
    qauto.
  - move=> [i lti]; fcrush.
Qed.

(* Lemma FO_NoQuant_Correct_Lem_2
  (p : PolyTerm) (f : FirstOrderFormula) (M : Sigma11Model D) a r
  (t : {n : nat | n < FOUni f} -> T D) :
  UProp D (FO_NoQuant f) (AddModelV D M r) a t <->
  UProp D (FO_NoQuant (FOExists p f)) M (AdviceExiExtend r a) t.
Proof.
  unfold UProp; simpl; split=> H i.
  - rewrite <- FO_NoQuant_Correct_Lem_0_0.
    apply (H i).
  - rewrite FO_NoQuant_Correct_Lem_0_0.
    apply (H i).
Qed. *)

Lemma FO_NoQuant_Correct_NoQuantSOBoundCondition
  (p : PolyTerm) (f : FirstOrderFormula) (M : Sigma11Model D) a :
  NoQuantSOBoundCondition D (FO_NoQuant f) M a.
Proof. move=> u [i lti]; fcrush. Qed.

Lemma FO_NoQuant_Correct_NoQuantFormulaCondition_Exi
  (p : PolyTerm) (f : FirstOrderFormula) (M : Sigma11Model D) a r :
  NoQuantFormulaCondition D (FO_NoQuant f) (AddModelV D M r) a <->
  NoQuantFormulaCondition D (FO_NoQuant (FOExists p f)) M (AdviceExiExtend r a).
Proof. split; move=> H u; by apply FO_NoQuant_Correct_Lem_0. Qed.

(*
Lemma FO_NoQuant_Correct_NoQuantFOBoundCondition_Exi
  (p : PolyTerm) (f : FirstOrderFormula) (M : Sigma11Model D) a r :
  (NoQuantFOBoundCondition D (FO_NoQuant f) (AddModelV D M r) a) <->
  NoQuantFOBoundCondition D (FO_NoQuant (FOExists p f)) M (AdviceExiExtend r a).
Proof.
  split.
  - move=> H0 [i lti] u n0.
    destruct (i == 0) eqn:ei0.
    + simpl; unfold ExtendAt0N.
      do 2 (rewrite dep_if_case_true; auto).
      unfold NoQuantFOBoundCondition in H0.
       *)

Program Definition FO_NoQuant_Correct_Lem_2_0 {exiV uniV i}
  {lti lti2 : i < exiV}
  {nuF : {n : nat | n < exiV} -> {m : nat | m <= uniV}}
  (v : {n : nat | n < uniV - ` (nuF (exist _ i lti))} -> T D) :
  {n : nat | n < uniV - ` (nuF (exist _ i lti2))} -> T D := v.
Next Obligation.
  by replace lti with lti2;[|apply eq_irrelevance].
Qed.

Program Definition FO_NoQuant_Correct_Lem_2
  (p : PolyTerm) (f : FirstOrderFormula) (M : Sigma11Model D) a r i
  (lti : i.+1 < (FOExi f).+1)
  (t : {n : nat | n < FOUni f} -> T D)
  (u : U D (FO_NoQuant (FOExists p f)) M (AdviceExiExtend r a)
      (exist (fun n : nat => n < (FOExi f).+1) i.+1 lti)) :
  U D (FO_NoQuant f) (AddModelV D M r) a
      (exist (fun n : nat => n < FOExi f) i lti) := u.
Next Obligation.
  unfold ExtendAt0N; simpl.
  replace (` ((` (nu (FO_NoQuant f))) _))
     with (` ((` (nu (FO_NoQuant f))) (exist _ i lti))); auto.
  do 3 f_equal; apply proof_irrelevance.
Qed.
Next Obligation.
  destruct u as [u pu]; simpl in *.
  unfold ExtendAt0N in *; simpl in *.
  pose lti2 := (Utils.ExtendAt0N_obligation_2 (FOExi f) (exist _ i.+1 lti) (erefl _)).
  assert (lti2 = lti) as e;[apply proof_irrelevance|].
  assert (j < ` ((` (nu (FO_NoQuant f))) (exist _ i lti2))) as ltj;[by rewrite e|].
  remember (pu (exist _ j ltj) (FO_NoQuant_Correct_Lem_2_0 v)) as pu'; clear Heqpu' pu.
  remember (InBound _ _ _ _ _ _) as A1.
  replace (InBound _ _ _ _ _ _) with A1;[auto|].
  rewrite HeqA1; clear pu' HeqA1 A1.
  f_equal.
  unfold InBound; simpl.
  remember (U_obligation_1 _ _ _ _ _ _ _ _ _ _) as DD0; clear HeqDD0.
  remember (U_obligation_1 _ _ _ _ _ _ _ _ _ _) as DD1; clear HeqDD1.
  simpl in *.
  rewrite <- FO_NoQuant_Correct_Lem_0_0.
  remember (PolyVSDenotation _ _ _ _ _) as P1.
  remember (PolyVSDenotation D (uniVBounds (FO_NoQuant f) (exist _ j DD1)) _ a _) as P2.
  replace P1 with P2.
  destruct P2; simpl; auto.
  by do 2 f_equal; apply subset_eq_compat.
  rewrite HeqP1 HeqP2; clear HeqP1 HeqP2 P1 P2.
  f_equal.
  by f_equal; apply subset_eq_compat.
  unfold MakeU.
  apply functional_extensionality=> x.
  simpl.
  f_equal.
  unfold TupConcat.
  remember (Utils.ExtendAt0N_obligation_2 _ _ _ ) as DD2.

  destruct e.
  reflexivity.
  f_equal.
  rewrite <- e.
  f_equal.
  replace (MakeU (fun x => u (exist _ (` x)
             (FO_NoQuant_Correct_Lem_2_obligation_1 p f i lti x))) v)
  with (MakeU u (FO_NoQuant_Correct_Lem_2_0 v)).
  replace DD0 with DD1;[|apply eq_irrelevance].
  remember (PolyVSDenotation _ _ _ _ _) as P1.
  remember (PolyVSDenotation D
    (uniVBounds (FO_NoQuant f) (exist (fun n : nat => n < FOUni f) j DD1))
    (AddModelV D M r) a (MakeU u (FO_NoQuant_Correct_Lem_2_0 v))) as P2.
  rewrite <- HeqP1.
  remember (PolyVSDenotation _ _ _ _ _) as P2.
  rewrite PM.

PolyVSDenotation D
  (uniVBounds (FO_NoQuant f) (exist (fun n : nat => n < FOUni f) j DD1))
  (AddModelV D M r) a (MakeU u (FO_NoQuant_Correct_Lem_2_0 v))
PolyVSDenotation D
  (uniVBounds (FO_NoQuant f) (exist (fun n : nat => n < FOUni f) j DD1))
  (AddModelV D M r) a (MakeU u (FO_NoQuant_Correct_Lem_2_0 v))

  f_equal.
  simpl.
  unfold PolyTermVSLiftExi.
  destruct e.

  f_equal.
  unfold InBound in *.

Check (exist (fun n0 : nat => n0 < FOExi f) i lti).

Program Definition FO_NoQuant_Correct_Lem_2_0 {exiV} {uniV}
  {lti lti2 : i.+1 < eviV}
  (nuF : {n : nat | n < exiV} -> {m : nat | m <= uniV})
  (v : {n : nat | n < uniV - ` (nuF (exist _ i lti))} -> T D) :
  {n : nat | n < uniV - ` (nuF (exist _ i lti2))} -> T D := v.

  unfold InBound.
  remember (U_obligation_1 _ _ _ _ _ _ _ _ _ _) as DD0; clear HeqDD0.
  simpl.
  rewrite e in v.
  destruct v as [v ltv].
  rewrite e in H.

Lemma FO_NoQuant_Correct_NoQuantFOBoundCondition_Exi
  (p : PolyTerm) (f : FirstOrderFormula) (M : Sigma11Model D) a r :
  ((forall n, InBound D M (AdviceExiExtend r a) r (PolyTermVSCastFO (PolyTerm_PolyTermVS p)) n)
   /\ NoQuantFOBoundCondition D (FO_NoQuant f) (AddModelV D M r) a) <->
  NoQuantFOBoundCondition D (FO_NoQuant (FOExists p f)) M (AdviceExiExtend r a).
Proof.
  split.
  - move=> [H0 H1] [i lti] u n0.
    destruct (i == 0) eqn:ei0.
    + simpl; unfold ExtendAt0N.
      do 2 (rewrite dep_if_case_true; auto).
    + destruct i;[fcrush|clear ei0].
      simpl in n0; unfold ExtendAt0N in n0; simpl in n0.
      remember (H0 (MakeU (` u) n0)) as H0'; clear HeqH0' H0; simpl in H0'.
      unfold NoQuantFOBoundCondition in H1.
      remember (H1 (exist _ i lti)) as H1'; clear HeqH1' H1.
      simpl in lti.
      unfold U in u; simpl in u.
      unfold ExtendAt0N in *; simpl in *.
      assert (lti = (Utils.ExtendAt0N_obligation_2 (FOExi f) (exist _ i.+1 lti) (erefl
        (exist _ i.+1 lti == exist _ 0 is_true_true)))) as e;[apply eq_irrelevance|].
      clear H0'.
      rewrite e in u.
      destruct u as [u pu]; simpl in *.
      rewrite e in n0.
      unfold InBound in *.
      destruct u as [u pu]; simpl in *.
      unfold ExtendAt0N; simpl.
      change (exist _ ?x _ == exist _ ?y _) with (x == y) in *.
      rewrite FO_NoQuant_Correct_Lem_1 in H0'.
      rewrite <- FO_NoQuant_Correct_Lem_0_0.
      destruct (FO_NoQuant f); simpl.
      remember (Utils.ExtendAt0N_obligation_2 (FOExi f)
             (exist (fun n : nat => n < (FOExi f).+1) i.+1 lti)
             (erefl (i.+1 == 0))) as DD0.

      assert (lti = (Utils.ExtendAt0N_obligation_2 (FOExi f) (exist _ i.+1 lti) (erefl
        (exist _ i.+1 lti == exist _ 0 is_true_true)))) as e;[apply eq_irrelevance|].

(exist (fun n1 : nat => n1 < FOExi f) i
          (Utils.ExtendAt0N_obligation_2 (FOExi f)
             (exist (fun n : nat => n < (FOExi f).+1) i.+1 lti)
             (erefl (i.+1 == 0))))) (AddModelV D M r) a
      destruct M; unfold AddModelV.
      unfold ExtendAt0.
      simpl.
      auto.
      apply
      simpl in n1.
      remember (` ((` (nu (FO_NoQuant f))) _)) as nn.
      assert (nn <= FOUni f);[by destruct ((` (nu (FO_NoQuant f))) _); rewrite Heqnn|].
      assert ({n : nat | n < FOUni f} -> T D) as n1.
        move=>[n ltn].
        destruct (n < FOUni f - nn) eqn:nlt2.
        apply n0.
        exists n.
        clear Heqnn u lti H0 H1; sfirstorder.
        exact 0%R.
      remember (H0 n1) as H0'. ; clear HeqH0' H0; simpl in H0'.

      remember (MakeU n0 (fun x => 0%R)) as n1.

      assert (forall n, n < FOUni f - nn -> n < FOUni f) as d.
        clear u; hecrush use: leq_trans, ltn_subrR, contraFltn unfold: is_true.
      assert ({n : nat | n < FOUni f} -> T D) as n1.
      move=> [n ltn].
      assert (n < FOUni f - nn).

      simpl; unfold ExtendAt0N; simpl.

      remember (fun x : {n : nat | n < FOUni f} =>
                )
        exists 0.
        unfold ExtendAt0N; simpl.
      cbn.
      auto.
      simpl in *.
      destruct u as [u ltu]; simpl in *.
      unfold ExtendAt0N in *; simpl in *.
      remember (exist (fun n1 : nat => n1 < FOExi f) i
        (Utils.ExtendAt0N_obligation_2 (FOExi f)
           (exist (fun n : nat => n < (FOExi f).+1) i.+1 lti)
           (erefl
              (exist (fun n : nat => n < (FOExi f).+1) i.+1 lti ==
               exist (fun x : nat => x < (FOExi f).+1) 0 is_true_true)))) as e1.

      unfold U in u; simpl in u.
      unfold ExtendAt0N in *; simpl in *.
      destruct ((` (nu (FO_NoQuant f)))
           (exist (fun n0 : nat => n0 < FOExi f) i
              (Utils.ExtendAt0N_obligation_2 (FOExi f)
                 (exist (fun n0 : nat => n0 < (FOExi f).+1) i.+1 lti)
                 (erefl
                    (exist (fun n0 : nat => n0 < (FOExi f).+1) i.+1 lti ==
                     exist (fun x : nat => x < (FOExi f).+1) 0 is_true_true)))))

      remember (Utils.ExtendAt0N_obligation_2
                        (FOExi f)
                        (exist (fun n0 : nat => n0 < (FOExi f).+1) i.+1 lti)
                        (erefl
                           (exist (fun n0 : nat => n0 < (FOExi f).+1) i.+1
                              lti ==
                            exist (fun x : nat => x < (FOExi f).+1) 0
                              is_true_true))) as DDD.
      unfold InBound.
      simpl.
      unfold ExtendAt0N; rewrite dep_if_case_true; auto.
; rewrite FO_NoQuant_Correct_Lem_1.
      clear n u.
      destruct u as [u ltu]; simpl.
      destruct (FO_NoQuant f); simpl in *.
      unfold ExtendAt0N in ltu.
      change (exist _ ?x _ == exist _ ?y _) with (x == y) in *.
      rewrite FO_NoQuant_Correct_Lem_1.
      destruct u as [u ltu].
      simpl in *.

      assert i <

      rewrite
    destruct n as [n ltn].
    rewrite dep_if_case_true; auto.

    move

Lemma FO_NoQuant_Correct_NoQuantExiStratCondition_Exi
  (p : PolyTerm) (f : FirstOrderFormula) (M : Sigma11Model D) a r :
  NoQuantExiStratCondition D (FO_NoQuant f) (AddModelV D M r) a <->
  NoQuantExiStratCondition D (FO_NoQuant (FOExists p f)) M (AdviceExiExtend r a).
Proof.
  split;move=> H.
  - unfold NoQuantExiStratCondition in *.
    move=> i m.
    destruct i as [i lti]; simpl.
    destruct (i == 0) eqn:ei0.
    + exists r;move=> n.
      unfold ExtendAt0N; simpl; rewrite dep_if_case_true; auto.
    + assert (i.-1 < FOExi f) as lti2. destruct i;[fcrush|auto].
      remember (H (exist _ (i.-1) lti2)) as H'; clear HeqH' H.
      assert (ExtendAt0N 0 (fun x => ` ((` (nu (FO_NoQuant f))) x)) (exist _ i lti) =
              ` ((` (nu (FO_NoQuant f))) (exist (fun n0 : nat => n0 < FOExi f) i.-1 lti2))) as e.
        unfold ExtendAt0N.
        rewrite dep_if_case_false.
        do 3 f_equal; apply eq_irrelevance.
      remember (H' (eq_rect _ (fun x => |[x]| -> T D) m _ e)) as H; clear HeqH H'.
      destruct H as [C H].
      exists C; move=> n.
      unfold ExtendAt0N; rewrite dep_if_case_false; auto; simpl.
      remember (H (eq_rect _ (fun x => |[FOUni f - x]| -> T D) n _ e)) as H'; clear HeqH' H.
      destruct a; simpl in *.
      change (exist _ ?x _ == exist _ ?y _) with (x == y) in *.
      remember (exiVAdv0 _ _) as A1.
      remember (exiVAdv0 (exist _ i.-1 (Utils.ExtendAt0N_obligation_2 _ (exist _ i lti) _)) _) as A2.
      replace A2 with A1; auto.
      rewrite HeqA1; rewrite HeqA2; clear HeqA1 HeqA2.
      f_equal;[f_equal; apply eq_irrelevance|].
      apply functional_extensionality;move=> x.
      remember (NoQuantExiStratCondition_obligation_1 _ _ _ _ _ _ _ _ _ _) as DD0; clear HeqDD0.
      remember (NoQuantExiStratCondition_obligation_1 _ _ _ _ _ _ _ _ _ _) as DD1; clear HeqDD1.
      destruct e.
      by f_equal; apply subset_eq_compat.
  - unfold NoQuantExiStratCondition in *.
    move=> i m.
    simpl in H.
    destruct i as [i lti].
    remember (H (exist _ (i.+1) lti)) as H'; clear HeqH' H.
    unfold ExtendAt0N in H'; simpl in H'.
    assert (lti = Utils.ExtendAt0N_obligation_2  (FOExi f) (exist _ i.+1 lti)
                      (erefl (exist _ i.+1 lti == exist _ 0 is_true_true))) as e;[apply eq_irrelevance|].
    remember (H' (eq_rect _ (fun x => |[ ` ((` (nu (FO_NoQuant f))) (exist _ i x))]| -> T D) m _ e)) as H; clear HeqH H'.
    destruct H as [C H].
    exists C; move=> n.
    remember (H (eq_rect _ (fun x => |[FOUni f - ` ((` (nu (FO_NoQuant f))) (exist _ i x))]| -> T D) n _ e)) as H'; clear HeqH' H.
    destruct a; simpl in *.
    remember (exiVAdv0 _ _) as A1.
    remember (exiVAdv0 (exist _ i lti) _) as A2.
    replace A2 with A1; auto.
    rewrite HeqA1; rewrite HeqA2; clear HeqA1 HeqA2.
    f_equal;[f_equal; apply eq_irrelevance|].
    apply functional_extensionality;move=> x.
    remember (NoQuantExiStratCondition_obligation_1 _ _ _ _ _ _ _ _ _ _) as DD0; clear HeqDD0.
    remember (NoQuantExiStratCondition_obligation_1 _ _ _ _ _ _ _ _ _ _) as DD1; clear HeqDD1.
    remember (exist _ (` x) DD0) as E0; destruct E0; apply EqdepFacts.eq_sig_fst in HeqE0.
    remember (exist _ (` x) DD1) as E1; destruct E1; apply EqdepFacts.eq_sig_fst in HeqE1.
    destruct HeqE0, HeqE1, e.
    by f_equal; apply subset_eq_compat.
Qed.

(*
Lemma FO_NoQuant_Correct_NoQuantFormulaCondition_Uni
  (f : FirstOrderFormula) (M : Sigma11Model D) a r :
  NoQuantFormulaCondition D (FO_NoQuant f) (AddModelV D M r) a <->
  NoQuantFormulaCondition D (FO_NoQuant (FOForall p f)) M (AdviceExiExtend r a).

Lemma FO_NoQuant_Correct_NoQuantFOBoundCondition_Uni
  (f : FirstOrderFormula) (M : Sigma11Model D) a r :
  NoQuantFOBoundCondition D (FO_NoQuant f) (AddModelV D M r) a <->
  NoQuantFOBoundCondition D (FO_NoQuant (FOForall p f)) M (AdviceExiExtend r a).

Lemma FO_NoQuant_Correct_NoQuantSOBoundCondition_Uni
  (f : FirstOrderFormula) (M : Sigma11Model D) a r :
  NoQuantSOBoundCondition D (FO_NoQuant f) (AddModelV D M r) a <->
  NoQuantSOBoundCondition D (FO_NoQuant (FOForall p f)) M (AdviceExiExtend r a).

Lemma FO_NoQuant_Correct_NoQuantExiStratCondition_Uni
  (f : FirstOrderFormula) (M : Sigma11Model D) a r :
  NoQuantExiStratCondition D (FO_NoQuant f) (AddModelV D M r) a <->
  NoQuantExiStratCondition D (FO_NoQuant (FOForall p f)) M (AdviceExiExtend r a). *)

Lemma FO_NoQuant_Correct_Lem_3_0
  (f : ZerothOrderFormula) (M : Sigma11Model D) a
  (H0 : NoQuantFormulaCondition D (ZO_NoQuant f) M a)
  (H1 : NoQuantFOBoundCondition D (ZO_NoQuant f) M a)
  (H2 : NoQuantSOBoundCondition D (ZO_NoQuant f) M a)
  (H3 : NoQuantExiStratCondition D (ZO_NoQuant f) M a) :
  (exists (t : |[0]| -> T D), UProp D (ZO_NoQuant f) M a t) \/
  ZerothOrder_Denote D f M.
Proof.
  right.
  apply ZO_NoQuant_Correct.
  unfold NoQuantDenotation.
  exists a; auto.
Qed.

(* Lemma FO_NoQuant_Correct_Lem_3
  (f : FirstOrderFormula) (M : Sigma11Model D) a
  (H0 : NoQuantFormulaCondition D (FO_NoQuant f) M a)
  (H1 : NoQuantFOBoundCondition D (FO_NoQuant f) M a)
  (H2 : NoQuantSOBoundCondition D (FO_NoQuant f) M a)
  (H3 : NoQuantExiStratCondition D (FO_NoQuant f) M a) :
  (exists (t : |[FOUni f]| -> T D), UProp D (FO_NoQuant f) M a t) \/
  FirstOrder_Denote D f M.
Proof.
  induction f; simpl in *.
  - apply FO_NoQuant_Correct_Lem_3_0; auto.
  - left.

Admitted. *)

(*

Lemma FO_NoQuant_Correct_Lem_3
  {exiV uniV}
  (p : @PolyTermVS 0 0 0 emptyTuple)
  (q : @NoQuant exiV 0 uniV emptyTuple)
  (i : nat) (H : (i == 0) = false) (lti : i < exiV.+1) (lti2 : i.-1 < exiV) :
  ` ((` (nu q)) (exist _ i.-1 lti2)) =
  ` ((` (nu (NoQuantAddExi p q))) (exist _ i lti)).
Proof.
  destruct q; simpl.
  unfold ExtendAt0N.
  rewrite dep_if_case_false.
  simpl.
  do 3 f_equal; apply eq_irrelevance.
Qed.

Lemma FO_NoQuant_Correct_Lem_4
  {exiV uniV}
  (q : @NoQuant exiV 0 uniV emptyTuple)
  (i : nat) (H : (i == 0) = false) (lti : i < exiV.+1) (lti2 : i.-1 < exiV) :
  uniV - ` ((` (nu q)) (exist _ i.-1 lti2)) =
  uniV - ExtendAt0N 0
          (fun x : {n0 : nat | n0 < exiV} => ` ((` (nu q)) x))
          (exist _ i lti).
Proof.
  unfold ExtendAt0N.
  rewrite dep_if_case_false; auto.
  simpl.
  remember (Utils.ExtendAt0N_obligation_2 _ _ _) as D0.
  simpl in D0.
  by replace D0 with lti2;[|apply eq_irrelevance].
Qed. *)

(*
n < uniV - ` ((` (nu q)) (exist _ i.-1 lti2))
uniV - ExtendAt0N 0
        (fun x : {n0 : nat | n0 < exiV} => ` ((` (nu q)) x))
        (exist _ i lti)
 *)

(* Lemma FO_NoQuant_Correct_Lem_1
  {exiV uniV}
  (b : @PolyTermVS 0 0 0 emptyTuple)
  (adv : @NoQuantAdvice D exiV 0 uniV emptyTuple)
  (p : @NoQuant exiV 0 uniV emptyTuple)
  (M : Sigma11Model D) (r : T D) :
  forall u i,
    PolyVSDenotation D
      (exiVBounds (NoQuantAddExi b p) i) M
      (AdviceExiExtend r adv) u =
    PolyVSDenotation D (exiVBounds p (fSeqRest i)) (AddModelV D M r) adv u. *)

Theorem FO_NoQuant_Correct (p : FirstOrderFormula) (M : Sigma11Model D) :
  FirstOrder_Denote D p M <-> NoQuantDenotation D (FO_NoQuant p) M.
Proof.
  move: M; elim: p.
  - apply ZO_NoQuant_Correct.
  - move=> p f IH M.
    split.
    + move=> H.
      simpl.
      unfold NoQuantDenotation.
      simpl in H.
      remember (Poly_Denote D p M) as PM.
      destruct PM;[|fcrush].
      destruct H as [r [ltrs fd]].
      apply ((IH (AddModelV D M r)).1) in fd; clear IH.
      unfold NoQuantDenotation in fd.
      destruct fd as [adv [H0 [H1 [H2 H3]]]].
      apply (FO_NoQuant_Correct_NoQuantFormulaCondition_Exi p) in H0.
      apply (FO_NoQuant_Correct_NoQuantSOBoundCondition_Exi p) in H2.
      apply (FO_NoQuant_Correct_NoQuantExiStratCondition_Exi p) in H3.
      exists (AdviceExiExtend r adv).
      split;[|split;[|split]];auto.
      * clear H0 H2 H3.
        move=> u i.
        simpl.
        unfold ExtendAt0N.
        destruct i as [i lti].
        dep_if_case (i == 0); auto.
        ++ rewrite dep_if_case_true; simpl; auto.
           rewrite FO_NoQuant_Correct_Lem_1.
           rewrite <- PolyTerm_PolyTermVS_Correct.
           by rewrite <- HeqPM.
        ++ rewrite <- FO_NoQuant_Correct_Lem_0_0.
           rewrite dep_if_case_false; simpl.
           remember (exist (fun n0 : nat => n0 < FOExi f) i.-1 _) as i'.
           destruct u as [u uH]; simpl.
           apply FO_NoQuant_Correct_Lem_2 in uH.
           apply (H1 (exist _ u uH) i').
    + move=> H.
      destruct H as [adv [H0 [H1 [H2 H3]]]].
      (* remember (FO_NoQuant_Correct_Lem_3 _ M adv H0 H1 H2 H3) as DI; clear HeqDI.
      destruct DI; auto. *)
      simpl.
      remember (Poly_Denote D p M) as PM;destruct PM.
      simpl in *.
      unfold NoQuantExiStratCondition in H3.
      destruct (H3 (exist _ 0 (leq0n (FOExi f))) emptyTuple) as [X PX].
      exists X.
      split.
        clear H0 H2.
        unfold NoQuantAddExi in *; simpl in *.
        simpl in PX; unfold ExtendAt0N in PX; simpl in PX.
        unfold NoQuantFOBoundCondition in H1.
        assert (U D {|
                nu :=
                  exist (fun s => forall i j, ` i <= ` j -> ` (s i) <= ` (s j))
                    (fun x => exist _
                       (ExtendAt0N 0 (fun x0 => ` ((` (nu (FO_NoQuant f))) x0)) x)
                       (NoQuantAddExi_obligation_1
                          (FOExi f) (FOUni f) (FO_NoQuant f) x))
                    (fun i j => [eta NoQuantAddExi_obligation_2
                            (FOExi f) (FOUni f) (FO_NoQuant f) i j]);
                uniVBounds := fun x => PolyTermVSLiftExi (uniVBounds (FO_NoQuant f) x);
                exiVBounds :=
                  ExtendAt0N (PolyTermVSCastFO (PolyTerm_PolyTermVS p))
                    (fun x => PolyTermVSLiftExi (exiVBounds (FO_NoQuant f) x));
                exiFOutputBounds := emptyTuple;
                exiFInputBounds := emptyTuple;
                formula := PropTermVSLiftExi (formula (FO_NoQuant f))
              |} M adv) as u.
      2:{
        remember (H1 u) as H1'; clear HeqH1' H1.
        simpl in H1'.

 destruct H as [t ut]

      destruct HeqX.
      simpl in PXE.
      assert (ExtendAt0N 0 (fun x => ` ((` nu0) x)) (exist _ 0 (leq0n (FOExi f))) = 0) as D0.
      unfold ExtendAt0Nz
      exists ()

      simpl in H; unfold NoQuantDenotation in H.
      unfold NoQuantDenotation in *.
           simpl.

           destruct (FO_NoQuant f)
           remember (ExtendAt0N 0 (fun x0 => ` ((` nu0) x0)) (exist _ i lti)) as G.
           remember ((fun x0 => m
     (exist
        (fun n0 : nat =>
         n0 <
         ExtendAt0N 0
           (fun x1 : {n1 : nat | n1 < FOExi f} => ` ((` (nu (FO_NoQuant f))) x1))
           (exist (fun n1 : nat => n1 < (FOExi f).+1) i lti))
        (` x0)
        (FO_NoQuant_Correct_Lem_3 (PolyTerm_PolyTermVS p)
           (FO_NoQuant f) i ei0 lti lti2 (` x0) (ssrfun.svalP x0))))) as m2.
           f_equal.
           f_equal.
           Check TupConcat.
           cbn.
           unfold TupConcat.
           f_equal.
           rewrite ei0.
           f_equal.
           rewrite HeqA2; clear HeqA2.
           unfold exiVAdv0.
           remember (Utils.ExtendAt0N_obligation_2 _ _).
           unfold exiVAdv.
           move: n.
           unfold ExtendAt0N.
           change (exist _ ?x _ == exist _ ?y _) with (x == y).
           rewrite dep_if_case_false.
           Check (fun x : {n : nat
            | n <
              `
              ((` (nu (FO_NoQuant f)))
                 (exist (fun n0 : nat => n0 < FOExi f) i.-1 lti2))}
          => m (exist _ (projT1 x) (FO_NoQuant_Correct_Lem_3 _ _ i lti lti2 (projT1 x) (projT2 x)))).
           apply le
           simpl in *.

unfold ExtendAt0N; simpl; rewrite dep_if_case_false; auto.
        destruct m.
        rewrite EEConvert in ei0.
        Check (FO_NoQuant_Correct_Lem_3 (n := FOExi f)
          (P := fun b n i m =>
            forall n : {n : nat | n < FOUni f - ` ((` (nu (FO_NoQuant f))) i)} -> T D,
                  exiVAdv D adv i
                    (fun x : {n0 : nat | n0 < FOUni f} =>
                      TupConcat m n
                        (exist
                          (fun n0 : nat =>
                            n0 <
                            ` ((` (nu (FO_NoQuant f))) i) +
                            (FOUni f - ` ((` (nu (FO_NoQuant f))) i)))
                          (` x)
                          (NoQuantExiStratCondition_obligation_1 D (FOExi f) 0 emptyTuple
                              (FOUni f) (FO_NoQuant f) i m n x))) = b)
          r H3).
        Search (_ -> ex _).
        Search ex.
        remember (fun x y => ex_proj1 (H3 x y) : forall (i : {n : nat | n < FOExi f})
       (m : {n : nat | n < ` ((` (nu (FO_NoQuant f))) i)} -> T D), T D).
        Check (fun x y => exists_inhabited _ (H3 x y)).
        Check (FO_NoQuant_Correct_Lem_3 r (fun x y => ex_proj1 (H3 x y))).

        Check (ExtendAt0N
                (fun _ => r)
                (fun (i0 : {n : nat | n < FOExi f})
                     (m0 : {n : nat | n < ` ((` (nu (FO_NoQuant f))) i0)} -> T D)
                => ` (H3 i0 m0)) i m).
        exists r.
        move=> n.
        simpl.
        unfold ExtendAt0N.
        destruct i as [i lti].
        dep_if_case (i == 0); auto.
        simpl.
        unfold exiVAdv.

          destruct u; simpl.

          assert (
          apply (H1 u i').
          apply H1.
          rewrite H.
PolyVSDenotation D (PolyTermVSCastFO (PolyTerm_PolyTermVS p)) M
    (AdviceExiExtend r adv) (` u) =
PolyVSDenotation D

        replace
          (PolyVSDenotation D
            (exiVBounds (NoQuantAddExi (PolyTerm_PolyTermVS p) (FO_NoQuant f)) i) M
            (AdviceExiExtend r adv) (` u))
        with
          (PolyVSDenotation D (exiVBounds (FO_NoQuant f) i) (AddModelV D M r) adv (` u)).
        simpl.

        simpl.
        unfold U in u.
        rewrite <- FO_NoQuant_Correct_Lem_0_0.

        Set Printing Implicit.

        move: H0'; elim: formula0.
        intro z.
        move=> IH ca.
        simpl in ca.
        simpl.
        clear exiFInputBounds0.

      2:{

    cbn.

Program Fixpoint LiftPolyExi
  {exiV exiF} {exiFA : |[exiF]| -> nat}
  {uniV}
  (p : PolyTerm) :
  @PolyTerm (exiV.+1) exiF exiFA uniV :=
  match p with
  | PolyFVar m => PolyFVar m
  | PolyEVar m => PolyEVar m.+1
  | PolyUVar m => PolyUVar m
  | PolyFFun i t => PolyFFun i (fun x => LiftPolyExi (t x))
  | PolyEFun i t => PolyEFun i (fun x => LiftPolyExi (t x))
  | PolyMinusOne => PolyMinusOne
  | PolyPlusOne => PolyPlusOne
  | PolyZero => PolyZero
  | PolyPlus r1 r2 => PolyPlus (LiftPolyExi r1) (LiftPolyExi r2)
  | PolyTimes r1 r2 => PolyTimes (LiftPolyExi r1) (LiftPolyExi r2)
  | PolyInd r1 r2 => PolyInd (LiftPolyExi r1) (LiftPolyExi r2)
  end.

Program Fixpoint LiftPolyUni
  {exiV exiF} {exiFA : |[exiF]| -> nat}
  {uniV}
  (p : PolyTerm) :
  @PolyTerm exiV exiF exiFA (uniV.+1) :=
  match p with
  | PolyFVar m => PolyFVar m
  | PolyEVar m => PolyEVar m
  | PolyUVar m => PolyUVar m.+1
  | PolyFFun i t => PolyFFun i (fun x => LiftPolyUni (t x))
  | PolyEFun i t => PolyEFun i (fun x => LiftPolyUni (t x))
  | PolyMinusOne => PolyMinusOne
  | PolyPlusOne => PolyPlusOne
  | PolyZero => PolyZero
  | PolyPlus r1 r2 => PolyPlus (LiftPolyUni r1) (LiftPolyUni r2)
  | PolyTimes r1 r2 => PolyTimes (LiftPolyUni r1) (LiftPolyUni r2)
  | PolyInd r1 r2 => PolyInd (LiftPolyUni r1) (LiftPolyUni r2)
  end.

Fixpoint LiftPropExi
  {exiV exiF} {exiFA : |[exiF]| -> nat}
  {uniV}
  (p : ZerothOrderFormula) :
  @ZerothOrderFormula (exiV.+1) exiF exiFA uniV :=
  match p with
  | ZONot f => ZONot (LiftPropExi f)
  | ZOAnd f1 f2 => ZOAnd (LiftPropExi f1) (LiftPropExi f2)
  | ZOOr f1 f2 => ZOOr (LiftPropExi f1) (LiftPropExi f2)
  | ZOImp f1 f2 => ZOImp (LiftPropExi f1) (LiftPropExi f2)
  | ZOEq r1 r2 => ZOEq (LiftPolyExi r1) (LiftPolyExi r2)
  end.

Fixpoint LiftPropUni
  {exiV exiF} {exiFA : |[exiF]| -> nat}
  {uniV}
  (p : ZerothOrderFormula) :
  @ZerothOrderFormula exiV exiF exiFA (uniV.+1) :=
  match p with
  | ZONot f => ZONot (LiftPropUni f)
  | ZOAnd f1 f2 => ZOAnd (LiftPropUni f1) (LiftPropUni f2)
  | ZOOr f1 f2 => ZOOr (LiftPropUni f1) (LiftPropUni f2)
  | ZOImp f1 f2 => ZOImp (LiftPropUni f1) (LiftPropUni f2)
  | ZOEq r1 r2 => ZOEq (LiftPolyUni r1) (LiftPolyUni r2)
  end.

Program Definition AddExiVBound
  {exiV exiF} {exiFA : |[exiF]| -> nat}
  {uniV}
  (p : PolyTerm)
  (n : @NoQuant exiV exiF uniV exiFA) :
  @NoQuant (exiV.+1) exiF exiFA uniV :=
  {| nu := ExtendAt0N (uniV) (nu n)
   ; uniVBounds := fun x => LiftPolyExi (uniVBounds n x)
   ; exiVBounds := fun x => LiftPolyExi (ExtendAt0N p (exiVBounds n) x)
   ; exiFOutputBounds := fun x => LiftPolyExi (exiFOutputBounds n x)
   ; exiFInputBounds := fun x y => LiftPolyExi (exiFInputBounds n x y)
   ; formula := inrMap LiftPropExi (formula n)
  |}.
Next Obligation.
  unfold ExtendAt0N.
  dep_if_case (x == 0); auto.
  by destruct ((` (nu n)) _).
Qed.
Next Obligation.
  unfold ExtendAt0N.
  dep_if_case (j == 0); auto.
  rewrite dep_if_case_True; auto.
  destruct i;[auto|apply EEConvert.1 in H2;fcrush].
  dep_if_case (i == 0); auto.
  by destruct ((` (nu n)) _).
  by destruct (nu n); apply i0; destruct i, j.
Qed.

Program Definition AddUniVBound
  {exiV exiF} {exiFA : |[exiF]| -> nat}
  {uniV}
  (p : PolyTerm)
  (n : @NoQuant exiV exiF uniV exiFA) :
  @NoQuant exiV exiF exiFA (uniV.+1) :=
  {| nu := nu n
   ; uniVBounds := fun x => LiftPolyUni (ExtendAt0N p (uniVBounds n) x)
   ; exiVBounds := fun x => LiftPolyUni (exiVBounds n x)
   ; exiFOutputBounds := fun x => LiftPolyUni (exiFOutputBounds n x)
   ; exiFInputBounds := fun x y => LiftPolyUni (exiFInputBounds n x y)
   ; formula := inrMap LiftPropUni (formula n)
  |}.
Next Obligation. by destruct (` (nu n)); auto. Qed.
Next Obligation. by destruct nu; apply i0. Qed.

Fixpoint FOExiMod
  {exiV exiF} {exiFA : |[exiF]| -> nat}
  {uniV}
  (f : @FirstOrderFormula exiV exiF uniV exiFA) : nat :=
  match f with
  | ZO z => exiV
  | FOExists p f => FOExiMod f
  | FOForall p f => FOExiMod f
  end.

Fixpoint FOUniMod
  {exiV exiF} {exiFA : |[exiF]| -> nat}
  {uniV}
  (f : @FirstOrderFormula exiV exiF uniV exiFA) : nat :=
  match f with
  | ZO z => uniV
  | FOExists p f => FOUniMod f
  | FOForall p f => FOUniMod f
  end.

Fixpoint FO_NoQuant
  {exiV exiF} {exiFA : |[exiF]| -> nat}
  {uniV}
  (f : @FirstOrderFormula exiV exiF uniV exiFA)
  (n : @NoQuant exiV exiF uniV exiFA) :
  @NoQuant (FOExiMod f) exiF exiFA (FOUniMod f) :=
  match f with
  | ZO z => ZO_NoQuant z n
  | FOExists p f => FO_NoQuant f (AddExiVBound p n)
  | FOForall p f => FO_NoQuant f (AddUniVBound p n)
  end.

Program Fixpoint LiftPolyExiF
  {exiV exiF} {exiFA : |[exiF]| -> nat}
  {uniV}
  {a}
  (p : PolyTerm) :
  @PolyTerm exiV (exiF.+1) (ExtendAt0N a exiFA) uniV :=
  match p with
  | PolyFVar m => PolyFVar m
  | PolyEVar m => PolyEVar m
  | PolyUVar m => PolyUVar m
  | PolyFFun i t => PolyFFun i (fun x => LiftPolyExiF (t x))
  | PolyEFun i t => PolyEFun i.+1 (fun x => LiftPolyExiF (t x))
  | PolyMinusOne => PolyMinusOne
  | PolyPlusOne => PolyPlusOne
  | PolyZero => PolyZero
  | PolyPlus r1 r2 => PolyPlus (LiftPolyExiF r1) (LiftPolyExiF r2)
  | PolyTimes r1 r2 => PolyTimes (LiftPolyExiF r1) (LiftPolyExiF r2)
  | PolyInd r1 r2 => PolyInd (LiftPolyExiF r1) (LiftPolyExiF r2)
  end.
Next Obligation.
  unfold ExtendAt0N in H; simpl in H.
  remember (Utils.ExtendAt0N_obligation_2 _ _ _) as P; clear HeqP; simpl in P.
  by replace H0 with P;[|apply eq_irrelevance].
Qed.

Fixpoint LiftPropExiF
  {exiV exiF} {exiFA : |[exiF]| -> nat}
  {uniV}
  {a}
  (p : ZerothOrderFormula) :
  @ZerothOrderFormula exiV (exiF.+1) (ExtendAt0N a exiFA) uniV :=
  match p with
  | ZONot f => ZONot (LiftPropExiF f)
  | ZOAnd f1 f2 => ZOAnd (LiftPropExiF f1) (LiftPropExiF f2)
  | ZOOr f1 f2 => ZOOr (LiftPropExiF f1) (LiftPropExiF f2)
  | ZOImp f1 f2 => ZOImp (LiftPropExiF f1) (LiftPropExiF f2)
  | ZOEq r1 r2 => ZOEq (LiftPolyExiF r1) (LiftPolyExiF r2)
  end.

Program Definition AddExiFBound
  {exiV exiF} {exiFA : |[exiF]| -> nat}
  {uniV}
  (p : PolyTerm)
  (bs : seq (PolyTerm))
  (n : @NoQuant exiV exiF uniV exiFA) :
  @NoQuant exiV (exiF.+1) (ExtendAt0N (length bs) exiFA) uniV :=
  {| nu := nu n
   ; uniVBounds := fun x => LiftPolyExiF (a := length bs) (uniVBounds n x)
   ; exiVBounds := fun x => LiftPolyExiF (a := length bs) (exiVBounds n x)
   ; exiFOutputBounds := fun x => LiftPolyExiF (a := length bs) (ExtendAt0N p (exiFOutputBounds n) x)
   ; exiFInputBounds := fun i =>
    (if i == 0 as b return (i == 0) = b -> |[ExtendAt0N (length bs) exiFA i]| -> PolyTerm
    then fun _ j => LiftPolyExiF (lnth bs j)
    else fun _ j => LiftPolyExiF (exiFInputBounds n (i.-1) j)) (erefl _)
(* fun x y => LiftPolyExiF (ExtendAt0N (lnth bs) (exiFInputBounds n) x y) *)
   ; formula := inrMap LiftPropExiF (formula n)
  |}.
Next Obligation. by destruct i. Qed.
Next Obligation.
  unfold ExtendAt0N in H.
  change (exist _ ?x _ == exist _ ?y _) with (x == y) in *.
  remember (AddExiFBound_obligation_2 _ _ _ _ _ _ _ _ _ _ _) as P; clear HeqP; simpl in P.
  rewrite dep_if_case_False in H; simpl in H.
  remember (Utils.ExtendAt0N_obligation_2 _ _ _) as Q; clear HeqQ; simpl in Q.
  by replace P with Q;[|apply eq_irrelevance].
Qed.
Next Obligation.
  unfold ExtendAt0N in H.
  by rewrite dep_if_case_True in H.
Qed.

Fixpoint SOExiFMod
  {exiF} {exiFA : |[exiF]| -> nat}
  (f : @SecondOrderFormula exiF exiFA) : nat :=
  match f with
  | FO f => exiF
  | SOExists y bs f => SOExiFMod f
  end.

Fixpoint SOExiFAMod
  {exiF} {exiFA : |[exiF]| -> nat}
  (f : @SecondOrderFormula exiF exiFA) : |[SOExiFMod f]| -> nat :=
  match f with
  | FO _ => exiFA
  | SOExists y bs f => SOExiFAMod f
  end.

Fixpoint SOExiMod
  {exiF} {exiFA : |[exiF]| -> nat}
  (f : @SecondOrderFormula exiF exiFA) : nat :=
  match f with
  | FO f => FOExiMod f
  | SOExists y bs f => SOExiMod f
  end.

Fixpoint SOUniMod
  {exiF} {exiFA : |[exiF]| -> nat}
  (f : @SecondOrderFormula exiF exiFA) : nat :=
  match f with
  | FO f => FOUniMod f
  | SOExists y bs f => SOUniMod f
  end.

Fixpoint SO_NoQuant
  {exiF} {exiFA : |[exiF]| -> nat}
  (f : @SecondOrderFormula exiF exiFA)
  (n : @NoQuant 0 exiF exiFA 0) :
  @NoQuant (SOExiMod f) (SOExiFMod f) (SOExiFAMod f) (SOUniMod f) :=
  match f with
  | FO f => FO_NoQuant f n
  | SOExists y bs f => SO_NoQuant f (AddExiFBound y bs n)
  end.

End NoQuantTranslation.

Section NoQuantCorrect.

Variables D : RingData.

Program Definition ModelMance
  (M : @Sigma11Model D) : @NoQuantMance D :=
  {| freeVM := freeV_F D M
   ; freeFM := fun x => freeF_S D M x (freeFA x)
  |}.

Program Definition SONoQuant {exiF exiFA}
  exiFOutputBounds exiFInputBounds:
  @NoQuant 0 exiF exiFA 0 :=
  {| nu := emptyTuple
   ; uniVBounds := emptyTuple
   ; exiVBounds := emptyTuple
   ; exiFOutputBounds := exiFOutputBounds
   ; exiFInputBounds := exiFInputBounds
   ; formula := inl ()
  |}.

Fixpoint FOModelMod
  {exiV exiF} {exiFA : |[exiF]| -> nat}
  uniV
  (f : @FirstOrderFormula exiV exiF uniV exiFA) : Type :=
match f with
| ZO f => @Sigma11Model D
| FOExists p f => (|[uniV]| -> T D) -> FOModelMod uniV f
| FOForall p f => FOModelMod (uniV.+1) f
end.

Fixpoint SOModelMod
  {exiF exiFA}
  (f : @SecondOrderFormula exiF exiFA) : Type :=
match f with
| FO f => FOModelMod 0 f
| SOExists y bs f => ((|[length bs]| -> T D) -> option (T D)) -> SOModelMod f
end.

Arguments SecondOrderFormula _ _ _ _ _ : clear implicits.
Arguments FirstOrderFormula _ _ _ _ _ _ _ : clear implicits.

Theorem SO_NOQuant_Sound
  {exiF exiFA}
  (M : @Sigma11Model D)
  (f : @SecondOrderFormula exiF exiFA) ys bss :
  NoQuantDenotation D (SO_NoQuant f (SONoQuant ys bss)) (ModelMance M) ->
  SecondOrder_Denote D f M.
move: M.
induction f.
2:{
  intros M H.
  simpl in H.
  simpl.
  remember (Poly_Denote D y M) as D1.
  destruct D1.
  remember (option_tuple
    (fun m : {n : nat | n < length bs} => Poly_Denote D (lnth bs m) M)) as D2.
  destruct D2.
  destruct H as [[exiVAdv exiFAdv] [H0 [H1 [H2 H3]]]].
  assert (0 < SOExiFMod f).
  2:{
  remember (exiFAdv (exist _ 0 H)) as f0.
  replace (length bs)
     with (SOExiFAMod f (exist (fun n0 : nat => n0 < SOExiFMod f) 0 H)) in f0.
  replace (SOExiFAMod f (exist (fun n0 : nat => n0 < SOExiFMod f) 0 H))
     with (length bs) in f0.
  Search sig.
  Unset Printing Notations.
  clear HeqD2 s0 HeqD1 s H3 H2 H1 H0 exiFAdv exiVAdv M IHf bss ys y D.
  induction f; auto.
  unfold SOExiMod.
  remember (exiFAdv 0) as Cool.
  remember (ex_proj1 H) as adv.
  destruct y.
  unfold AddExiFBound.
Admitted.

Program Definition EmptyNoQuant {freeV freeF freeFA} : @NoQuant 0 0 emptyTuple 0 :=
  {| nu := emptyTuple
   ; uniVBounds := emptyTuple
   ; exiVBounds := emptyTuple
   ; exiFOutputBounds := emptyTuple
   ; exiFInputBounds := emptyTuple
   ; formula := inl ()
  |}.

Theorem SO_NOQuant_Sound_E {freeV freeF freeFA} (M : @Sigma11Model D)
  (f : @SecondOrderFormula 0 emptyTuple) :
  NoQuantDenotation D (SO_NoQuant f EmptyNoQuant) (ModelMance M) ->
  SecondOrder_Denote D f M.
Admitted.

Theorem SO_NOQuant_Complete_E {freeV freeF freeFA} (M : @Sigma11Model D)
  (f : @SecondOrderFormula 0 emptyTuple) :
  SecondOrder_Denote D f M ->
  NoQuantDenotation D (SO_NoQuant f EmptyNoQuant) (ModelMance M).
Admitted.

Theorem SO_NOQuant_Correct {freeV freeF freeFA} (M : @Sigma11Model D)
  (f : @SecondOrderFormula 0 emptyTuple) :
  SecondOrder_Denote D f M <->
  NoQuantDenotation D (SO_NoQuant f EmptyNoQuant) (ModelMance M).
Proof. qauto use: SO_NOQuant_Complete_E, SO_NOQuant_Sound_E. Qed.

End NoQuantCorrect.


Require Import Basics.
Require Import Paths.
Require Import HIT.
Require Import Polygraphs.
Require Import PolyMorphs.
Require Import Adjunction.

Definition Counit_inject (n : nat) (T : Type) :
  compose  (CounitA (S n) (Counit T n)) (injectPol (Forget T n) (ForgetA (Counit T n) (S n)))
           = (Counit T n).
Proof.
  destruct n.
  - simpl. exact 1.
  - simpl.
    unfold compose. apply funext. simple refine (eqMorphPushout _ _ _).
    + intro b1. reflexivity.
    + intro b2. simpl. reflexivity.
    + intros [a a']. simpl. exact ((concat_1p _)).
Defined.

Lemma Forget_composeM (n : nat) ( T T' T'' : Type) (f : T -> T') (f' : T' -> T'') :
  ComposeM (ForgetM n f) (ForgetM n f') = ForgetM n (compose f' f).
Admitted.

Fixpoint ForgetTriangular (n : nat) (T : Type) {struct n} :
  ComposeM (Unit (Forget T n)) (ForgetM n (Counit T n)) = fstd IdAndFreeM (Forget T n).
Proof.
Admitted.


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

(***
Modulus : 2^285 - 9
Base: 64
***)

Definition curve : CurveParameters :=
  {|
    sz := 5%nat;
    base := 64;
    bitwidth := 64;
    s := 2^285;
    c := [(1, 9)];
    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 Equations Require Import Equations.

Require Import Coq.Classes.EquivDec.

Require Import Leapfrog.FinType.
Require Import Leapfrog.ConfRel.
Require Import Leapfrog.P4automaton.
Require Import Leapfrog.Ntuple.
Require Import MirrorSolve.FirstOrder.
Require Import MirrorSolve.HLists.
Require Import Coq.Logic.JMeq.
Import HListNotations.

Require Leapfrog.FirstOrderConfRelSimplified.
Require Leapfrog.FirstOrderBitVec.

Require Import Coq.Program.Equality.
Module FOS := FirstOrderConfRelSimplified.
Module FOBV := FirstOrderBitVec.

Section CompileFirstOrderConfRelSimplified.
  Set Implicit Arguments.
  (* State identifiers. *)
  Variable (St: Type).
  Context `{St_eq_dec: EquivDec.EqDec St eq}.
  Context `{St_finite: @Finite St _ St_eq_dec}.

  (* Header identifiers. *)
  Variable (Hdr: Type).
  Context `{Hdr_eq_dec: EquivDec.EqDec Hdr eq}.
  Context `{Hdr_finite: @Finite Hdr _ Hdr_eq_dec}.
  Variable (Hdr_sz: Hdr -> nat).

  Variable (a: P4A.t St Hdr_sz).

  Equations compile_store_ctx_partial
    (hdrs: list Hdr)
    : ctx FOBV.sig
  := {
    compile_store_ctx_partial nil := SLNil _;
    compile_store_ctx_partial (hdr :: hdrs) :=
      Snoc _ (compile_store_ctx_partial hdrs) (FOBV.Bits (Hdr_sz hdr))
  }.

  Definition compile_store_ctx : ctx FOBV.sig :=
    compile_store_ctx_partial (enum Hdr).

  Equations compile_store_valu_partial
    {hdrs: list Hdr}
    (hl: HList.t (fun h => (n_tuple bool (Hdr_sz h))) hdrs)
    : valu FOBV.sig FOBV.fm_model (compile_store_ctx_partial hdrs)
      by struct hl
  := {
    compile_store_valu_partial hnil := VEmp _ _;
    compile_store_valu_partial (hdr ::: hdrs) :=
      VSnoc _ FOBV.fm_model (FOBV.Bits _) _
            (compile_store_valu_partial hdrs) hdr
  }.

  Equations compile_ctx (c: ctx (FOS.sig Hdr_sz)) : ctx FOBV.sig := {
    compile_ctx (SLNil _) := SLNil _;
    compile_ctx (Snoc _ c FOS.Store) :=
      app_ctx (compile_ctx c) compile_store_ctx;
    compile_ctx (Snoc _ c (FOS.Bits n)) :=
      Snoc _ (compile_ctx c) (FOBV.Bits n)
  }.

  Equations build_hlist_env
    (hdrs: list Hdr)
    (env: P4A.store Hdr Hdr_sz)
    : (HList.t (fun h => (n_tuple bool (Hdr_sz h))) hdrs) := {
      build_hlist_env nil _ := hnil;
      build_hlist_env (hdr :: hdrs) env :=
        let v := match P4A.find Hdr Hdr_sz hdr env with
                 | P4A.VBits _ v => v
                 end in
        (_ v) ::: build_hlist_env hdrs env
    }.

  Equations compile_valu
    {c: ctx (FOS.sig Hdr_sz)}
    (v: valu (FOS.sig Hdr_sz) (FOS.fm_model a) c)
    : valu FOBV.sig FOBV.fm_model (compile_ctx c) := {
    compile_valu (VEmp _ _) := VEmp _ _;
    compile_valu (VSnoc _ _ (FOS.Bits n) _ vinner v) :=
      VSnoc _ FOBV.fm_model (FOBV.Bits n) _ (compile_valu vinner) v;
    compile_valu (VSnoc _ _ (FOS.Store) _ vinner v) :=
      app_valu _ (compile_valu vinner) (compile_store_valu_partial (build_hlist_env _ v))
  }.

  Lemma here_or_there
    {X: Type}
    `{EquivDec.EqDec X eq}
    (x x': X)
    (l: list X)
    (Hin: List.In x (x' :: l))
  :
    {x' = x} + {List.In x l}.
  Proof.
    destruct (equiv_dec x' x).
    - left.
      exact e.
    - right.
      destruct Hin.
      + contradiction.
      + exact H0.
  Defined.

  Equations compile_lookup_partial
    (k: Hdr)
    (enum: list Hdr)
    (elem_of_enum: List.In k enum)
    : var (FOBV.sig) (compile_store_ctx_partial enum)
          (FOBV.Bits (Hdr_sz k)) := {
    compile_lookup_partial k (elem :: enum) elem_of_enum :=
      match here_or_there elem_of_enum with
      | left Heq =>
        _ (VHere _ (compile_store_ctx_partial enum) (FOBV.Bits (Hdr_sz elem)))
      | right Helse =>
        VThere FOBV.sig _ (FOBV.Bits (Hdr_sz elem))
               _ (compile_lookup_partial k enum Helse)
      end
  }.

  Definition compile_lookup (k: Hdr)
    : var FOBV.sig compile_store_ctx (FOBV.Bits (Hdr_sz k))
  :=
    compile_lookup_partial k (enum Hdr) (elem_of_enum k).

  Definition get_sizes (enum: list Hdr) : list nat :=
    List.map Hdr_sz enum.

  Definition compile_sizes (enum: list Hdr) : nat :=
    List.list_sum (get_sizes enum).

  Definition compile_sort (s: FOS.sorts) : FOBV.sorts :=
    match s with
    | FOS.Bits n => FOBV.Bits n
    | FOS.Store => FOBV.Bits (compile_sizes (enum Hdr))
    end.

  Equations compile_store_partial
    (enum: list Hdr)
    : tm FOBV.sig (compile_store_ctx_partial enum)
                  (FOBV.Bits (compile_sizes enum)) := {
    compile_store_partial nil := TFun FOBV.sig (FOBV.BitsLit 0 tt) hnil;
    compile_store_partial (elem :: enum) :=
      TFun FOBV.sig (FOBV.Concat (Hdr_sz elem) (compile_sizes enum))
                    (TVar (VHere _ _ _) :::
                     tm_cons FOBV.sig (compile_store_partial enum) ::: hnil)
  }.

  Definition compile_store
    : tm (FOBV.sig) compile_store_ctx (compile_sort FOS.Store)
  :=
    compile_store_partial (enum Hdr).

  Equations subscript {c n}
    (v: var (FOS.sig Hdr_sz) c FOS.Store)
    (v': var FOBV.sig compile_store_ctx (FOBV.Bits n))
    : var FOBV.sig (compile_ctx c) (FOBV.Bits n)
  := {
    subscript (VHere c' _) v' :=
      reindex_var v';
    subscript (VThere _ c (FOS.Bits _) _ v) v' :=
      VThere _ _ _ _ (subscript v v');
    subscript (VThere _ c FOS.Store _ v) v' :=
      weaken_var _ (subscript v v')
  }.

  Equations compile_var
    {c: ctx (FOS.sig Hdr_sz)}
    {s: FOS.sorts}
    (v: var (FOS.sig Hdr_sz) c s)
    : tm FOBV.sig (compile_ctx c) (compile_sort s)
  := {
    compile_var (VHere _ c (FOS.Bits n)) :=
      TVar (VHere _ (compile_ctx c) (FOBV.Bits n));
    compile_var (VHere _ c FOS.Store) := reindex_tm compile_store;
    compile_var (VThere _ c (FOS.Bits _) s' v) := tm_cons FOBV.sig (compile_var v);
    compile_var (VThere _ c FOS.Store s' v) := weaken_tm _ (compile_var v)
  }.

  Equations compile_tm
    {c: ctx (FOS.sig Hdr_sz)}
    {s: FOS.sorts}
    (t: tm (FOS.sig Hdr_sz) c s):
    tm FOBV.sig (compile_ctx c) (compile_sort s) := {
    compile_tm (TVar v) := compile_var v;
    compile_tm (TFun _ (FOS.BitsLit _ n v) hnil) :=
      TFun FOBV.sig (FOBV.BitsLit n v) hnil;
    compile_tm (TFun _ (FOS.Concat _ n m) (t1 ::: t2 ::: hnil)) :=
      TFun FOBV.sig (FOBV.Concat n m)
                    (compile_tm t1 ::: compile_tm t2 ::: hnil);
    compile_tm (TFun _ (FOS.Slice _ n hi lo) (t ::: hnil)) :=
      TFun FOBV.sig (FOBV.Slice n hi lo) (compile_tm t ::: hnil);
    compile_tm (TFun _ (FOS.Lookup n h) (TVar v ::: hnil)) :=
      TVar (subscript v (compile_lookup h))
  }.

  (* Compilation from FOL(Conf) to FOL(BV). *)
  Equations compile_fm
    {c: ctx (FOS.sig Hdr_sz)}
    (f: fm (FOS.sig Hdr_sz) c)
    : fm FOBV.sig (compile_ctx c) := {
    compile_fm FTrue := FTrue;
    compile_fm FFalse := FFalse;
    compile_fm (FEq t1 t2) := FEq (compile_tm t1) (compile_tm t2);
    compile_fm (FNeg f) := FNeg _ (compile_fm f);
    compile_fm (FOr f1 f2) := FOr _ (compile_fm f1) (compile_fm f2);
    compile_fm (FAnd f1 f2) := FAnd _ (compile_fm f1) (compile_fm f2);
    compile_fm (FImpl f1 f2) := FImpl (compile_fm f1) (compile_fm f2);
    compile_fm (@FForall _ c (FOS.Bits n) f) :=
      FForall (sig := FOBV.sig) (FOBV.Bits n) (compile_fm f);
    compile_fm (@FForall _ c FOS.Store f) :=
      quantify compile_store_ctx (compile_fm f)
  }.

  Equations compile_store_val_partial
    (s: store (P4A.interp a))
    (enum: list Hdr)
    : n_tuple bool (compile_sizes enum)
  := {
    compile_store_val_partial s nil := tt;
    compile_store_val_partial s (elem :: enum) :=
      let '(P4A.VBits _ v) := P4A.find Hdr Hdr_sz elem s in
      n_tuple_concat v (compile_store_val_partial s enum)
  }.

  Equations compile_val
    {sort: FOS.sorts}
    (val: FOS.mod_sorts a sort)
    : FOBV.mod_sorts (compile_sort sort)
  := {
    @compile_val (FOS.Bits _) v := _ v;
    @compile_val FOS.Store s :=
      compile_store_val_partial s (enum Hdr);
  }.

  Transparent compile_store_valu_partial.

  Lemma compile_store_val_correct':
    forall (h : Hdr)
      (m : mod_sorts (FOS.sig Hdr_sz) (FOS.fm_model a) FOS.Store) enum Hin,
    List.NoDup enum ->
    match P4A.find Hdr Hdr_sz h m with
    | P4A.VBits _ v1 => v1
    end =
    find FOBV.sig FOBV.fm_model
      (compile_lookup_partial h enum Hin)
      (compile_store_valu_partial (build_hlist_env enum m))
  .
  Proof.
    intros.
    dependent induction enum.
    - contradiction.
    - autorewrite with build_hlist_env.
      simpl.
      unfold build_hlist_env_obligations_obligation_1.
      autorewrite with compile_lookup_partial.
      destruct Hin.
      + subst; simpl.
        unfold here_or_there.
        destruct (equiv_dec _ _); [|congruence].
        simpl.
        unfold compile_lookup_partial_obligations_obligation_1.
        simpl.
        unfold equiv in e.
        dependent destruction e.
        cbn.
        now rewrite (find_equation_1 FOBV.sig FOBV.fm_model (compile_store_ctx_partial enum) (FOBV.Bits (Hdr_sz h))).
      + unfold here_or_there.
        destruct (equiv_dec _ _); simpl.
        unfold equiv in e.
        inversion H.
        congruence.
        rewrite (find_equation_2 FOBV.sig FOBV.fm_model (compile_store_ctx_partial enum) (FOBV.Bits (Hdr_sz a0)) (FOBV.Bits (Hdr_sz h))).
        apply IHenum.
        now inversion H.
  Qed.

  Opaque compile_store_valu_partial.

  Lemma compile_store_val_correct:
    forall (h : Hdr) c (v0 : var (FOS.sig Hdr_sz) c FOS.Store) v,
      match P4A.find Hdr Hdr_sz h (find (FOS.sig Hdr_sz) (FOS.fm_model a) v0 v)
      with
      | P4A.VBits _ v1 => v1
      end =
      find FOBV.sig FOBV.fm_model
        (subscript v0 (compile_lookup h)) (compile_valu v).
  Proof.
    intros.
    dependent induction v; dependent destruction v0.
    - erewrite compile_valu_equation_3 with (c0 := c).
      rewrite (subscript_equation_1 c).
      replace (find FOBV.sig FOBV.fm_model _ _)
      with (find FOBV.sig FOBV.fm_model (compile_lookup h)
                 (compile_store_valu_partial (build_hlist_env (enum Hdr) m))).
      + autorewrite with find.
        unfold compile_lookup.
        apply compile_store_val_correct'.
        apply NoDup_enum.
      + erewrite <- find_app_right; now f_equal.
    - autorewrite with find.
      rewrite IHv; auto.
      destruct s.
      + simpl.
        match goal with
        | |- _ = find _ _ ?X _ =>
          assert (X = VThere FOBV.sig (compile_ctx c) (FOBV.Bits n) (FOBV.Bits (Hdr_sz h)) (subscript v0 (compile_lookup h))) by eapply subscript_equation_2
        end.
        erewrite H; clear H.

        erewrite compile_valu_equation_2 with (n := n) (c0 := c).

        now rewrite (find_equation_2 FOBV.sig FOBV.fm_model (compile_ctx c) (FOBV.Bits n) (FOBV.Bits (Hdr_sz h))).
      + erewrite (@subscript_equation_3 c).
        rewrite (compile_valu_equation_3 (c0 := c) v).
        erewrite <- find_app_left; now f_equal.
  Qed.

  Equations decompile_store_val_partial
    (enum: list Hdr)
    (val: n_tuple bool (compile_sizes enum))
    (store: P4A.store Hdr Hdr_sz)
    : P4A.store Hdr Hdr_sz
  := {
    decompile_store_val_partial nil val store := store;
    decompile_store_val_partial (elem :: enum) val store :=
      let prefix := rewrite_size _ (n_tuple_take_n (Hdr_sz elem) val) in
      let suffix := rewrite_size _ (n_tuple_skip_n (Hdr_sz elem) val) in
      P4A.assign Hdr Hdr_sz elem (P4A.VBits _ prefix)
                 (decompile_store_val_partial enum suffix store)
  }.
  Next Obligation.
    unfold compile_sizes.
    simpl.
    remember (List.list_sum _).
    remember (Hdr_sz elem).
    Lia.lia.
  Defined.
  Next Obligation.
    unfold compile_sizes.
    simpl.
    remember (List.list_sum _).
    remember (Hdr_sz elem).
    Lia.lia.
  Defined.

  Definition init_store: P4A.store Hdr Hdr_sz.
  Proof.
    apply DepEnv.init.
    intro.
    constructor.
    apply n_tuple_repeat.
    exact false.
  Defined.

  Equations decompile_val
    {sort: FOS.sorts}
    (val: FOBV.mod_sorts (compile_sort sort))
    : FOS.mod_sorts a sort
  := {
    @decompile_val (FOS.Bits _) v := v;
    @decompile_val FOS.Store v :=
      decompile_store_val_partial (enum Hdr) v init_store;
  }.

  Lemma compile_store_val_partial_invariant:
    forall h v enum s,
      ~ List.In h enum ->
      compile_store_val_partial (P4A.assign Hdr Hdr_sz h v s) enum =
      compile_store_val_partial s enum.
  Proof.
    intros.
    induction enum.
    - reflexivity.
    - autorewrite with compile_store_val_partial; simpl.
      rewrite IHenum.
      + rewrite P4A.find_not_first; auto.
        contradict H.
        subst; now apply List.in_eq.
      + contradict H.
        now apply List.in_cons.
  Qed.

  Lemma decompile_store_val_partial_roundtrip:
    forall enum val,
      List.NoDup enum ->
      val ~= compile_store_val_partial (decompile_store_val_partial enum val init_store) enum.
  Proof.
    induction enum; intros.
    - autorewrite with decompile_store_val_partial.
      autorewrite with compile_store_val_partial.
      now destruct val.
    - autorewrite with decompile_store_val_partial.
      autorewrite with compile_store_val_partial.
      simpl.
      rewrite P4A.assign_find; auto.
      symmetry.
      rewrite <- n_tuple_concat_roundtrip with (n := Hdr_sz a0).
      symmetry.
      apply concat_proper with
        (xs2 := (rewrite_size (decompile_store_val_partial_obligations_obligation_1 a0 enum) _))
        (ys2 := (compile_store_val_partial _ enum)).
      + now rewrite rewrite_size_jmeq.
      + rewrite compile_store_val_partial_invariant.
        rewrite <- IHenum.
        now rewrite rewrite_size_jmeq.
        all: now inversion H.
  Qed.

  Lemma compile_val_roundtrip:
    forall s (val: FOBV.mod_sorts (compile_sort s)),
      val = compile_val (decompile_val val).
  Proof.
    intros.
    destruct s.
    - reflexivity.
    - autorewrite with decompile_val.
      autorewrite with compile_val.
      rewrite <- decompile_store_val_partial_roundtrip; auto.
      apply NoDup_enum.
  Qed.

  Definition store_almost_equal (s1 s2: store (P4A.interp a)) :=
    forall (h: Hdr), P4A.find Hdr Hdr_sz h s1 = P4A.find Hdr Hdr_sz h s2.

  Theorem store_eq:
    forall (s1 s2: store (P4A.interp a)),
      store_almost_equal s1 s2 ->
      s1 = s2.
  Proof.
    unfold store_almost_equal, P4A.find.
    intros.
    eapply DepEnv.env_extensionality; eauto.
  Qed.

  Lemma decompile_val_roundtrip:
    forall s (val: FOS.mod_sorts a s),
      val = decompile_val (compile_val val).
  Proof.
    intros.
    destruct s.
    - autorewrite with compile_val.
      autorewrite with decompile_val.
      constructor.
    - apply store_eq.
      unfold store_almost_equal; intros.
      autorewrite with compile_val.
      autorewrite with decompile_val.
      pose proof (elem_of_enum (Finite := Hdr_finite) h).
      revert h H; induction (enum Hdr); intros.
      + contradiction.
      + destruct (h == a0).
        * unfold equiv in e.
          subst.
          clear IHl.
          autorewrite with compile_store_val_partial.
          autorewrite with decompile_store_val_partial.
          simpl.
          rewrite P4A.assign_find;
            try solve [eauto | typeclasses eauto].
          destruct (P4A.find Hdr Hdr_sz a0 val).
          f_equal.
          apply JMeq_eq.
          rewrite rewrite_size_jmeq.
          pose proof n_tuple_take_n_roundtrip.
          now specialize (H0 (Hdr_sz a0) n _ (compile_store_val_partial val l)).
        * unfold equiv, complement in c.
          autorewrite with compile_store_val_partial.
          autorewrite with decompile_store_val_partial.
          simpl.
          rewrite P4A.find_not_first by assumption.
          rewrite IHl by (destruct H; congruence).
          do 2 f_equal.
          destruct (P4A.find Hdr Hdr_sz a0 val).
          apply JMeq_eq.
          rewrite rewrite_size_jmeq.
          pose proof n_tuple_skip_n_roundtrip.
          now specialize (H0 (Hdr_sz a0) n _ (compile_store_val_partial val l)).
  Qed.

  Lemma compile_store_val_partial_correct':
    forall enum m,
      compile_store_val_partial m enum =
      interp_tm
          (compile_store_valu_partial (build_hlist_env enum m))
          (compile_store_partial enum).
  Proof.
    induction enum; intros.
    - reflexivity.
    - autorewrite with compile_store_val_partial.
      autorewrite with build_hlist_env.
      simpl.
      unfold build_hlist_env_obligations_obligation_1.
      destruct (P4A.find Hdr Hdr_sz a0 m).
      rewrite (compile_store_valu_partial_equation_2 a0 (rest := enum) n).
      rewrite (compile_store_partial_equation_2 a0 enum).
      autorewrite with interp_tm; simpl.
      autorewrite with mod_fns.
      f_equal.
      rewrite <- interp_tm_tm_cons.
      apply IHenum.
  Qed.

  Lemma compile_store_val_partial_correct:
    forall m,
      compile_store_val_partial m (enum Hdr) =
      interp_tm
          (compile_store_valu_partial (build_hlist_env (enum Hdr) m))
          (compile_store_partial (enum Hdr)).
  Proof.
    intros.
    erewrite compile_store_val_partial_correct'.
    trivial.
  Qed.

  Lemma compile_var_correct:
    forall c s (v: var _ c s) val,
      compile_val (interp_tm (m := FOS.fm_model a) val (TVar v)) =
      interp_tm (compile_valu val) (compile_var v).
  Proof.
    dependent induction val; intros.
    - dependent destruction v.
    - dependent destruction v.
      + destruct s; [easy|].
        rewrite (compile_var_equation_2 c).
        rewrite (compile_valu_equation_3 (c0 := c)).
        unfold compile_store.
        autorewrite with interp_tm.
        autorewrite with find.
        replace (@interp_tm FOBV.sig FOBV.fm_model _ _ _ _)
        with (interp_tm
                (compile_store_valu_partial (build_hlist_env (enum Hdr) m))
                (compile_store_partial (enum (Finite := Hdr_finite) Hdr))).
        * autorewrite with compile_val.
          apply compile_store_val_partial_correct.
        * now rewrite interp_tm_reindex_tm with (sig := FOBV.sig) (v' := compile_valu val).
      + destruct s0.
        * erewrite compile_var_equation_3 with (c := c) (n := n).
          rewrite (compile_valu_equation_2 (c0 := c) n).
          replace (@interp_tm FOBV.sig FOBV.fm_model _ _ _ _)
          with (interp_tm (compile_valu val) (compile_var v)).
          autorewrite with interp_tm.
          autorewrite with find.
          rewrite <- IHval.
          now autorewrite with interp_tm.
          now rewrite interp_tm_tm_cons with
            (sig := FOBV.sig)
            (m := FOBV.fm_model)
            (s' := FOBV.Bits n)
            (val := m).
        * rewrite (compile_var_equation_4 v).
          rewrite (compile_valu_equation_3 (c0 := c)).
          autorewrite with interp_tm.
          autorewrite with find.
          replace (@interp_tm FOBV.sig FOBV.fm_model _ _ _ _)
          with (interp_tm (compile_valu val) (compile_var v)).
          rewrite <- IHval.
          -- now autorewrite with interp_tm.
          -- now rewrite interp_tm_weaken_tm with
               (v' := (compile_store_valu_partial (build_hlist_env (enum Hdr) m))).
  Qed.

  Lemma compile_simplified_tm_bv_correct:
    forall c s v (tm: tm _ c s),
      compile_val (interp_tm (m := FOS.fm_model a) v tm) =
      interp_tm (compile_valu v) (compile_tm (c := c) tm).
  Proof.
    intros.
    dependent induction tm using tm_ind'.
    - autorewrite with compile_tm.
      now erewrite compile_var_correct.
    - destruct srt;
      repeat dependent destruction hl;
      autorewrite with compile_tm;
      autorewrite with interp_tm; simpl;
      autorewrite with mod_fns;
      repeat match goal with
      | H : HList.all _ _ |- _ =>
        destruct H
      end;
      auto.
      + unfold compile_val_obligations_obligation_1.
        now rewrite <- H, <- H0.
      + now rewrite <- H.
      + dependent destruction t; [|easy].
        autorewrite with compile_tm.
        autorewrite with interp_tm.
        autorewrite with compile_val.
        unfold compile_val_obligations_obligation_1.
        now erewrite compile_store_val_correct.
  Qed.

  Lemma compile_store_valu_partial_invariant:
    forall h v enum s,
      ~ List.In h enum ->
      compile_store_valu_partial (build_hlist_env enum (P4A.assign Hdr Hdr_sz h v s)) =
      compile_store_valu_partial (build_hlist_env enum s).
  Proof.
    induction enum; intros.
    - now autorewrite with build_hlist_env.
    - autorewrite with build_hlist_env.
      simpl.
      unfold build_hlist_env_obligations_obligation_1.
      rewrite P4A.find_not_first;
        try solve [typeclasses eauto | eauto].
      + destruct (P4A.find Hdr Hdr_sz a0 s).
        specialize (IHenum s).
        rewrite (compile_store_valu_partial_equation_2 _ (rest := enum)).
        rewrite (compile_store_valu_partial_equation_2 _ (rest := enum)).
        f_equal.
        apply IHenum.
        contradict H.
        now apply List.in_cons.
      + contradict H.
        subst.
        apply List.in_eq.
  Qed.

  Lemma compile_store_valu_partial_surjective':
    forall enum,
      List.NoDup enum ->
      forall (val: valu FOBV.sig FOBV.fm_model (compile_store_ctx_partial enum)),
        exists s: P4A.store Hdr Hdr_sz,
          compile_store_valu_partial (build_hlist_env enum s) = val.
  Proof.
    induction enum; intros.
    - setoid_rewrite build_hlist_env_equation_1.
      exists init_store.
      dependent destruction val.
      reflexivity.
    - dependent destruction val.
      inversion H.
      specialize (IHenum H3 val).
      destruct IHenum as [? ?].
      exists (P4A.assign Hdr Hdr_sz a0 (P4A.VBits _ m) x0).
      autorewrite with build_hlist_env.
      simpl.
      unfold build_hlist_env_obligations_obligation_1.
      subst.
      rewrite (compile_store_valu_partial_equation_2 a0 (rest := enum)).
      f_equal.
      + now apply compile_store_valu_partial_invariant.
      + rewrite P4A.assign_find; auto.
  Qed.

  Lemma compile_store_valu_partial_surjective:
    forall (val: valu FOBV.sig FOBV.fm_model compile_store_ctx),
      exists s: P4A.store Hdr Hdr_sz,
        compile_store_valu_partial (build_hlist_env (enum Hdr) s) = val.
  Proof.
    intros.
    apply compile_store_valu_partial_surjective'.
    apply NoDup_enum.
  Qed.

  (* Compilation from FOL(Conf) to FOL(BV) is correct. *)
  Lemma compile_simplified_fm_bv_correct:
    forall c v (fm : fm _ c),
      interp_fm (m := FOS.fm_model a) v fm <->
      interp_fm (m := FOBV.fm_model) (compile_valu v) (compile_fm (c := c) fm)
      .
  Proof.
    intros.
    dependent induction fm;
    autorewrite with compile_fm;
    autorewrite with interp_fm;
    try easy.
    - repeat rewrite <- compile_simplified_tm_bv_correct.
      split; intros.
      + now f_equal.
      + rewrite decompile_val_roundtrip.
        rewrite decompile_val_roundtrip at 1.
        now f_equal.
    - now rewrite IHfm.
    - now rewrite IHfm1, IHfm2.
    - now rewrite IHfm1, IHfm2.
    - now rewrite IHfm1, IHfm2.
    - destruct s.
      + autorewrite with compile_fm.
        autorewrite with interp_fm.
        intuition.
        -- specialize (H (decompile_val val (sort := FOS.Bits n))).
           apply IHfm in H.
           apply H.
        -- specialize (H (compile_val val)).
           apply IHfm.
           apply H.
      + autorewrite with compile_fm.
        rewrite quantify_correct.
        intuition.
        -- pose proof (compile_store_valu_partial_surjective valu).
           destruct H0 as [s ?].
           specialize (H s).
           apply IHfm in H.
           erewrite compile_valu_equation_3 with (c0 := c) in H.
           now rewrite H0 in H.
        -- specialize (H (compile_store_valu_partial (build_hlist_env _ val))).
           apply IHfm.
           now erewrite compile_valu_equation_3 with (c0 := c).
  Qed.

End CompileFirstOrderConfRelSimplified.


Require Export CFGinnermost.
Require Import PropExtensionality Lia.

(** * Kinds of edges in a redCFG **)

Section cfg.
  Context `{C : redCFG}.

  Infix "-->" := edge__P.

  Inductive Edge (p q : Lab) : Type :=
  | Enormal : basic_edge p q -> Edge p q
  | Eback : back_edge p q -> Edge p q
  | Eentry : entry_edge p q -> Edge p q
  | Eexit : eexit_edge p q -> Edge p q.

  Lemma Edge_disj (p q : Lab) (H Q : Edge p q)
    : H = Q.
  Proof.
    destruct H,Q.
    all: match goal with
         | |- ?x _ = ?x _ => f_equal;eapply proof_irrelevance
         | |- _ => exfalso
         end.
    all: unfold back_edge,entry_edge, eexit_edge, exit_edge, basic_edge in *.
    all: unfold_edge_op' b; unfold_edge_op' b0; repeat destructH;
      try contradiction.
    7,10:eapply no_exit_head;unfold exit_edge;eauto.
    4,8:exfalso;eapply no_exit_head;eexists;eauto; unfold back_edge; unfold_edge_op; eauto.
    all: lazymatch goal with
         | H : ~ loop_contains ?q ?p,
               Q : eq_loop ?p ?q |- _ => eapply H; rewrite Q; eapply loop_contains_self;eauto
         | H : eq_loop ?p ?q,
               Q : ~ loop_contains _ ?q |- _ => rewrite <-H in Q; contradiction
         | _ : loop_head ?q,
               H : ~ loop_contains ?q ?p,
                   _ : ~ a_edge__P ?p ?q |- _
           => eapply H; specialize (back_edge_eq_loop (p:=p) (h:=q)) as Q;
               exploit Q;[firstorder|rewrite Q;eapply loop_contains_self;eauto]
         | _ => idtac
         end.
  Qed.

  Lemma edge_Edge : forall (p q : Lab), edge__P p q -> Edge p q.
  Proof.
    intros ? ? Hedge.
    decide (deq_loop p q).
    - decide (deq_loop q p).
      + decide (a_edge__P p q).
        * econstructor;eauto;split;eauto;split;eauto.
        * eapply Eback. refine (conj Hedge n).
      + eapply Eexit.
        simpl_dec' n. simpl_dec' n. destructH.
        exists x. split;eauto.
    - eapply Eentry.
      unfold entry_edge. split_conj;eauto.
      + simpl_dec' n. simpl_dec' n. destructH.
        enough (x = q).
        * subst. eapply loop_contains_loop_head;eauto.
        * eapply dom_loop_contains in n1 as Hdom;eauto.
          specialize (PathSingle edge__P p) as Hpath.
          eapply PathCons in Hedge;eauto.
          eapply Hdom in Hedge. destruct Hedge;subst;auto.
          exfalso. cbn in H; destruct H;[|auto]. subst.
          eapply n1. eapply loop_contains_self;eapply loop_contains_loop_head;eauto.
      + contradict n. eapply loop_contains_deq_loop;auto.
  Defined.

  Lemma Edge_eq (p q : Lab)
        (H : edge__P p q)
        (Q : edge__P p q)
    : edge_Edge H = edge_Edge Q.
  Proof.
    erewrite Edge_disj. reflexivity.
  Qed.

  Lemma basic_edge_loop_contains a b x
        (Hedge : basic_edge a b)
        (Hinner : loop_contains x a)
    : loop_contains x b.
  Proof.
    specialize (loop_contains_loop_head Hinner) as Hhead.
    destruct Hedge as [Hedge _].
    eauto using loop_contains_deq_loop, deq_loop_head_loop_contains, eq_loop1.
  Qed.

  Lemma enter_exit_same e h b c
        (Hentry : entry_edge e h)
        (Hexit: exit_edge h b c)
    : eq_loop c e.
  Proof.
    enough (forall h, loop_contains h e <-> loop_contains h c).
    - unfold eq_loop, deq_loop.
      firstorder 0.
    - intros h'. split; intros.
      + eapply exit_edge_in_loop; try eassumption.
        * eapply deq_loop_entry in Hentry. unfold deq_loop in Hentry. eauto.
        * intro. subst. eapply Hentry. assumption.
      + specialize (deq_loop_exited' Hexit) as Hdeq. unfold deq_loop in Hdeq.
        edestruct (deq_loop_entry_or Hentry); eauto.
        subst. unfold exit_edge in Hexit.
        exfalso. destruct Hexit as [_ [Hexit _]]. contradiction.
  Qed.

  Lemma not_deq_edge_is_exit a b h
        (Edge : a --> b)
        (Hinner : innermost_loop h a)
        (Hndeq : ~ deq_loop b a)
    : exit_edge h a b.
  Proof.
    eapply edge_Edge in Edge.
    inv Edge.
    - exfalso. destruct H as [H _]. eapply Hndeq. eapply eq_loop1. eapply H. reflexivity.
    - exfalso. eapply back_edge_eq_loop in H. eapply Hndeq. eapply eq_loop1. eapply H. reflexivity.
    - exfalso. eapply deq_loop_entry in H. contradiction.
    - destruct H as [h' Hexit].
      enough (h = h').
      + subst h'. eassumption.
      + eauto using exit_edge_innermost, innermost_unique.
  Qed.

  Lemma ncont_cont_is_entry_edge h a b
        (Hcont : loop_contains h b)
        (Hncont : ~ loop_contains h a)
        (Hedge : a --> b)
    : entry_edge a b /\ b = h.
  Proof.
    eapply edge_Edge in Hedge.
    inv Hedge.
    - destruct H as [H _]. rewrite H in Hncont. contradiction.
    - eapply back_edge_eq_loop in H. rewrite H in Hncont. contradiction.
    - split; try eassumption. unfold entry_edge in H.
      destruct H as [_ [Hncontba Hedge]].
      eauto using entry_through_header.
    - destruct H as [h' Hexit].
      eapply deq_loop_exited in Hexit.
      exfalso. unfold deq_loop in Hexit. eauto.
  Qed.

End cfg.

Ltac edge_excl
  := let He := fresh "Hexcleexit" in
     match goal with
     | H : exit_edge ?h ?p ?q |- _
       => assert (eexit_edge p q) as He;
         [eexists;eauto|]
     | _ => idtac
     end;
     match goal with
     | H : basic_edge ?p ?q |- _
       => let tac
             := eapply depth_basic in H
           in
             lazymatch goal with
             | Q : entry_edge p q |- _
               => eapply depth_entry in Q;tac;lia
             | Q : eexit_edge p q |- _
               => eapply depth_exit in Q;tac;lia
             | Q : back_edge p q |- _
               => destruct H, Q; firstorder
             end
     | H : entry_edge ?p ?q |- _
       => let tac
             := eapply depth_entry in H
           in
             lazymatch goal with
             | Q : basic_edge p q |- _
               => eapply depth_basic in Q;tac;lia
             | Q : eexit_edge p q |- _
               => eapply depth_exit in Q;tac;lia
             | Q : back_edge p q |- _
               => eapply depth_back in Q;tac;lia
             end
     | H : eexit_edge ?p ?q |- _
       => let tac
             := eapply depth_exit in H
           in
             lazymatch goal with
             | Q : basic_edge p q |- _
               => eapply depth_basic in Q;tac;lia
             | Q : entry_edge p q |- _
               => eapply depth_entry in Q;tac;lia
             | Q : back_edge p q |- _
               => eapply depth_back in Q;tac;lia
             end
     | H : back_edge ?p ?q |- _
       => let tac
             := eapply depth_back in H
           in
             lazymatch goal with
             | Q : basic_edge p q |- _
               => destruct H, Q; firstorder
             | Q : entry_edge p q |- _
               => eapply depth_entry in Q;tac;lia
             | Q : back_edge p q |- _
               => eapply depth_back in Q;tac;lia
             end
     end;
     try clear He.

Lemma entry_edge_acyclic `(C : redCFG) p q
      (Hentry : entry_edge p q)
  : a_edge__P p q.
Proof.
  decide (back_edge p q).
  - edge_excl.
  - simpl_dec' n. simpl_dec' n. unfold entry_edge in Hentry. destruct n;firstorder.
Qed.

Lemma exit_edge_acyclic `(C : redCFG) p q
      (Hexit : eexit_edge p q)
  : a_edge__P p q.
Proof.
  decide (back_edge p q).
  - edge_excl.
  - do 2 simpl_dec' n. destruct Hexit. destruct H. destruct H0. destruct n;firstorder.
Qed.


Require Import Bedrock.Examples.AutoSep.

(** * A trivial example to make sure the separation logic proof automation isn't completely borked *)

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

Definition read := bmodule "read" {{
  bfunction "read"("x", "y") [readS]
    "y" <-* "x";;
    If ("y" = 0) {
      "x" *<- 0
    } else {
      "x" *<- "y"
    } ;;
    "y" <-* "x";;
    Return "y"
  end
}}.

Theorem readOk : moduleOk read.
(*TIME  Clear Timing Profile. *)
  vcgen; abstract sep_auto.
(*TIME  Print Timing Profile. *)
Qed.