(**********************************************************************************
 * The PEDANTIC (Proof Engine for Deductive Automation using Non-deterministic
 * Traversal of Instruction Code) verification framework
 *
 * Developed by Kenneth Roe
 * For more information, check out www.cs.jhu.edu/~roe
 *
 * SatSolverAux1.v
 * This file contains the proof of correctness of a tree traversal algorithm using
 * the PEDANTIC verification framework.
 *
 **********************************************************************************)

Require Import Omega.
Require Export SfLib.
Require Export SfLibExtras.
Require Export ImpHeap.
Require Export AbsState.
Require Export AbsExecute.
Require Export AbsStateInstance.
Require Export Simplify.
Require Export Eqdep.
Require Export StateImplication.
Require Export Classical.
Require Export Unfold.
Require Export Fold.
Require Export merge.
Require Export ProgramTactics.
Require Export UpdateHelper.
Require Export ClosureHelper.
Require Export MagicWandExistsHelper.

Set Printing Depth 200.

Fixpoint isNat (v: @Value unit) :=
    match v with
    | NatValue _ => True
    | _ => False
    end.

Inductive ValueType := ListType | NatType | BoolType| AnyType.

Fixpoint expValue (vt : ValueType) (ex : absExp) (bindings: list (@Value unit)) (e : env) : @Value unit :=
    match vt with
    | NatType => match ex with
                 | AbsConstVal x => x
                 | AbsVar x => NatValue (e x)
                 | AbsQVar x => nth x bindings NoValue
                 | AbsFun AbsPlusId (x::y::nil) => match expValue NatType x bindings e,
                                                         expValue NatType y bindings e with
                                                   | NatValue a, NatValue b => NatValue (a+b)
                                                   | _, _ => NoValue
                                                   end
                 | AbsFun AbsMinusId (x::y::nil) => match expValue NatType x bindings e,
                                                          expValue NatType y bindings e with
                                                    | NatValue a, NatValue b => NatValue (a-b)
                                                    | _, _ => NoValue
                                                    end
                 | AbsFun AbsTimesId (x::y::nil) => match expValue ListType x bindings e,
                                                          expValue NatType y bindings e with
                                                    | ListValue a, NatValue b => nth b a NoValue
                                                    | _, _ => NoValue
                                                    end
                 | AbsFun AbsNthId (x::y::nil) => match expValue NatType x bindings e,
                                                          expValue NatType y bindings e with
                                                    | NatValue a, NatValue b => NatValue (a*b)
                                                    | _, _ => NoValue
                                                    end
                 | _ => NoValue
                 end
    | ListType => match ex with
                  | AbsQVar x => nth x bindings NoValue
                  | _ => NoValue
                  end
    | _ => NoValue
    end.

Fixpoint mergeConditions cond1 cond2 :=
    match cond1, cond2 with
    | None, None => None
    | Some x, None => Some x
    | None, Some x => Some x
    | Some x, Some y => Some (x /\ y)
    end.
Fixpoint expValid (vt : ValueType) (ex : absExp) (bindings: list (@Value unit)) (e : env) : option Prop :=
    match vt with
    | NatType => match ex with
                 | AbsConstVal _ => None
                 | AbsVar _ => None
                 | AbsQVar x => match nth x bindings NoValue with | NatValue _ => None | _ => Some False end
                 | AbsFun AbsPlusId (x::y::nil) => mergeConditions
                                                   (expValid vt x bindings e)
                                                   (expValid vt y bindings e)
                 | AbsFun AbsMinusId (x::y::nil) => mergeConditions
                                                    (expValid vt x bindings e)
                                                    (expValid vt y bindings e)
                 | AbsFun AbsTimesId (x::y::nil) => mergeConditions
                                                    (expValid vt x bindings e)
                                                    (expValid vt y bindings e)
                 | AbsFun AbsIteId (x::y::z::nil) => mergeConditions (mergeConditions
                                                      (expValid vt z bindings e)
                                                      (expValid vt y bindings e))
                                                     (expValid BoolType x bindings e)
                 | _ => Some False
                 end
    | AnyType => match ex with
                 | AbsConstVal _ => None
                 | AbsVar _ => None
                 | AbsQVar x => None
                 | _ => Some False
                 end
    | _ => Some False
    end.

Fixpoint findTree (state : absState) (e: absExp) : option (absState) :=
    match state with
    | AbsUpdateVar s a b => if hasVarExp e a then None else findTree s e
    | AbsUpdateWithLoc s a b => if hasVarExp e a then None else findTree s e
    | AbsStar a b => match findTree a e with
                     | Some x => Some x
                     | None => findTree b e
                     end
    (*| AbsExistsT s => findTree s (N e)*)
    | TREE(root,var,size,p) => if beq_absExp root e then Some (TREE(root,var,size,p)) else None
    | ARRAY(root,a,b) => if beq_absExp root e then Some (ARRAY(root,a,b)) else None
    | _ => None
    end.

Fixpoint expAssertion (ex : absExp) (bindings: list (@Value unit)) (e : env) :=
    match ex with
    | AbsConstVal (NatValue (S _)) => True
    | AbsConstVal _ => False
    | AbsVar v => (e v) > 0
    | AbsQVar n => match nth n bindings NoValue with
                   | NatValue (S 0) => True
                   | _ => False
                   end
    | AbsFun AbsLessId el => match map (absEval e bindings) el with
                             | (NatValue l::NatValue r::nil) =>  (l < r)
                             | _ => False
                             end
    | AbsFun AbsEqualId el => match map (absEval e bindings) el with
                              | (NatValue l::NatValue r::nil) =>  (l = r)
                              | _ => False
                              end
    | AbsFun AbsNotId (a::nil) => ~ (expAssertion a bindings e)
    | AbsFun AbsAndId (a::b::nil) => (expAssertion a bindings e) /\ (expAssertion b bindings e)
    | AbsFun AbsOrId (a::b::nil) => (expAssertion a bindings e) \/ (expAssertion b bindings e)
    | AbsFun AbsMemberId (a::b::nil) => match expValid NatType a bindings e,expValue NatType a bindings e with
                                        | None,NatValue x => match expValid AnyType b bindings e,expValue ListType b bindings e with
                                                             | None,y => Rmember x y=true
                                                             | Some p,y => p -> Rmember x y=true
                                                             end
                                        | Some q,NatValue x => match expValid AnyType b bindings e,expValue ListType b bindings e with
                                                             | None,y => q -> Rmember x y=true
                                                             | Some p,y => q -> p -> Rmember x y=true
                                                             end
                                        | _,_ => False
                                        end
    | AbsFun f el => match absEval e bindings ex with
                     | NatValue x => (x > 0)
                     | _ => False
                     end
    end.

Fixpoint isField  (ff : nat) (l : list absExp) (bindings : list (@Value unit)) (st : state) :=
    match l with
    | nil => false
    | (h::r) => match expValue NatType h bindings (fst st) with
                      | NatValue q=> if beq_nat q ff then true else isField ff r bindings st
                      | _ => isField ff r bindings st
                      end
    end.

Fixpoint foldAssertions {t} (b : t) (a : list (t -> Prop)) :=
    match a with
    | f::r => (f b) /\ foldAssertions b r
    | nil => True
    end.

Fixpoint extractList {t} (l : @Value t) :=
    match l with
    | ListValue v => v
    | _ => nil
    end.

Fixpoint stateAssertions (s : absState) (st : state) :=
    match s with
    | AbsStar a b => (stateAssertions a st)++(stateAssertions b st)
    | AbsMagicWand a b => (stateAssertions a st)++(stateAssertions b st)
    | AbsOrStar a b => (fun bindings => ((foldAssertions bindings (stateAssertions a st)) \/ (foldAssertions bindings (stateAssertions b st))))::nil
    | AbsUpdateVar s a b => (fun bindings => (match expValid NatType b bindings (fst st),(NatValue (fst st a)=(expValue NatType b bindings (fst st))) with
                            | Some x,y => (x -> y)
                            | None,y => y
                            end))::(fun bindings => (exists vv, (foldAssertions bindings (stateAssertions s (override (fst st) a vv,snd st)))))::nil
    | AbsUpdateWithLoc s l (AbsFun AbsPlusId (aa::bb::nil)) =>
          (fun bindings => (exists vv, (foldAssertions bindings (stateAssertions s (override (fst st) l vv,snd st)))))::
          match findTree s aa with
          | Some (ARRAY(_,s,v)) => (fun bindings => (expAssertion (AbsFun AbsLessId (bb::s::nil)) bindings (fst st) ->
                                  forall ll vvv bbv, (NatValue ll=expValue NatType (AbsFun AbsPlusId (aa::bb::nil)) bindings (fst st) ->
                                  (ListValue vvv)=expValue ListType v bindings (fst st) ->
                                  NatValue bbv=expValue NatType bb bindings (fst st) ->
                                  (NatValue (fst st l)=(nth (bbv+1) vvv NoValue)))))
          | Some (TREE(_,v,s,ff)) => (fun bindings => (expAssertion (AbsFun AbsLessId (bb::s::nil)) bindings (fst st) ->
                                  forall ll vvv bbv, (NatValue ll=expValue NatType (AbsFun AbsPlusId (aa::bb::nil)) bindings (fst st) ->
                                  (ListValue vvv)=expValue ListType v bindings (fst st) ->
                                  NatValue bbv=expValue NatType bb bindings (fst st) ->
                                  isField ll ff bindings st=false ->
                                  (NatValue (fst st l)=(nth (bbv+1) vvv NoValue)))) /\
                                  (expAssertion (AbsFun AbsLessId (bb::s::nil)) bindings (fst st) ->
                                   forall ll vvv qq bbv, (NatValue ll=expValue NatType (AbsFun AbsPlusId (aa::bb::nil)) bindings (fst st) ->
                                  (ListValue vvv)=expValue ListType v bindings (fst st) ->
                                  isField ll ff bindings st=true ->
                                  NatValue bbv=expValue NatType bb bindings (fst st) ->
                                  (ListValue qq=(nth (bbv+1) vvv NoValue)) ->
                                  NatValue (fst st l)=(nth 0 qq NoValue))))
          | _ => (fun bindings => True)
          end::nil
    | AbsExistsT s => (fun bindings => (exists v, (foldAssertions (v::bindings) (stateAssertions s st))))::nil
    | AbsAll TreeRecords(v) s => map (fun (x : list Value -> Prop) => (fun bindings => forall vv vl,
                           expValue ListType v bindings (fst st)=vv->
                           rangeSet vv=ListValue vl ->
                           forall v, (In (NatValue v) vl -> (x ((NatValue v)::bindings))))) (stateAssertions s st)
    | AbsAll range(#ss,#ee) s =>
                             map (fun (x : list Value -> Prop) => (fun bindings => forall v, (ss<=v -> v < ee -> x ((NatValue v)::bindings)))) (stateAssertions s st)
    | AbsAll range(ss,ee) s => (map (fun (x : list Value -> Prop) => (fun bindings => forall sss eee,
                             expValue NatType ss bindings (fst st)=NatValue sss->
                             expValue NatType ee bindings (fst st)=NatValue eee->
                             forall v, (sss<=v -> v < eee -> x (bindings++((NatValue v)::nil))))) (stateAssertions s st))
    | AbsAll e s => map (fun (x : list Value -> Prop) => (fun bindings => forall vl, absEval (env_p st) bindings e = (ListValue vl) ->
                           forall v, (In v vl -> x (v::bindings)))) (stateAssertions s st)
    | [x] => (fun bindings => (expAssertion x bindings (fst st)))::nil
    | ARRAY(!!root,#count,v(n)) => (fun bindings => exists h,
                             (match (nth n bindings NoValue) with
                             | ListValue vl => anyHeapv ((fst st) root) count h vl /\ (forall x v, h x = Some v -> (snd st) x = Some v)
                             | _ => False
                             end))::nil
    | ARRAY(root,count,v) => (fun bindings => (exists r c vv h,
                             NatValue r=expValue NatType root bindings (fst st) ->
                             NatValue c=expValue NatType count bindings (fst st) ->
                             ListValue vv=expValue ListType v bindings (fst st) ->
                             anyHeapv r c h vv))::nil
    | (x |-> y) => (fun bindings => (exists xx, NatValue xx = expValue NatType x bindings (fst st)) /\
                                    (exists yy, NatValue yy = expValue NatType y bindings (fst st)) /\
                                    (forall xx yy,
                                     NatValue xx = expValue NatType x bindings (fst st) ->
                                     NatValue yy = expValue NatType y bindings (fst st) ->
                                     (xx > 0 /\ (snd st xx)=Some yy)))::nil
    | TREE(!!root,v(x),#count,(#next::nil)) =>
                                     (fun bindings => (exists h,
                                         Tree (fst st root) count (next::nil)
                                              (nth x bindings NoValue) h /\ (forall x v, h x = Some v -> (snd st) x = Some v)))::nil
    | TREE(root,v,count,children) => (fun bindings => (forall c vr childrenr rootr countr, exists h,
                                     childrenr = map (fun cc => expValue NatType cc bindings (fst st)) children ->
                                     vr = expValue ListType v bindings (fst st) ->
                                     NatValue countr = expValue NatType count bindings (fst st) ->
                                     NatValue rootr = expValue NatType root bindings (fst st) ->
                                     strip_nat_values childrenr c -> Tree rootr countr c vr h))::nil

    | _ => (fun x => True)::nil
    end.

Theorem stateAssertionThm: forall st b s,
    realizeState st b s -> foldAssertions b (stateAssertions st s).
Proof.
    admit.
Admitted.

Theorem heapMap : forall t base size h l, @anyHeapv t base size h l -> (forall i, (i < size -> exists nv, (h (base+i)=Some nv /\ nth (i+1) l NoValue=NatValue nv))).
Proof.
    admit.
Admitted.

Theorem glue1 : forall (s : state), (let (x, _) := s in x)=env_p s.
Proof.
    admit.
Admitted.

Theorem glue2 : forall (s : state), (let (_, x) := s in x)=heap_p s.
Proof.
    admit.
Admitted.

Ltac decomposeStep := match goal with
     | [ H: match ?Q with NatValue _ => _ | ListValue _ => False | NoValue => False | OtherValue _ => False end |- _ ] => remember Q; destruct Q
     | [ H: match ?Q with NatValue _ => False | ListValue _ => _ | NoValue => False | OtherValue _ => False end |- _ ] => remember Q; destruct Q
     | [ Q: False |- _ ] => inversion Q
     end.

Theorem rangeSetIsList : forall a b c d e, @Tree unit a b c d e -> exists v, @ListValue unit v=rangeSet d.
Proof.
    admit.
Admitted.

Theorem rootInTree : forall a b c d e f, @Tree unit a b c d e -> @ListValue unit f = rangeSet d -> In (NatValue a) f.
Proof. admit. Admitted.

Theorem rootIsRecord: forall a b c d e, @Tree unit a b c d e -> extractList d = findRecord a d.
Proof. admit. Admitted.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D M : Universe, ((wd_ A C /\ (wd_ B D /\ (wd_ M B /\ (wd_ M A /\ (wd_ M C /\ (wd_ M D /\ (col_ A B C /\ (col_ A M C /\ (col_ B M D /\ (col_ B M A /\ (col_ M B C /\ col_ M D A))))))))))) -> col_ A B D)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj14eqsynthconj2 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (plus Zero (mult lv1 lv0))).
Admitted.
QuickChick conj14eqsynthconj2.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C I H1 H2 : Universe, ((wd_ H1 B /\ (wd_ H2 B /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ I H2 /\ (wd_ I H1 /\ (wd_ I B /\ (col_ B H1 A /\ (col_ B H2 C /\ (col_ I B H1 /\ (col_ A B I /\ col_ I B C)))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O A B C Bprime : Universe, ((wd_ A Bprime /\ (wd_ O A /\ (wd_ O Bprime /\ (wd_ A B /\ (wd_ B C /\ (wd_ B Bprime /\ (wd_ C Bprime /\ (wd_ O C /\ (wd_ O B /\ (col_ O A C /\ (col_ A B C /\ (col_ O A Bprime /\ col_ B C Bprime)))))))))))) -> col_ Bprime O C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Algebra.Functor Algebra.Applicative Algebra.SetoidCat Algebra.SetoidCat.PairUtils Algebra.SetoidUtils Algebra.Monad Tactics Utils Algebra.SetoidCat.MaybeUtils Algebra.Monad.Maybe Lens.
Require Import SetoidClass Vector.

Inductive MaybePreview := maybePreview.

Program Instance MaybePreviewS : Setoid MaybePreview.

Definition _MaybePreview_set {A} {AS : Setoid A} (_ : MaybePreview) (a : A) : maybeS AS ~> maybeS AS :=
  caseMaybeS
    @ (constS _ @ (SomeS @ a))
    @ None.

Instance _MaybePreview_set_Proper A (AS : Setoid A) : Proper (equiv ==> equiv ==> equiv) (@_MaybePreview_set A AS).
Proof.
  autounfold. intros. unfold _MaybePreview_set. rewritesr.
Qed.

Definition MaybePreview_set {A} {AS : Setoid A} := injF2 (@_MaybePreview_set A AS) _.

Definition MaybePreview_preview {A} {AS : Setoid A} : MaybePreviewS ~> maybeS AS ~~> maybeS AS :=
  constS _ @ idS.

Instance maybePreview_Settable A (AS : Setoid A) : @Settable (maybe A) A _  _ MaybePreview _ .
Proof.
  split.
  exact (MaybePreview_set).
Defined.

Instance maybePreview_Preview A (AS : Setoid A) : @Preview (maybe A) A _ _ MaybePreview _ _.
Proof.
  exists (MaybePreview_preview).
  intros. destruct a; [simpl; reflexivity | simpl in H; tauto].
  intros. destruct a; [simpl in H; tauto | simpl; auto].
  intros. destruct a; [simpl in *; symmetry; auto | simpl; auto].
  intros. destruct a; [simpl in H; tauto | simpl; auto].

Defined.


Require Import CT.Category.
Require Import CT.Functor.
Require Import CT.NaturalTransformation.
Require Import CT.Instance.Functor.
Require Import CT.Instance.NaturalTransformation.Composition.
Require Import CT.Instance.NaturalTransformation.IdentityNaturalTransformation.

Program Definition FunctorCategory (C D : Category) : Category :=
  {| ob := Functor C D;
     mor := NaturalTransformation;
     id := IdentityNaturalTransformation;
     comp := @VCNaturalTransformation C D
  |}.
Next Obligation.
Proof.
  rewrite VCNaturalTransformation_assoc.
  reflexivity.
Qed.
Next Obligation.
Proof. symmetry. apply FunctorCategory_obligation_1. Qed.
Next Obligation.
Proof. apply VCNaturalTransformation_id_left. Qed.
Next Obligation.
Proof. apply VCNaturalTransformation_id_right. Qed.

(* The category of endofunctors on some category. *)
Definition EndofunctorCategory (C : Category) := FunctorCategory C C.


Require Import Coqlib.
Require Import Asm.
Require Import PeekTactics.
Require Import PeepsLib.
Require Import PregTactics.
Require Import StepIn.
Require Import AsmBits.
Require Import Values.
Require Import ValEq.
Require Import Integers.
Require Import PeepsTactics.

Definition peep_overwrite_mov_nop_example :=
  Pmov_rr EBX EAX
                :: Pmov_rr EBX ECX
                :: nil.

Section OVERWRITE_MOV_NOP.

  Variable concrete : code.
  Variable r1 : ireg.
  Variable r2 : ireg.
  Variable r3 : ireg.
  Hypothesis r1_r3_neq : r1 <> r3.
  Hypothesis r2_r3_neq : r2 <> r3.

  Definition peep_overwrite_mov_nop_defs : rewrite_defs :=
    {|
      fnd :=
        Pmov_rr r2 r1
                :: Pmov_rr r2 r3
                :: nil
      ; rpl :=
          Pnop
            :: Pmov_rr r2 r3
            :: nil
      ; lv_in := IR r3 :: PC :: nil
      ; lv_out := IR r2 :: IR r3 :: PC :: nil
      ; clobbered := flags
    |}.

  Lemma peep_overwrite_mov_nop_selr :
    StepEquiv.step_through_equiv_live (fnd peep_overwrite_mov_nop_defs) (rpl peep_overwrite_mov_nop_defs) (lv_in peep_overwrite_mov_nop_defs) (lv_out peep_overwrite_mov_nop_defs).
  Proof.
    prep_l.
    step_l.
    step_l.
    prep_r.
    step_r.
    step_r.
    finish_r.
    prep_eq'.
    - subst_max.
      preg_simpl.
      assumption.
    - subst_max.
      preg_simpl.
      assumption.
    - subst_max.
      preg_simpl.
      repeat find_rewrite_goal.
      simpl.
      reflexivity.
  Qed.

  Definition peep_overwrite_mov_nop_proofs : rewrite_proofs :=
    {|
      defs := peep_overwrite_mov_nop_defs
      ; selr := peep_overwrite_mov_nop_selr
    |}.

  Definition peep_overwrite_mov_nop :
    concrete = fnd peep_overwrite_mov_nop_defs ->
    StepEquiv.rewrite.
  Proof.
    intros.
    peep_tac_mk_rewrite peep_overwrite_mov_nop_defs peep_overwrite_mov_nop_proofs.
  Qed.

End OVERWRITE_MOV_NOP.

Definition peep_overwrite_mov_nop_rewrite (c : code) : option StepEquiv.rewrite.
  name peep_overwrite_mov_nop p.
  unfold peep_overwrite_mov_nop_defs in p.
  simpl in p.
  specialize (p c).
  do 2 set_code_cons c.
  set_code_nil c.
  set_instr_eq i 0%nat peep_overwrite_mov_nop_example.
  set_instr_eq i0 1%nat peep_overwrite_mov_nop_example.
  set_ireg_eq rd rd0.
  set_ireg_neq rd0 r0.
  specialize (p _ _ _ n eq_refl). exact (Some p).
Defined.

Definition overwrite_mov_nop (c : code) : list StepEquiv.rewrite :=
  collect (map peep_overwrite_mov_nop_rewrite (ParamSplit.matched_pat peep_overwrite_mov_nop_example c)).


Require Import SecOrder Modal ST_setup p_is_pos P_occurs_in_alpha p_occurs_in.
Require Import P_occurs_in_alpha nList_egs Occ_In_Alpha.
Require Import Arith.EqNat my_bool pos_SO2 neg_SO2 my_arith__my_leb_nat.

(* ---------------------------------------------------------------------------- *)
(* Monotonicity *)

Definition Ip_extends (W : Set) (Ip Ip' : predicate -> W -> Prop)
                     (P : predicate) :=
  (forall (w : W), (Ip P w) -> (Ip' P w))
    /\ forall (Q : predicate),
         (match P, Q with
            Pred n, Pred m =>
              ~(n = m) -> (Ip Q = Ip' Q)
          end).

Definition alpha_upward_monotone_P (alpha : SecOrder) (P : predicate) :=
    forall (W : Set) (Iv : FOvariable -> W) (R : W -> W -> Prop)
           (Ip Ip' : predicate -> W -> Prop),
   Ip_extends W Ip Ip' P
      -> (SOturnst W Iv Ip R alpha) ->
                          (SOturnst W Iv Ip' R alpha).

Definition alpha_downward_monotone_P (alpha : SecOrder) (P : predicate) :=
    forall (W : Set) (Iv : FOvariable -> W) (R : W -> W -> Prop)
           (Ip Ip' : predicate -> W -> Prop),
   Ip_extends W Ip' Ip P
      -> (SOturnst W Iv Ip R alpha) ->
                          (SOturnst W Iv Ip' R alpha).

Definition ST_p (p : propvar) : predicate :=
  match p with
    pv n => Pred n
  end.

(* ---------------------------------------------------------------------------- *)

Lemma up_not_occ_SO : forall (alpha : SecOrder) (P : predicate),
  P_occurs_in_alpha alpha P = false ->
    (alpha_upward_monotone_P alpha P /\ alpha_downward_monotone_P alpha P).
Proof.
  intros alpha P; induction alpha;
  unfold alpha_upward_monotone_P in *;
  unfold alpha_downward_monotone_P in *;
    intros Hocc.
    apply conj; intros W Iv R Ip Ip' Ipext SOt;
    unfold P_occurs_in_alpha in Hocc;
    unfold Ip_extends in Ipext;
    destruct Ipext as [l r];
    destruct P as [Pn]; destruct p as [Qm];
    destruct f as [xn];
      simpl in *;
      case_eq (beq_nat Pn Qm); intros Hbeq; rewrite Hbeq in *;
        try discriminate;
      apply beq_nat_false in Hbeq;
      specialize (r (Pred Qm)); simpl in r;
      specialize (r Hbeq);
      apply equal_f with (x := (Iv (Var xn))) in r.
        rewrite r in SOt. assumption.
        rewrite r. assumption.

    destruct f; destruct f0.
    apply conj; intros W Iv R Ip Ip' Ipext SOt;
    simpl in *; assumption.

    destruct f; destruct f0.
    apply conj; intros W Iv R Ip Ip' Ipext SOt;
    simpl in *; assumption.

    apply conj; intros W Iv R Ip Ip' Ipext SOt;
      rewrite SOturnst_allFO in *;
      intros d; specialize (SOt d);
      rewrite <- P_occurs_in_alpha_allFO in Hocc;
      destruct (IHalpha Hocc) as [l r].
      apply l with (Ip := Ip); assumption.
      apply r with (Ip := Ip); assumption.

    apply conj; intros W Iv R Ip Ip' Ipext SOt;
      rewrite SOturnst_exFO in *;
      destruct SOt as [d SOt]; exists d;
      rewrite <- P_occurs_in_alpha_exFO in Hocc;
      destruct (IHalpha Hocc) as [l r].
      apply l with (Ip := Ip); assumption.
      apply r with (Ip := Ip); assumption.

    apply conj; intros W Iv R Ip Ip' Ipext SOt;
      rewrite SOturnst_negSO in *;
      unfold not in *; intros H;
      apply SOt;
      destruct (IHalpha Hocc) as [l r].
      apply r with (Ip := Ip'); assumption.
      apply l with (Ip := Ip'); assumption.

    apply conj; intros W Iv R Ip Ip' Ipext SOt;
    rewrite SOturnst_conjSO in *;
    pose proof (P_occurs_in_alpha_conjSO alpha1 alpha2 P) as H;
    apply contrapos_bool_or in H;
    apply H in Hocc;
    destruct Hocc as [H1 H2]; destruct SOt as [Ha Hb];
    apply conj.
      destruct (IHalpha1 H1) as [l r].
      apply l with (Ip := Ip); assumption.

      destruct (IHalpha2 H2) as [l r].
      apply l with (Ip := Ip); assumption.

      destruct (IHalpha1 H1) as [l r].
      apply r with (Ip := Ip); assumption.

      destruct (IHalpha2 H2) as [l r].
      apply r with (Ip := Ip); assumption.

    apply conj; intros W Iv R Ip Ip' Ipext SOt;
    rewrite SOturnst_disjSO in *;
    pose proof (P_occurs_in_alpha_disjSO alpha1 alpha2 P) as H;
    apply contrapos_bool_or in H;
    apply H in Hocc;
    destruct Hocc as [H1 H2]; destruct SOt as [Ha | Hb].
      left; destruct (IHalpha1 H1) as [l r].
      apply l with (Ip := Ip); assumption.

      right; destruct (IHalpha2 H2) as [l r].
      apply l with (Ip := Ip); assumption.

      left; destruct (IHalpha1 H1) as [l r].
      apply r with (Ip := Ip); assumption.

      right; destruct (IHalpha2 H2) as [l r].
      apply r with (Ip := Ip); assumption.

    apply conj; intros W Iv R Ip Ip' Ipext SOt SOt1;
    rewrite SOturnst_implSO in *;
    pose proof (P_occurs_in_alpha_implSO alpha1 alpha2 P) as H;
    apply contrapos_bool_or in H;
    apply H in Hocc;
    destruct Hocc as [H1 H2]; destruct (IHalpha1 H1) as [l r];
      destruct (IHalpha2 H2) as [l2 r2].
      apply l2 with (Ip := Ip);
      try assumption; apply SOt; apply r with (Ip := Ip'); assumption.

      apply r2 with (Ip := Ip); try assumption.
      apply SOt; apply l with (Ip := Ip'); assumption.

    apply conj; intros W Iv R Ip Ip' Ipext SOt;
    rewrite SOturnst_allSO in *;
    intros pa; specialize (SOt pa);
    pose proof P_occurs_in_alpha_allSO as H;
    specialize (H alpha p P);
    destruct p as [Qm]; destruct P as [Pn];
    apply contrapos_bool_or in H ;
    apply H in Hocc;
    destruct Hocc as [Hbeq Hocc];
    clear H;
    destruct (IHalpha Hocc) as [l r].
    apply l with (Ip := alt_Ip Ip pa (Pred Qm)).
      unfold Ip_extends.
      apply conj.
        intros w H.
        simpl; simpl in H.
        rewrite beq_nat_comm. rewrite beq_nat_comm in H.
        rewrite Hbeq in *.
        unfold Ip_extends in Ipext.
        apply Ipext; assumption.

        intros Q; destruct Q as [Rm]; intros Heq.
        simpl.
        case_eq (beq_nat Qm Rm); intros Hbeq2.
          reflexivity.

          unfold Ip_extends in Ipext.
          destruct Ipext as [H1 H2].
          specialize (H2 (Pred Rm)).
          simpl in H2.
          apply H2; assumption.

        assumption.

      apply r with (Ip := alt_Ip Ip pa (Pred Qm)).
        unfold Ip_extends in *.
        apply conj.
          simpl.
          rewrite beq_nat_comm.
          intros w H.
          rewrite Hbeq in *.
          apply Ipext; assumption.

          intros Q; destruct Q as [Rn].
          intros Heq.
          simpl.
          case (beq_nat Qm Rn).
            reflexivity.

            destruct Ipext as [H1 H2].
            specialize (H2 (Pred Rn)).
            apply H2; assumption.

        assumption.

    apply conj; intros W Iv R Ip Ip' Ipext SOt;
    rewrite SOturnst_exSO in *;
    destruct SOt as [pa SOt]; exists pa;
    pose proof P_occurs_in_alpha_exSO as H;
    specialize (H alpha p P);
    destruct p as [Qm]; destruct P as [Pn];
    apply contrapos_bool_or in H ;
    apply H in Hocc;
    destruct Hocc as [Hbeq Hocc];
    clear H;
    destruct (IHalpha Hocc) as [l r].
    apply l with (Ip := alt_Ip Ip pa (Pred Qm)).
      unfold Ip_extends.
      apply conj.
        intros w H.
        simpl; simpl in H.
        rewrite beq_nat_comm. rewrite beq_nat_comm in H.
        rewrite Hbeq in *.
        unfold Ip_extends in Ipext.
        apply Ipext; assumption.

        intros Q; destruct Q as [Rm]; intros Heq.
        simpl.
        case_eq (beq_nat Qm Rm); intros Hbeq2.
          reflexivity.

          unfold Ip_extends in Ipext.
          destruct Ipext as [H1 H2].
          specialize (H2 (Pred Rm)).
          simpl in H2.
          apply H2; assumption.

        assumption.

      apply r with (Ip := alt_Ip Ip pa (Pred Qm)).
        unfold Ip_extends in *.
        apply conj.
          simpl.
          rewrite beq_nat_comm.
          intros w H.
          rewrite Hbeq in *.
          apply Ipext; assumption.

          intros Q; destruct Q as [Rn].
          intros Heq.
          simpl.
          case (beq_nat Qm Rn).
            reflexivity.

            destruct Ipext as [H1 H2].
            specialize (H2 (Pred Rn)).
            apply H2; assumption.

        assumption.
Qed.

(* -------------------------------------------------------------------- *)

Lemma up_negSO : forall (alpha: SecOrder) (P : predicate),
  alpha_upward_monotone_P alpha P ->
    alpha_downward_monotone_P (negSO alpha) P.
Proof.
  intros alpha P H.
  case_eq (P_occurs_in_alpha (negSO alpha) P); intros Hocc;
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext.
  simpl in *.
  unfold not; intros SOt' H2; apply SOt'.
  apply H with (Ip := Ip'); assumption.
Qed.

Lemma up_conjSO12 : forall (alpha1 alpha2 : SecOrder) (P : predicate),
  alpha_upward_monotone_P alpha1 P ->
    alpha_upward_monotone_P alpha2 P ->
      alpha_upward_monotone_P (conjSO alpha1 alpha2) P.
Proof.
  intros alpha1 alpha2 P H1 H2.
  case_eq (P_occurs_in_alpha (conjSO alpha1 alpha2) P); intros Hocc;
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext SOt.
  simpl in *.
  apply conj; [apply H1 with (Ip := Ip) | apply H2 with (Ip := Ip)];
   try apply SOt; try assumption.
Qed.

Lemma up_disjSO12 : forall (alpha1 alpha2 : SecOrder) (P : predicate),
  alpha_upward_monotone_P alpha1 P ->
    alpha_upward_monotone_P alpha2 P ->
      alpha_upward_monotone_P (disjSO alpha1 alpha2) P.
Proof.
  intros alpha1 alpha2 P H1 H2.
  case_eq (P_occurs_in_alpha (disjSO alpha1 alpha2) P); intros Hocc;
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext SOt.
  simpl in *.
  destruct SOt as [SOt | SOt];
    [left ;apply H1 with (Ip := Ip) |
    right ; apply H2 with (Ip := Ip)]; assumption.
Qed.

Lemma up_implSO12 : forall (alpha1 alpha2 : SecOrder) (P : predicate),
  alpha_downward_monotone_P alpha1 P ->
    alpha_upward_monotone_P alpha2 P ->
      alpha_upward_monotone_P (implSO alpha1 alpha2) P.
Proof.
  intros alpha1 alpha2 P H1 H2.
  case_eq (P_occurs_in_alpha (implSO alpha1 alpha2) P); intros Hocc;
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext SOt.
  simpl in *; intros H.
  apply H2 with (Ip := Ip); try assumption.
  apply SOt.
  apply H1 with (Ip := Ip'); assumption.
Qed.

Lemma up_allFO : forall (alpha : SecOrder) (x : FOvariable)
                         (P : predicate),
    ((alpha_upward_monotone_P alpha P) ->
     (alpha_upward_monotone_P (allFO x alpha) P)).
Proof.
  intros alpha x P Hmono.
  unfold alpha_upward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct x as [xn]; intros d.
  specialize (SOt d).
  specialize (Hmono W (alt_Iv Iv d (Var xn)) R Ip Ip' Ipext).
  apply Hmono.
  assumption.
Qed.

Lemma up_exFO : forall (alpha : SecOrder) (x : FOvariable)
                         (P : predicate),
    ((alpha_upward_monotone_P alpha P) ->
     (alpha_upward_monotone_P (exFO x alpha) P)).
Proof.
  intros alpha x P Hmono.
  unfold alpha_upward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct x as [xn]; destruct SOt as [d SOt].
  exists d.
  specialize (Hmono W (alt_Iv Iv d (Var xn)) R Ip Ip' Ipext).
  apply Hmono.
  assumption.
Qed.

Lemma Ip_ext_alt_Ip : forall (W : Set) (Ip Ip' : predicate -> W -> Prop)
                             (pa : W -> Prop) (P Q : predicate),
  Ip_extends W Ip Ip' P ->
  Ip_extends W (alt_Ip Ip pa Q) (alt_Ip Ip' pa Q) P.
Proof.
  intros W Ip Ip' pa P Q Ipext.
  unfold Ip_extends in *.
  destruct Ipext as [Ipext1 Ipext2].
  destruct P as [Pn]; destruct Q as [Qm].
  apply conj.
    intros w Halt.
    simpl in *.
    case_eq (beq_nat Qm Pn); intros Hbeq; rewrite Hbeq in *.
      assumption.

      apply Ipext1.
      assumption.

    intros R; destruct R as [Rn].
    intros Hneq.
    simpl.
    case_eq (beq_nat Qm Rn); intros Hbeq2.
      reflexivity.

      specialize (Ipext2 (Pred Rn)).
      simpl in *.
      apply Ipext2.
      assumption.
Qed.

Lemma up_allSO : forall (alpha : SecOrder) (P Q: predicate),
    ((alpha_upward_monotone_P alpha P) ->
     (alpha_upward_monotone_P (allSO Q alpha) P)).
Proof.
  intros alpha P Q Hmono.
  unfold alpha_upward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct Q as [Qm]; destruct P as [Pn].
  intros pa.
  specialize (SOt pa).
  specialize (Hmono W Iv R (alt_Ip Ip pa (Pred Qm))
        (alt_Ip Ip' pa (Pred Qm))).
  apply Hmono.
  apply Ip_ext_alt_Ip; assumption.

  assumption.
Qed.

Lemma up_exSO : forall (alpha : SecOrder) (P Q: predicate),
    ((alpha_upward_monotone_P alpha P) ->
     (alpha_upward_monotone_P (exSO Q alpha) P)).
Proof.
  intros alpha P Q Hmono.
  unfold alpha_upward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct Q as [Qm]; destruct P as [Pn].
  destruct SOt as [pa SOt].
  exists pa.
  specialize (Hmono W Iv R (alt_Ip Ip pa (Pred Qm))
        (alt_Ip Ip' pa (Pred Qm))).
  apply Hmono.
  apply Ip_ext_alt_Ip; assumption.

  assumption.
Qed.

(*
Lemma up_allFOx : forall (alpha : SecOrder) (x : FOvariable)
                         (P : predicate),
  P_is_pos_SO alpha P ->
  (alpha_upward_monotone_P (allFO x alpha) P <->
    alpha_upward_monotone_P alpha P).
Proof.
  intros alpha x P Hpos.
  split; intros H.
    unfold alpha_upward_monotone_P in *.
    intros W Iv R Ip Ip' Ipext SOt.
    specialize (H W Iv R Ip Ip' Ipext).
    simpl in H.
    destruct x as [xn].
    simpl in *.
*)

(* -------------------------------------------------------------------- *)

Lemma down_negSO : forall (alpha: SecOrder) (P : predicate),
  alpha_downward_monotone_P alpha P ->
    alpha_upward_monotone_P (negSO alpha) P.
Proof.
  intros alpha P H.
  case_eq (P_occurs_in_alpha (negSO alpha) P); intros Hocc;
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext.
  simpl in *.
  unfold not; intros SOt' H2; apply SOt'.
  apply H with (Ip := Ip'); assumption.
Qed.

Lemma down_conjSO12 : forall (alpha1 alpha2 : SecOrder) (P : predicate),
  alpha_downward_monotone_P alpha1 P ->
    alpha_downward_monotone_P alpha2 P ->
      alpha_downward_monotone_P (conjSO alpha1 alpha2) P.
Proof.
  intros alpha1 alpha2 P H1 H2.
  case_eq (P_occurs_in_alpha (conjSO alpha1 alpha2) P); intros Hocc;
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext SOt.
  simpl in *.
  apply conj; [apply H1 with (Ip := Ip) | apply H2 with (Ip := Ip)];
   try apply SOt; try assumption.
Qed.

Lemma down_disjSO12 : forall (alpha1 alpha2 : SecOrder) (P : predicate),
  alpha_downward_monotone_P alpha1 P ->
    alpha_downward_monotone_P alpha2 P ->
      alpha_downward_monotone_P (disjSO alpha1 alpha2) P.
Proof.
  intros alpha1 alpha2 P H1 H2.
  case_eq (P_occurs_in_alpha (disjSO alpha1 alpha2) P); intros Hocc;
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_downward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext SOt.
  simpl in *.
  destruct SOt as [SOt | SOt];
    [left ;apply H1 with (Ip := Ip) |
    right ; apply H2 with (Ip := Ip)]; try assumption.
Qed.

Lemma down_implSO12 : forall (alpha1 alpha2 : SecOrder) (P : predicate),
  alpha_upward_monotone_P alpha1 P ->
    alpha_downward_monotone_P alpha2 P ->
      alpha_downward_monotone_P (implSO alpha1 alpha2) P.
Proof.
  intros alpha1 alpha2 P H1 H2.
  case_eq (P_occurs_in_alpha (implSO alpha1 alpha2) P); intros Hocc;
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext SOt.
  simpl in *; intros H.
  apply H2 with (Ip := Ip); try assumption.
  apply SOt.
  apply H1 with (Ip := Ip'); assumption.
Qed.

Lemma down_allFO : forall (alpha : SecOrder) (x : FOvariable)
                         (P : predicate),
    ((alpha_downward_monotone_P alpha P) ->
     (alpha_downward_monotone_P (allFO x alpha) P)).
Proof.
  intros alpha x P Hmono.
  unfold alpha_downward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct x as [xn]; intros d.
  specialize (SOt d).
  specialize (Hmono W (alt_Iv Iv d (Var xn)) R Ip Ip' Ipext).
  apply Hmono.
  assumption.
Qed.

Lemma down_exFO : forall (alpha : SecOrder) (x : FOvariable)
                         (P : predicate),
    ((alpha_downward_monotone_P alpha P) ->
     (alpha_downward_monotone_P (exFO x alpha) P)).
Proof.
  intros alpha x P Hmono.
  unfold alpha_downward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct x as [xn]; destruct SOt as [d SOt];
  exists d.
  specialize (Hmono W (alt_Iv Iv d (Var xn)) R Ip Ip' Ipext).
  apply Hmono.
  assumption.
Qed.

Lemma down_allSO : forall (alpha : SecOrder) (P Q: predicate),
    ((alpha_downward_monotone_P alpha P) ->
     (alpha_downward_monotone_P (allSO Q alpha) P)).
Proof.
  intros alpha P Q Hmono.
  unfold alpha_downward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct Q as [Qm]; destruct P as [Pn].
  intros pa.
  specialize (SOt pa).
  specialize (Hmono W Iv R (alt_Ip Ip pa (Pred Qm))
        (alt_Ip  Ip' pa (Pred Qm))).
  apply Hmono.
  apply Ip_ext_alt_Ip; assumption.

  assumption.
Qed.

Lemma down_exSO : forall (alpha : SecOrder) (P Q: predicate),
    ((alpha_downward_monotone_P alpha P) ->
     (alpha_downward_monotone_P (exSO Q alpha) P)).
Proof.
  intros alpha P Q Hmono.
  unfold alpha_downward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct Q as [Qm]; destruct P as [Pn].
  destruct SOt as [pa SOt].
  exists pa.
  specialize (Hmono W Iv R (alt_Ip Ip pa (Pred Qm))
        (alt_Ip Ip' pa (Pred Qm))).
  apply Hmono.
  apply Ip_ext_alt_Ip; assumption.

  assumption.
Qed.

(* ------------------------------------------------------------- *)
(* Outdated coment: Can't prove this using induction since the negSO case requires
   the downward_monotone IH. So it is true and is okay to assume,
   but need to prove downward for is_neg at the same time. *)
Lemma monotonicity_SO_predSO : forall (P Q : predicate) (x : FOvariable),
  P_occurs_in_alpha (predSO Q x) P = true ->
  (P_is_pos_SO (predSO Q x) P -> alpha_upward_monotone_P (predSO Q x) P) /\
  (P_is_neg_SO (predSO Q x) P -> alpha_downward_monotone_P (predSO Q x) P).
Proof.
  intros P Q x HPocc.
  apply conj; intros H.
    unfold alpha_upward_monotone_P.
    intros W Iv R Ip Ip' Ipext SOt.
    simpl in *.
    destruct Q as [Qm]; destruct P as [Pn];
    destruct x as [xn].
    unfold Ip_extends in Ipext.
    destruct Ipext as [Ha Hb].
    case_eq (beq_nat Pn Qm); intros Hbeq.
      rewrite (beq_nat_true _ _ Hbeq) in *.
      apply Ha.
      assumption.

      specialize (Hb (Pred Qm) (beq_nat_false _ _ Hbeq)).
      apply equal_f with (x := (Iv (Var xn))) in Hb.
      rewrite Hb in *.
      assumption.

    unfold alpha_downward_monotone_P.
    intros W Iv R Ip Ip' Ipext SOt.
    simpl in *.
    destruct Q as [Qm]; destruct P as [Pn];
    destruct x as [xn].
    unfold Ip_extends in Ipext.
    destruct Ipext as [Ha Hb].
    case_eq (beq_nat Pn Qm); intros Hbeq.
      rewrite (beq_nat_true _ _ Hbeq) in *.
      unfold P_is_neg_SO in H.
      simpl in H.
      destruct H as [H _].
      specialize (H HPocc 1).
      simpl in H.
      unfold occ_in_alpha in H.
      simpl in *.
      specialize (H (eq_refl _) (eq_refl _)); discriminate.

      unfold P_occurs_in_alpha in HPocc.
      simpl in *.
      rewrite Hbeq in *.
      discriminate.
Qed.

Lemma monotonicity_SO_relatSO : forall (P: predicate) (x y : FOvariable),
  P_occurs_in_alpha (relatSO x y) P = true ->
  (P_is_pos_SO (relatSO x y) P -> alpha_upward_monotone_P (relatSO x y) P) /\
  (P_is_neg_SO (relatSO x y) P -> alpha_downward_monotone_P (relatSO x y) P).
Proof.
  intros P  x y HPocc.
  unfold P_occurs_in_alpha in HPocc.
  destruct x; destruct y.
  simpl in *.
  discriminate.
Qed.

Lemma monotonicity_SO_eqFO : forall (P: predicate) (x y : FOvariable),
  P_occurs_in_alpha (eqFO x y) P = true ->
  (P_is_pos_SO (eqFO x y) P -> alpha_upward_monotone_P (eqFO x y) P) /\
  (P_is_neg_SO (eqFO x y) P -> alpha_downward_monotone_P (eqFO x y) P).
Proof.
  intros P  x y HPocc.
  unfold P_occurs_in_alpha in HPocc.
  destruct x; destruct y.
  simpl in *.
  discriminate.
Qed.

Lemma monotonicity_SO_allFO : forall (alpha : SecOrder) (P: predicate)
                                     (x : FOvariable),
  (P_occurs_in_alpha alpha P = true ->
          (P_is_pos_SO alpha P -> alpha_upward_monotone_P alpha P) /\
          (P_is_neg_SO alpha P -> alpha_downward_monotone_P alpha P)) ->
  P_occurs_in_alpha (allFO x alpha) P = true ->
    (P_is_pos_SO (allFO x alpha) P -> alpha_upward_monotone_P (allFO x alpha) P) /\
    (P_is_neg_SO (allFO x alpha) P -> alpha_downward_monotone_P (allFO x alpha) P).
Proof.
  intros alpha P x IHalpha HPocc.
  rewrite <- P_occurs_in_alpha_allFO with (x := x) in HPocc.
  specialize (IHalpha HPocc).
  apply conj; intros H.
    rewrite P_is_pos_SO_allFO in H.
    apply up_allFO; apply IHalpha;
      assumption.

    rewrite P_is_neg_SO_allFO in H.
    apply down_allFO; apply IHalpha;
      assumption.
Qed.

Lemma monotonicity_SO_exFO : forall (alpha : SecOrder) (P: predicate)
                                     (x : FOvariable),
  (P_occurs_in_alpha alpha P = true ->
          (P_is_pos_SO alpha P -> alpha_upward_monotone_P alpha P) /\
          (P_is_neg_SO alpha P -> alpha_downward_monotone_P alpha P)) ->
  P_occurs_in_alpha (exFO x alpha) P = true ->
    (P_is_pos_SO (exFO x alpha) P -> alpha_upward_monotone_P (exFO x alpha) P) /\
    (P_is_neg_SO (exFO x alpha) P -> alpha_downward_monotone_P (exFO x alpha) P).
Proof.
  intros alpha P x IHalpha HPocc.
  rewrite <- P_occurs_in_alpha_exFO with (x := x) in HPocc.
  specialize (IHalpha HPocc).
  apply conj; intros H.
    rewrite P_is_pos_SO_exFO in H.
    apply up_exFO; apply IHalpha;
      assumption.

    rewrite P_is_neg_SO_exFO in H.
    apply down_exFO; apply IHalpha;
      assumption.
Qed.

Lemma monotonicity_SO_negSO : forall (alpha : SecOrder) (P: predicate),
    (P_occurs_in_alpha alpha P = true ->
          (P_is_pos_SO alpha P -> alpha_upward_monotone_P alpha P) /\
          (P_is_neg_SO alpha P -> alpha_downward_monotone_P alpha P)) ->
     P_occurs_in_alpha (negSO alpha) P = true ->
    ((P_is_pos_SO (negSO alpha) P -> alpha_upward_monotone_P (negSO alpha) P) /\
     (P_is_neg_SO (negSO alpha) P -> alpha_downward_monotone_P (negSO alpha) P)).
Proof.
  intros alpha P IHalpha Hpocc.
  rewrite <- P_occurs_in_alpha_negSO in Hpocc.
  specialize (IHalpha Hpocc).
  split; intros H.
    apply down_negSO.
    apply IHalpha.
    apply P_pos_negSO.
    assumption.

    apply up_negSO.
    apply IHalpha.
    apply P_neg_negSO.
    assumption.
Qed.

Lemma monotonicity_SO_conjSO : forall (alpha1 alpha2 : SecOrder) (P: predicate),
  (P_occurs_in_alpha alpha1 P = true ->
           (P_is_pos_SO alpha1 P -> alpha_upward_monotone_P alpha1 P) /\
           (P_is_neg_SO alpha1 P -> alpha_downward_monotone_P alpha1 P)) ->
  (P_occurs_in_alpha alpha2 P = true ->
           (P_is_pos_SO alpha2 P -> alpha_upward_monotone_P alpha2 P) /\
           (P_is_neg_SO alpha2 P -> alpha_downward_monotone_P alpha2 P)) ->
  P_occurs_in_alpha (conjSO alpha1 alpha2) P = true ->
  (P_is_pos_SO (conjSO alpha1 alpha2) P ->
   alpha_upward_monotone_P (conjSO alpha1 alpha2) P) /\
  (P_is_neg_SO (conjSO alpha1 alpha2) P ->
   alpha_downward_monotone_P (conjSO alpha1 alpha2) P).
Proof.
  intros alpha1 alpha2 P IHalpha1 IHalpha2 Hpocc.
  case_eq (P_occurs_in_alpha alpha1 P); intros Hpocc1.
      apply conj; intros H.
        apply up_conjSO12.
          apply P_is_pos_SO_conjSO_l in H;
            try apply IHalpha1; try assumption.
    case_eq (P_occurs_in_alpha alpha2 P); intros Hpocc2.
          apply P_is_pos_SO_conjSO_r in H;
            try apply IHalpha2; try assumption.

      apply up_not_occ_SO in Hpocc2.
      apply Hpocc2.

        apply down_conjSO12.
          apply P_is_neg_SO_conjSO_l in H;
            try apply IHalpha1; try assumption.
    case_eq (P_occurs_in_alpha alpha2 P); intros Hpocc2.
          apply P_is_neg_SO_conjSO_r in H;
            try apply IHalpha2; try assumption.

      apply up_not_occ_SO in Hpocc2.
      apply Hpocc2.

    case_eq (P_occurs_in_alpha alpha2 P); intros Hpocc2.
      apply conj; intros H.
        apply up_conjSO12.
          apply up_not_occ_SO in Hpocc1.
          apply Hpocc1.

          apply P_is_pos_SO_conjSO_r in H;
          try apply IHalpha2; try assumption.

        apply down_conjSO12.
          apply up_not_occ_SO in Hpocc1.
          apply Hpocc1.

          apply P_is_neg_SO_conjSO_r in H;
          try apply IHalpha2; try assumption.

      apply conj; intros H.
        apply up_conjSO12; apply up_not_occ_SO;
          assumption.

        apply down_conjSO12; apply up_not_occ_SO;
          assumption.
Qed.

Lemma monotonicity_SO_disjSO : forall (alpha1 alpha2 : SecOrder) (P: predicate),
  (P_occurs_in_alpha alpha1 P = true ->
           (P_is_pos_SO alpha1 P -> alpha_upward_monotone_P alpha1 P) /\
           (P_is_neg_SO alpha1 P -> alpha_downward_monotone_P alpha1 P)) ->
  (P_occurs_in_alpha alpha2 P = true ->
           (P_is_pos_SO alpha2 P -> alpha_upward_monotone_P alpha2 P) /\
           (P_is_neg_SO alpha2 P -> alpha_downward_monotone_P alpha2 P)) ->
  P_occurs_in_alpha (disjSO alpha1 alpha2) P = true ->
  (P_is_pos_SO (disjSO alpha1 alpha2) P ->
   alpha_upward_monotone_P (disjSO alpha1 alpha2) P) /\
  (P_is_neg_SO (disjSO alpha1 alpha2) P ->
   alpha_downward_monotone_P (disjSO alpha1 alpha2) P).
Proof.
  intros alpha1 alpha2 P IHalpha1 IHalpha2 Hpocc.
  case_eq (P_occurs_in_alpha alpha1 P); intros Hpocc1.
      apply conj; intros H.
        apply up_disjSO12.
          apply P_is_pos_SO_conjSO_l in H;
            try apply IHalpha1; try assumption.
    case_eq (P_occurs_in_alpha alpha2 P); intros Hpocc2.
          apply P_is_pos_SO_conjSO_r in H;
            try apply IHalpha2; try assumption.

      apply up_not_occ_SO in Hpocc2.
      apply Hpocc2.

        apply down_disjSO12.
          apply P_is_neg_SO_conjSO_l in H;
            try apply IHalpha1; try assumption.
    case_eq (P_occurs_in_alpha alpha2 P); intros Hpocc2.
          apply P_is_neg_SO_conjSO_r in H;
            try apply IHalpha2; try assumption.

      apply up_not_occ_SO in Hpocc2.
      apply Hpocc2.

    case_eq (P_occurs_in_alpha alpha2 P); intros Hpocc2.
      apply conj; intros H.
        apply up_disjSO12.
          apply up_not_occ_SO in Hpocc1.
          apply Hpocc1.

          apply P_is_pos_SO_conjSO_r in H;
          try apply IHalpha2; try assumption.

        apply down_disjSO12.
          apply up_not_occ_SO in Hpocc1.
          apply Hpocc1.

          apply P_is_neg_SO_conjSO_r in H;
          try apply IHalpha2; try assumption.

      apply conj; intros H.
        apply up_disjSO12; apply up_not_occ_SO;
          assumption.

        apply down_disjSO12; apply up_not_occ_SO;
          assumption.
Qed.

Lemma monotonicity_SO_implSO : forall (alpha1 alpha2 : SecOrder) (P: predicate),
  (P_occurs_in_alpha alpha1 P = true ->
           (P_is_pos_SO alpha1 P -> alpha_upward_monotone_P alpha1 P) /\
           (P_is_neg_SO alpha1 P -> alpha_downward_monotone_P alpha1 P)) ->
  (P_occurs_in_alpha alpha2 P = true ->
           (P_is_pos_SO alpha2 P -> alpha_upward_monotone_P alpha2 P) /\
           (P_is_neg_SO alpha2 P -> alpha_downward_monotone_P alpha2 P)) ->
  P_occurs_in_alpha (implSO alpha1 alpha2) P = true ->
  (P_is_pos_SO (implSO alpha1 alpha2) P ->
   alpha_upward_monotone_P (implSO alpha1 alpha2) P) /\
  (P_is_neg_SO (implSO alpha1 alpha2) P ->
   alpha_downward_monotone_P (implSO alpha1 alpha2) P).
Proof.
  intros alpha1 alpha2 P IHalpha1 IHalpha2 Hpocc.
  case_eq (P_occurs_in_alpha alpha1 P); intros Hpocc1.
      apply conj; intros H.
        apply up_implSO12.
          apply P_is_pos_SO_implSO_l in H;
            try apply IHalpha1; try assumption.
    case_eq (P_occurs_in_alpha alpha2 P); intros Hpocc2.
          apply P_is_pos_SO_implSO_r in H;
            try apply IHalpha2; try assumption.

      apply up_not_occ_SO in Hpocc2.
      apply Hpocc2.

        apply down_implSO12.
          apply P_is_neg_SO_implSO_l in H;
            try apply IHalpha1; try assumption.
    case_eq (P_occurs_in_alpha alpha2 P); intros Hpocc2.
          apply P_is_neg_SO_implSO_r in H;
            try apply IHalpha2; try assumption.

      apply up_not_occ_SO in Hpocc2.
      apply Hpocc2.

    case_eq (P_occurs_in_alpha alpha2 P); intros Hpocc2.
      apply conj; intros H.
        apply up_implSO12.
          apply up_not_occ_SO in Hpocc1.
          apply Hpocc1.

          apply P_is_pos_SO_implSO_r in H;
          try apply IHalpha2; try assumption.

        apply down_implSO12.
          apply up_not_occ_SO in Hpocc1.
          apply Hpocc1.

          apply P_is_neg_SO_implSO_r in H;
          try apply IHalpha2; try assumption.

      apply conj; intros H.
        apply up_implSO12; apply up_not_occ_SO;
          assumption.

        apply down_implSO12; apply up_not_occ_SO;
          assumption.
Qed.

Lemma monotonicity_SO_allSO : forall (alpha : SecOrder) (P Q: predicate),
  (P_occurs_in_alpha alpha P = true ->
          (P_is_pos_SO alpha P -> alpha_upward_monotone_P alpha P) /\
          (P_is_neg_SO alpha P -> alpha_downward_monotone_P alpha P)) ->
  P_occurs_in_alpha (allSO Q alpha) P = true ->
  (P_is_pos_SO (allSO Q alpha) P -> alpha_upward_monotone_P (allSO Q alpha) P) /\
  (P_is_neg_SO (allSO Q alpha) P -> alpha_downward_monotone_P (allSO Q alpha) P).
Proof.
  intros alpha P Q IHalpha Hpocc.
  destruct P as [Pn]; destruct Q as [Qm].
  apply conj; intros H.
    apply up_allSO.
    case_eq (P_occurs_in_alpha alpha (Pred Pn)); intros Hpocc2.
      apply IHalpha; try assumption.
      apply P_is_pos_SO_allSO in H; assumption.

      apply up_not_occ_SO.
      assumption.

    apply down_allSO.
    case_eq (P_occurs_in_alpha alpha (Pred Pn)); intros Hpocc2.
      apply IHalpha; try assumption.
      apply P_is_neg_SO_allSO in H; assumption.

      apply up_not_occ_SO.
      assumption.
Qed.

Lemma monotonicity_SO_exSO : forall (alpha : SecOrder) (P Q: predicate),
  (P_occurs_in_alpha alpha P = true ->
          (P_is_pos_SO alpha P -> alpha_upward_monotone_P alpha P) /\
          (P_is_neg_SO alpha P -> alpha_downward_monotone_P alpha P)) ->
  P_occurs_in_alpha (allSO Q alpha) P = true ->
  (P_is_pos_SO (exSO Q alpha) P -> alpha_upward_monotone_P (exSO Q alpha) P) /\
  (P_is_neg_SO (exSO Q alpha) P -> alpha_downward_monotone_P (exSO Q alpha) P).
Proof.
  intros alpha P Q IHalpha Hpocc.
  destruct P as [Pn]; destruct Q as [Qm].
  apply conj; intros H.
    apply up_exSO.
    case_eq (P_occurs_in_alpha alpha (Pred Pn)); intros Hpocc2.
      apply IHalpha; try assumption.
      apply P_is_pos_SO_exSO in H; assumption.

      apply up_not_occ_SO.
      assumption.

    apply down_exSO.
    case_eq (P_occurs_in_alpha alpha (Pred Pn)); intros Hpocc2.
      apply IHalpha; try assumption.
      apply P_is_neg_SO_exSO in H; assumption.

      apply up_not_occ_SO.
      assumption.
Qed.

Lemma monotonicity_SO : forall (alpha : SecOrder) (P : predicate),
  P_occurs_in_alpha alpha P = true ->
    (P_is_pos_SO alpha P ->
      alpha_upward_monotone_P alpha P) /\
    (P_is_neg_SO alpha P ->
      alpha_downward_monotone_P alpha P).
Proof.
  intros alpha P.
  induction alpha.
    apply monotonicity_SO_predSO.
    apply monotonicity_SO_relatSO.
    apply monotonicity_SO_eqFO.
    apply monotonicity_SO_allFO; assumption.
    apply monotonicity_SO_exFO; assumption.
    apply monotonicity_SO_negSO; assumption.
    apply monotonicity_SO_conjSO; assumption.
    apply monotonicity_SO_disjSO; assumption.
    apply monotonicity_SO_implSO; assumption.
    apply monotonicity_SO_allSO; assumption.
    apply monotonicity_SO_exSO; assumption.
Qed.

(* ---------------------------------------------------------------------------- *)

Lemma Ip_ext_pa_f : forall (W : Set)
                    (Ip : predicate -> W -> Prop)
                    (P : predicate)
                    (pa : W -> Prop),
  Ip_extends W (alt_Ip Ip pa_f P) (alt_Ip Ip pa P) P.
Proof.
  intros W Ip P pa.
  unfold Ip_extends.
  apply conj.
    intros w H.
    unfold pa_f in *.
    destruct P.
    simpl in *.
    rewrite <- beq_nat_refl in *.
    contradiction.

    intros Q.
    destruct P as [Pn]; destruct Q as [Qm].
    intros H.
    unfold not in *.
    unfold pa_f.
    simpl.
    case_eq (beq_nat Pn Qm); intros Hbeq.
      specialize (H (beq_nat_true _ _ Hbeq)).
      contradiction.

      reflexivity.
Qed.


Require Import ssreflect.
Require Import Coq.Classes.EquivDec.
Require Import Metalib.Metatheory.

Require Import Coq.Structures.Orders.
Require Import Coq.Bool.Sumbool.
Require Import Coq.Program.Equality.
Require Import Coq.Classes.RelationClasses.

Require Import dqtt_ott.
Require Import dqtt_inf.
Require Import usage.
Require Import dctx.
Require Import dctx_sub.
Require Import semimodule.
Require Import tactics.
Require Import structural.

Require Export beta.

(* Lemma 6.1 *)
Lemma Typing_regularity :
  forall {D G a B}, Typing D G a B -> exists G', Typing D G' B a_Type.
Proof.
  intros. induction H.
  all: try destruct IHTyping as [G' h].
  all: try destruct IHTyping1 as [G1' h1].
  all: try destruct IHTyping2 as [G2' h2].

  all: try solve [eexists; eauto].
  all: try solve [eexists; eapply T_weak; eauto].
  - pick fresh x for (L \u fv_tm_tm B \u dom D5).
    specialize (H x ltac:(auto)).
    specialize (H0 x ltac:(auto)).
    destruct H0 as [G0 h0].
    move: (Typing_ctx h0) => C0.
    destruct_ctx.
    eexists.
    eapply (T_pi_exists x); eauto.
    asimpl in h0.
    eapply h0.
  - apply invert_pi in h1.
    move: h1 => [_ [G1'' [G2'' [r [? [? hb]]]]]].
    pick fresh x for (dom D5 \u fv_tm_tm B).
    specialize (hb x ltac:(auto)).
    move: (substitution _ nil _ nil _ _ _ _ _ hb _ _ H0) => hs.
    asimpl in hs.
    erewrite <- subst_tm_tm_intro in hs; auto.
    eauto.
  - (* UnitE *)
    pick_fresh x.
    specialize (H2 x ltac:(auto)).
    have LC: lc_tm a. { eapply Typing_lc; eauto. }
    move: (fun x y => substitution x nil y nil) => s.
    eapply s in H. 2: { simpl_env. apply H2. }
    simpl_env in H.
    rewrite subst_tm_tm_open_tm_wrt_tm in H; auto.
    rewrite subst_tm_same in H; auto.
    simpl in H.
    rewrite subst_tm_tm_fresh_eq in H. fsetdec.
    eexists. eauto.
  - (* unbox *)
    pick_fresh x.
    specialize (H2 x ltac:(auto)).
    have LC: lc_tm a. { eapply Typing_lc; eauto. }
    move: (fun x y => substitution x nil y nil) => s.
    eapply s in H. 2: { simpl_env. apply H2. }
    simpl_env in H.
    rewrite subst_tm_tm_open_tm_wrt_tm in H; auto.
    rewrite subst_tm_same in H; auto.
    simpl in H.
    rewrite subst_tm_tm_fresh_eq in H. fsetdec.
    eexists. eauto.
  - (* inj1 *)
    eexists. eapply T_sum; eauto.
  - (* inj2 *)
    eexists. eapply T_sum; eauto.
  - (* case *)
    pick fresh x.
    repeat match goal with [H : forall x, x `notin` ?L -> _ |- _ ] => specialize (H x ltac:(auto)) end.
    repeat match goal with [H : forall y, y `notin` ?L -> _ |- _ ] => specialize (H x ltac:(auto)) end.
    repeat match goal with [H : exists G' , Typing _ _ _ _ |- _ ] => destruct H end.
    move: (fun y => substitution D5 nil y nil) => s.
    match goal with [H5 : Typing _ _ (open_tm_wrt_tm ?B _) a_Type |- _ ] =>
                    eapply s in H5; eauto; clear s;
                    asimpl in H5;
                    rewrite subst_tm_tm_open_tm_wrt_tm in H5; eauto using Typing_lc;
                    rewrite subst_tm_same in H5; auto;
                    rewrite subst_tm_tm_fresh_eq in H5; eauto
    end.
  - pick fresh x for (L \u fv_tm_tm B \u dom D5).
    specialize (H1 x ltac:(auto)).
    specialize (H2 x ltac:(auto)).
    destruct H2 as [G0 h0].
    move: (Typing_ctx h0) => C0.
    destruct_ctx.
    eexists.
    eapply (T_Sigma_exists x); eauto.
  - (* spread *)
    subst A.
    pick fresh x.
    repeat match goal with [H : forall x, x `notin` ?L -> _ |- _ ] => specialize (H x ltac:(auto)) end.
    repeat match goal with [H : forall y, y `notin` ?L -> _ |- _ ] => specialize (H x ltac:(auto)) end.
    repeat match goal with [H : exists G' , Typing _ _ _ _ |- _ ] => destruct H end.
    move: (fun y => substitution D5 nil y nil) => s.
    match goal with [H5 : Typing _ _ (open_tm_wrt_tm ?B _) a_Type |- _ ] =>
                    eapply s in H5; eauto; clear s;
                    asimpl in H5;
                    rewrite subst_tm_tm_open_tm_wrt_tm in H5; eauto using Typing_lc;
                    rewrite subst_tm_same in H5; auto;
                    rewrite subst_tm_tm_fresh_eq in H5; eauto
    end.
Qed.

Lemma invert_Lam D G q a A C :
  Typing D G (a_Lam q A a) C ->
     (forall x, x `notin` fv_tm_tm a `union` dom G `union` dom D ->
           exists B,  Beta C (a_Pi q A B) /\
           exists G1, Typing D G1 (a_Pi q A B) a_Type /\
           Typing
             (x ~ Tm A ++ D)
             ([(x, (q, Tm A))] ++ G) (open_tm_wrt_tm a (a_Var_f x))
                                     (open_tm_wrt_tm B (a_Var_f x))).
Proof.
  intros HA.
  dependent induction HA; intros y Fr.
  - have D: dom G1 = dom G2. eapply dom_ctx_sub; eauto.
    rewrite <- D in Fr.
    specialize (IHHA q a A ltac:(auto) y ltac:(auto)).
    move: IHHA => [B [HB [GA [hA HT]]]].
    exists B. split; auto.
    exists GA. split; auto.
    eapply T_sub. eauto. econstructor; eauto. reflexivity.
  - specialize (IHHA1 _ _ _  ltac:(auto) y ltac:(auto)).
    clear IHHA2.
    move: IHHA1 => [B0 [HB [GA [hA  HT]]]].
    exists B0. split. auto.
    exists (x ~ (0, Tm A0) ++ GA). split.
    eapply T_weak; eauto.
    eapply weakening. eauto. eclarify_ctx. solve_uniq. eauto.
  - (* lam *)
    clear IHHA. clear H0.
    exists B. split.
    + eapply B_Refl.
      pick fresh z.
      move: (Typing_regularity (H z ltac:(auto))) => [GG TB].
      eapply (lc_a_Pi_exists z);
      eapply Typing_lc; eauto.
    + pick fresh z.
      move: (H z ltac:(auto)) => h.
      move: (Typing_regularity h) => [G h1].
      move: (Typing_ctx h1) => C1.
      destruct_ctx.
      eexists. split.
      eapply (T_pi_exists z); eauto.
      eapply h1.
      move: (Typing_rename _ _ _ z y _ _ _ _ HA h ltac:(auto)) => rn.
      rewrite subst_tm_tm_open_tm_wrt_tm in rn. auto.
      rewrite subst_tm_same in rn. auto.
      rewrite subst_tm_tm_fresh_eq in rn. fsetdec.
      rewrite subst_tm_tm_open_tm_wrt_tm in rn. auto.
      rewrite subst_tm_same in rn. auto.
      rewrite subst_tm_tm_fresh_eq in rn. fsetdec.
      eapply rn.
  - (* conv *)
    specialize (IHHA1 _ _ _ ltac:(reflexivity) y Fr).
    destruct IHHA1 as [B0 [BB [G2' [T1 T2]]]]. clear IHHA2.
    exists B0.
    split. eapply B_Trans. eapply B_Sym. eauto. eauto.
    exists G2'. split. eauto.
    eauto.
Qed.

Lemma invert_Unit {D G A} :
  Typing D G a_TmUnit A ->
  exists G1, Beta A a_TyUnit /\ ctx_mul 0 G1 = G1 /\ ctx_sub D G1 G.
Proof.
  intros HA.
  dependent induction HA.
  - destruct IHHA as [G3 [h0 [ h1 h2]]]; auto.
    exists G3. subst. repeat split; auto. transitivity G1; auto.
  - destruct IHHA1 as [G3 [h0 [h1 h2]]]; auto. clear IHHA2.
    exists (x ~ (0, Tm A) ++ G3). repeat split; auto. simpl.  ring_simpl. f_equal.  auto.
    econstructor; auto. reflexivity.
  - destruct IHHA1 as [G3 [h0 [h1 h2]]]; auto.
    exists G3. repeat split; auto.
    eapply B_Trans. eapply B_Sym. eauto. eauto.
  - exists nil. repeat split; auto.
Qed.

Lemma invert_box {D G q a A} :
 Typing D G (a_box q a) A ->
 exists A0,
   Beta A (a_Box q A0) /\
   exists G0, ctx_sub D (ctx_mul q G0) G /\ Typing D G0 a A0.
Proof.
  intros HA.
  dependent induction HA.
  + edestruct IHHA as [A0 [HB [G0 [SS TA]]]]. eauto.
    eexists. split. eauto.
    exists G0. split.
    transitivity G1; auto. auto.
  + clear IHHA2.
    specialize (IHHA1 q a ltac:(auto)).
    move: IHHA1 => [A0 [HB [G0 [SS TA]]]].
    eexists. split. eauto.
    exists (x ~ (0, Tm A) ++ G0). split.
    econstructor. auto. rewrite qmul_0_r. reflexivity.
    eauto. eauto.
    eapply T_weak. eauto. auto. eauto.
  + clear IHHA2.
    specialize (IHHA1 q a ltac:(auto)).
    move: IHHA1 => [A0 [HB [G0 [SS TA]]]].
    eexists.  split. eapply B_Trans. eapply B_Sym; eauto. eauto.
    eexists. split. eauto. auto.
  + clear IHHA.
    move: (Typing_regularity HA) => [GA TA].
    eexists.  split. eapply B_Refl. econstructor. eapply Typing_lc; eauto.
    exists G. split.
    eapply ctx_sub_refl. eclarify_ctx.
    auto.
Qed.

Lemma invert_Box {D G q A B} :
   Typing D G (a_Box q A) B ->
   Beta B a_Type /\ Typing D G A a_Type.
Proof.
  intros HA.
  dependent induction HA; intros.
  + specialize (IHHA _ _ ltac:(auto)). destruct IHHA.
    split. auto.
    eapply T_sub; eauto.
  + specialize (IHHA1 _ _ ltac:(auto)). destruct IHHA1.
    split. auto.
    eapply T_weak; eauto.
  + specialize (IHHA1 _ _ ltac:(auto)). destruct IHHA1.
    split. eapply B_Trans. eapply B_Sym. eauto. eauto. auto.
  + clear IHHA.
    split. eapply B_Refl. eauto. eauto.
Qed.

Lemma invert_inj1 :
       forall {D G a A}, Typing D G (a_Inj1 a) A ->
                    exists A1, exists A2, exists G1, Beta (a_Sum A1 A2) A /\
                                Typing D G a A1 /\ Typing D G1 A2 a_Type.
Proof. intros D G a A TA. dependent induction TA.
       - destruct (IHTA _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         exists A1. exists A2. eexists. split. auto. split.
         eapply T_sub; eauto. eauto.
       - destruct (IHTA1 _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         eexists. eexists. eexists.
         split. eauto. split.
         eapply T_weak; auto. eauto.
         eapply T_weak; auto. eauto. eauto.
       - destruct (IHTA1 _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         eexists. eexists. eexists.
         split. eapply B_Trans. eauto. eauto.
         split; eauto.
       - eexists. eexists. eexists.
         split. eapply B_Refl. econstructor. eapply Typing_lc2; eauto. eapply Typing_lc; eauto.
         split; eauto.
Qed.

Lemma invert_inj2 :
       forall {D G a A}, Typing D G (a_Inj2 a) A ->
                    exists A1, exists A2, exists G1, Beta (a_Sum A1 A2) A /\
                                Typing D G a A2 /\ Typing D G1 A1 a_Type.
Proof. intros D G a A TA. dependent induction TA.
       - destruct (IHTA _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         exists A1. exists A2. eexists. split. auto. split.
         eapply T_sub; eauto. eauto.
       - destruct (IHTA1 _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         eexists. eexists. eexists.
         split. eauto. split.
         eapply T_weak; auto. eauto.
         eapply T_weak; auto. eauto. eauto.
       - destruct (IHTA1 _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         eexists. eexists. eexists.
         split. eapply B_Trans. eauto. eauto.
         split; eauto.
       - eexists. eexists. eexists.
         split. eapply B_Refl. econstructor. eapply Typing_lc; eauto. eapply Typing_lc2; eauto.
         split; eauto.
Qed.

Lemma invert_Sum : forall {D G A1 A2 B},
       Typing D G (a_Sum A1 A2) B ->
       Beta B a_Type /\
       exists G1, exists G2, ctx_sub D (ctx_plus G1 G2) G /\ Typing D G1 A1 a_Type /\ Typing D G2 A2 a_Type.
Proof.
       intros. dependent induction H.
       - destruct (IHTyping _ _ ltac:(auto)) as [Be [G1' [G2' [S [T1 T2]]]]].
         split. auto. exists G1'. exists G2'.
         split. transitivity G1; auto.
         split; auto.
       - destruct (IHTyping1 _ _ ltac:(auto)) as [Be [G1' [G2' [S [T1 T2]]]]].
         split. auto. exists (x ~ (0, Tm A) ++ G1'). exists (x ~ (0, Tm A) ++ G2').
         split. econstructor; eauto. ring_simpl; reflexivity.
         split. eapply T_weak; eauto.
                eapply T_weak; eauto.
       - destruct (IHTyping1 _ _ ltac:(auto)) as [Be [G1' [G2' [S [T1 T2]]]]].
         split. eapply B_Trans. eapply B_Sym. eauto. auto.
         exists G1'. exists G2'. split. eauto. split. eauto. eauto.
       - split. eapply B_Refl. auto.
         exists G1. exists G2. split. eapply ctx_sub_refl. eclarify_ctx.
         split; auto.
Qed.

Lemma invert_Tensor : forall {D G a1 a2 B},
       Typing D G (a_Tensor a1 a2) B ->
       exists A1, exists A2, exists q, Beta B (a_Sigma q A1 A2) /\
       exists G1, exists G2, exists G3, exists r,
             ctx_sub D (ctx_plus (ctx_mul q G1) G2) G
             /\ Typing D G1 a1 A1
             /\ Typing D G2 a2 (open_tm_wrt_tm A2 a1)
             /\ (forall x, x `notin` dom D ->
                    Typing (x ~ Tm A1 ++ D) (x ~ (r, Tm A1) ++ G3) (open_tm_wrt_tm A2 (a_Var_f x)) a_Type).
Proof.
  intros. dependent induction H.
  - destruct (IHTyping a1 a2 ltac:(auto)) as [A1 [A2 [q [BA [G1' [G2' [G3 [r [SS [Ta1 [Ta2 U]]]]]]]]]]].
    exists A1. exists A2. exists q. split. auto.
    exists G1'. exists G2'. exists G3. exists r.
    repeat split; auto. transitivity G1; auto.
  - destruct (IHTyping1 _ _ ltac:(auto))  as [A1 [A2 [q [BA [G1' [G2' [G3 [r [SS [Ta1 [Ta2 U]]]]]]]]]]].
    exists A1. exists A2. exists q. split. auto.
    exists (x ~ (0, Tm A) ++ G1'). exists (x ~ (0, Tm A) ++ G2'). exists (x ~ (0, Tm A) ++ G3). exists r.
    repeat split; auto. econstructor; eauto.  ring_simpl; reflexivity.
    eapply T_weak; eauto.
    eapply T_weak; eauto.
    intros. simpl in H2.
    move: (U x0 ltac:(auto)) => TB.
    eapply weakening; eauto.
    move: (Typing_ctx TB) => C. destruct_ctx.
    solve_ctx.
  - destruct (IHTyping1 _ _ ltac:(auto))  as [A1 [A2 [q [BA [G1' [G2' [G3 [r [SS [Ta1 [Ta2 U]]]]]]]]]]].
    exists A1. exists A2. exists q. split. eapply B_Trans. eapply B_Sym. eauto. auto.
    exists G1'. exists G2'. exists G3. exists r.
    repeat split; eauto.
  -  clear H2 IHTyping1 IHTyping2.
     move: (Typing_ctx H) => C1. move: (Typing_ctx H0) => C2.
     have LC: lc_tm (a_Sigma q A B). {
       pick fresh z.
       eapply lc_a_Sigma_exists. eapply Typing_lc2; eauto.
       eapply Typing_lc; eauto.
     }
     exists A. exists B. exists q. split. apply B_Refl; auto.
     exists G1. exists G2. exists G3. exists r.
     repeat split; eauto.
     eapply ctx_sub_refl. solve_ctx.
     pick fresh z.
     intros x Frx.
     move: (Typing_regularity H) => [GA TA].
     move: (H1 z ltac:(auto)) => h.
     move: (Typing_regularity h) => [G h1].
     move: (Typing_ctx h1) => C3.
     destruct_ctx.
     move: (Typing_rename _ _ _ z x _ _ _ _ TA h ltac:(auto)) => rn.
     rewrite subst_tm_tm_open_tm_wrt_tm in rn. auto.
     rewrite subst_tm_same in rn. auto.
     rewrite subst_tm_tm_fresh_eq in rn. fsetdec.
     asimpl in rn.
     eapply rn.
Qed.

(* Theorem 6.4 *)
Lemma preservation: forall D G a A, Typing D G a A -> forall a', Step a a' -> Typing D G a' A.
Proof.
  induction 1; intros a' St.
  all: try solve [inversion St].
  - (* sub *) eapply T_sub; eauto.
  - (* weak *) eapply T_weak; eauto.
  - (* app *)
    inversion St; subst.
    + eapply T_app. eauto. auto.
    + (* beta *)
      clear IHTyping1. clear IHTyping2.
      move: (Typing_regularity  H) => [GP TP].
      move: (Typing_regularity  H0) => [GA TA].
      move: (invert_pi _ _ _ _ _ _ TP) => [M [G1' [G2' [r [S1 [T1 U]]]]]].

      pick fresh x for (fv_tm_tm a0 `union` dom D5 `union` fv_tm_tm B \u dom G1).
      move: (U x ltac:(auto)) => UU.

      rewrite (subst_tm_tm_intro x a0). fsetdec.
      rewrite (subst_tm_tm_intro x B). fsetdec.

      eapply invert_Lam with (x:=x) in H. 2: fsetdec.
      move: H => [B0 [EQ [GA0 [TP0 Ta]]]].
      move: (invert_Beta_a_Pi0 EQ) => h0.
      move: (invert_Beta_a_Pi1 EQ) => h1.
      move: (invert_Beta_a_Pi2 EQ) => h2.
      move: (invert_pi _ _ _ _ _ _ TP0) => [? [G3 [G4 [r1 [h3 [h4 h5]]]]]].
      subst q.
      move: (Typing_ctx_fv x TP0 ltac:(auto)) => FV. asimpl in FV.
      have h00: Typing D5 G2 b A0. eapply T_conv; eauto.
      move: (substitution _ nil _ nil _ _ _ _ _ Ta _ _ h00) => SS.
      asimpl in SS.
      move: (Typing_regularity  SS) => [G0 TB0].
      move: (substitution _ nil _ nil _ _ _ _ _ UU _ _ H0) => SU. asimpl in SU.
      eapply T_conv. eauto. eauto.
      move: (h2 x ltac:(auto)) => BV.
      apply subst_Beta1. eapply Typing_lc; eauto.
      eapply B_Sym. auto.
 - (* beta *)
   eapply T_conv; eauto.
 - (* letunit *)
   inversion St; subst.
   + (* cong *)
     eapply T_conv.
     eapply T_UnitE; eauto.
     ++ pick fresh x.
       move: (H2 x ltac:(auto)) => h1.
       move: (substitution _ nil _ nil _ _ _ _ _ h1 _ _ H) => SU. asimpl in SU.
       rewrite subst_tm_tm_open_tm_wrt_tm in SU. eapply Typing_lc; eauto.
       rewrite subst_tm_tm_fresh_eq in SU. eauto.
       rewrite subst_tm_same in SU. auto. eauto.
     ++ pick fresh x. rewrite (subst_tm_tm_intro x). eauto. rewrite (subst_tm_tm_intro x B a). eauto.
        eapply subst_Beta2.
        move: (H3 x ltac:(auto)) => h. eapply Typing_lc. eauto.
        eapply B_Sym.
        eapply B_Step.
        auto.
   + (* beta *)
     move: (invert_Unit H) => [G4 [h0 [h1 h2]]].
     eapply T_sub. eauto.
     rewrite (ctx_plus_comm _ D5); eclarify_ctx.
     eapply ctx_plus_sub; eclarify_ctx.
     auto.
 - (* let box *)
   inversion St; subst.
   + (* Cong *)
     clear H1 H3.
     eapply T_conv.
     ++ eapply T_letbox with (L := L).
        eapply IHTyping. auto.
        move=> x Fr.
        eapply H0. auto.
        move=> x Fr.
        eapply H2. auto.
     ++ pick fresh x.
        move: (H2 x ltac:(auto)) => TB.
        move: (substitution _ nil _ nil _ _ _ _ _ TB _ _ H) => SU. asimpl in SU.
        rewrite subst_tm_tm_open_tm_wrt_tm in SU.
        eapply Typing_lc; eauto.
        rewrite subst_tm_same in SU. auto.
        rewrite subst_tm_tm_fresh_eq in SU. fsetdec.
        eauto.
     ++ pick fresh x.
        move: (H2 x ltac:(auto)) => TB.
        rewrite (subst_tm_tm_intro x). eauto.
        rewrite (subst_tm_tm_intro x B a). eauto.
        eapply subst_Beta2.
        eapply Typing_lc. eauto.
        eapply B_Sym.
        eapply B_Step.
        auto.
   + (* beta *)
     clear H3. clear H1.
     pick fresh x.
     move: (H0 x ltac:(auto)) => h1.
     move: (Typing_ctx h1) => CA. destruct_ctx.
     move: (invert_box H) => [A0 [BB [G [T1 T2]]]].
     move: (invert_Beta_Box1 BB) => BA.
     move: (invert_Beta_Box2 BB) => eq. subst q0.
     move: (Typing_regularity  H) => [GA TBA].
     move: (invert_Box TBA) => [h0 h2].
     have Ta0: (Typing D5 G a0 A). eapply T_conv. eapply T2. eauto. eapply B_Sym. eauto.
     move: (substitution _ nil _ nil _ _ _ _ _ h1 _ _ Ta0) => SU. asimpl in SU.
     rewrite subst_tm_tm_open_tm_wrt_tm in SU. eapply Typing_lc; eauto.
     rewrite subst_tm_same in SU. auto.
     rewrite subst_tm_tm_open_tm_wrt_tm in SU. eapply Typing_lc; eauto.
     simpl in SU. rewrite eq_dec_refl in SU.
     rewrite subst_tm_tm_fresh_eq in SU. fsetdec.
     rewrite subst_tm_tm_fresh_eq in SU. fsetdec.
     eapply T_sub. eauto.
     erewrite ctx_plus_comm; eclarify_ctx.
     eapply ctx_sub_ctx_plus. auto.
     eapply ctx_sub_refl. auto.
 - (* case *)
   inversion St; subst.
   + (* case cong *)
     have TBa : Typing D5 (ctx_plus G3 (ctx_mul r G1)) (open_tm_wrt_tm B a) a_Type.
     {
       pick fresh x.
       match goal with [H5 : forall y, y `notin` L -> _ ,
                        H0  : Typing ?D ?G a _  |- _ ] =>
          move: (H5 x ltac:(auto)) => h1;
          move: (substitution _ nil _ nil _ _ _ _ _ h1 _ _ H0) => SU
       end.
       asimpl in SU.
       rewrite subst_tm_tm_open_tm_wrt_tm in SU.
       eapply Typing_lc; eauto.
       rewrite subst_tm_same in SU. auto.
       rewrite subst_tm_tm_fresh_eq in SU. fsetdec.
       eauto.
     }
     eapply T_conv.
     eapply T_case; auto.
     eauto.
     pick fresh x.
     rewrite (subst_tm_tm_intro x B a'0); auto.
     rewrite (subst_tm_tm_intro x B a); auto.
     eapply subst_Beta2.
     eapply Typing_lc. eauto.
     eapply B_Sym.
     eapply B_Step.
     auto.
   + (* case Beta1 *)
     match goal with [H0 : Typing ?D ?G  _ (a_Sum _ _) |- _ ] =>
        move: (invert_inj1 H0) => [A1' [A2' [G1' [Be [T1 T2]]]]];
        move: (Typing_regularity H0) => [Gr TS]
     end.
     move: (invert_Beta_Sum1 Be) => Be1.
     move: (invert_Sum TS) => [BB [G3' [G4' [S [Ta Tb]]]]].
     eapply Typing_e.
     eapply T_app. eauto.
     eapply T_conv; eauto.
     eapply ctx_plus_comm; eclarify_ctx.
     match goal with [H1 : forall x, x `notin` ?L -> (open_tm_wrt_tm B1 (a_Var_f x)) = _ |- _ ] =>
        pick fresh x;
        move: (H1 x ltac:(auto)) => E
     end.
     apply (cong (subst_tm_tm a0 x)) in E.
     rewrite subst_tm_tm_open_tm_wrt_tm in E; eauto using Typing_lc.
     rewrite subst_tm_tm_open_tm_wrt_tm in E; eauto using Typing_lc.
     simpl in E.  destruct (x == x) eqn:E1. rewrite E1 in E.
     rewrite subst_tm_tm_fresh_eq in E; auto.
     rewrite subst_tm_tm_fresh_eq in E; auto.
     done.
   + (* case Beta1 *)
     match goal with [H0 : Typing ?D ?G  _ (a_Sum _ _) |- _ ] =>
        move: (invert_inj2 H0) => [A1' [A2' [G1' [Be [T1 T2]]]]];
        move: (Typing_regularity H0) => [Gr TS]
     end.
     move: (invert_Beta_Sum2 Be) => Be1.
     move: (invert_Sum TS) => [BB [G3' [G4' [S [Ta Tb]]]]].
     eapply Typing_e.
     eapply T_app. eauto.
     eapply T_conv; eauto.
     eapply ctx_plus_comm; eclarify_ctx.
     match goal with [H1 : forall x, x `notin` ?L -> (open_tm_wrt_tm B2 (a_Var_f x)) = _ |- _ ] =>
        pick fresh x;
        move: (H1 x ltac:(auto)) => E
     end.
     apply (cong (subst_tm_tm a0 x)) in E.
     rewrite subst_tm_tm_open_tm_wrt_tm in E; eauto using Typing_lc.
     rewrite subst_tm_tm_open_tm_wrt_tm in E; eauto using Typing_lc.
     simpl in E.  destruct (x == x) eqn:E1. rewrite E1 in E.
     rewrite subst_tm_tm_fresh_eq in E; auto.
     rewrite subst_tm_tm_fresh_eq in E; auto.
     done.
 - (* Spread *)
   inversion St; subst.
   + (* case cong *)
     have Ta0 : Typing D5 G1 a'0 (a_Sigma q A1 A2).
     { eapply IHTyping. eauto. }
     have TBa0 : Typing D5 (ctx_plus G3 (ctx_mul r G1)) (open_tm_wrt_tm B a'0) a_Type.
     {
       pick fresh x.
       match goal with [H5 : forall y, y `notin` L -> _ ,
                        H0  : Typing ?D ?G a'0 _  |- _ ] =>
          move: (H5 x ltac:(auto)) => h1;
          move: (substitution _ nil _ nil _ _ _ _ _ h1 _ _ H0) => SU
       end.
       asimpl in SU.
       rewrite subst_tm_tm_open_tm_wrt_tm in SU.
       eapply Typing_lc; eauto.
       rewrite subst_tm_same in SU. auto.
       rewrite subst_tm_tm_fresh_eq in SU. fsetdec.
       eauto.
     }

     have TBa : Typing D5 (ctx_plus G3 (ctx_mul r G1)) (open_tm_wrt_tm B a) a_Type.
     {
       pick fresh x.
       match goal with [H5 : forall y, y `notin` L -> _ ,
                        H0  : Typing ?D ?G a _  |- _ ] =>
          move: (H5 x ltac:(auto)) => h1;
          move: (substitution _ nil _ nil _ _ _ _ _ h1 _ _ H0) => SU
       end.
       asimpl in SU.
       rewrite subst_tm_tm_open_tm_wrt_tm in SU.
       eapply Typing_lc; eauto.
       rewrite subst_tm_same in SU. auto.
       rewrite subst_tm_tm_fresh_eq in SU. fsetdec.
       eauto.
     }

     eapply T_conv with (A := open_tm_wrt_tm B a'0).
     eapply T_Spread; auto.
     eauto.
     pick fresh x.
     rewrite (subst_tm_tm_intro x B a); auto.
     rewrite (subst_tm_tm_intro x B a'0); auto.
     eapply subst_Beta2.
     eapply Typing_lc. eauto.
     eapply B_Sym.
     eapply B_Step.
     auto.

   + (* case beta *)
     move: (invert_Tensor H0) => [A1' [A2' [q1 [Be [G1' [G2' [G3' [r' ?]]]]]]]].
     move: (Typing_regularity H0) => [G' TS].
     move: (invert_Sigma _ _ _ _ _ _ TS) => [_ [G1'' [G2'' [r'' ?]]]].
     repeat match goal with [H : _ /\ _ |- _ ] => destruct H  end.
     move: (invert_Beta_a_Sigma1 Be) => Be1.
     move: (invert_Beta_a_Sigma2 Be) => Be2.
     move: (invert_Beta_a_Sigma0 Be) => Be3.
     subst.

     pick fresh x. pick fresh y.
     specialize (H1 x ltac:(auto) y ltac:(auto)). move: H1 => Tb.
     move: (Typing_ctx Tb) => C1.

     eapply substitution with (D2 := nil) (G2 := nil) (a := a0) in Tb.
     2: { eapply T_conv. eauto. eauto. eapply B_Sym. eauto. }
     asimpl in Tb.
     erewrite subst_tm_tm_open_tm_wrt_tm in Tb; eauto using Typing_lc.
     erewrite subst_tm_tm_close_tm_wrt_tm in Tb; eauto using Typing_lc.
     erewrite (subst_tm_tm_open_tm_wrt_tm B) in Tb; eauto using Typing_lc.
     simpl in Tb. destruct (x == x) eqn:E; rewrite E in Tb. 2: { done. } clear E e.
     destruct (y == x) eqn:E. { subst. clear Fr. solve_notin. }
     rewrite E in Tb. clear E n.
     rewrite subst_tm_tm_fresh_eq in Tb. { clear Fr0. fsetdec. }
     eapply Typing_e.
     eapply T_sub.
     3: { eauto. }
     eapply T_app.
     ++ eapply Tb.
     ++ eapply T_conv. eauto.
        replace a_Type with (subst_tm_tm a0 x a_Type).
        eapply substitution with (D2 := nil) (G2 := nil) (a := a0). simpl_env.
        eapply H6. { clear Fr0. fsetdec. } eapply T_conv. eauto. eauto. eapply B_Sym. auto. reflexivity.
        rewrite (subst_tm_tm_intro x). { clear Fr0. fsetdec. }
        eapply subst_Beta1; eauto using Typing_lc.
     ++ destruct_ctx.
        simpl_env; eclarify_ctx.
        erewrite (ctx_plus_assoc _ _ G2); eclarify_ctx.
        erewrite ctx_plus_comm; eclarify_ctx.
        eapply ctx_sub_ctx_plus; eclarify_ctx.
        eapply ctx_sub_refl; eclarify_ctx.
     ++ rewrite subst_tm_tm_fresh_eq. { clear Fr0. fsetdec. }
        rewrite <- subst_tm_tm_spec.
        rewrite subst_tm_tm_open_tm_wrt_tm. eauto using Typing_lc.
        rewrite subst_tm_tm_fresh_eq. { clear Fr. fsetdec. }
        f_equal.
        simpl.
        destruct (y == y) eqn:E. 2: { done. } rewrite E.
        rewrite subst_tm_tm_fresh_eq. { clear Fr. fsetdec. }
        auto.
Qed.

Ltac invert_value :=
  match goal with [ H : value ?a|- _ ]=> inversion H end;
  try match goal with [ H : ty ?a |- _ ] => inversion H end.

Ltac inconsistent :=
  match goal with [ H : Beta ?a ?b |- _ ] =>
     apply Beta_consistent in H; eauto; inversion H
  end.

Lemma canonical_Type : forall a A, Typing nil nil a A -> Beta a a_Type -> value a -> ty a.
Proof.
  intros a A h.
  dependent induction h; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H. subst. auto.
Qed.

Lemma canonical_Pi : forall a A q B1 B2, Typing nil nil a A -> Beta A (a_Pi q B1 B2) -> value a -> exists q1 a1 A1, a = a_Lam q1 A1 a1.
Proof.
  intros. dependent induction H; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H0; subst; eauto.
Qed.

Lemma canonical_Sigma : forall a A q B1 B2, Typing nil nil a A -> Beta A (a_Sigma q B1 B2) -> value a ->
                                       exists a1 b1, a = a_Tensor a1 b1.
Proof.
  intros. dependent induction H; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H0. subst. auto.
Qed.

Lemma canonical_Unit : forall a A, Typing nil nil a A -> Beta A a_TyUnit -> value a -> a = a_TmUnit.
Proof.
  intros. dependent induction H; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H0. subst. auto.
Qed.

Lemma canonical_Box : forall a A q B, Typing nil nil a A -> Beta A (a_Box q B) -> value a -> exists a1, a = a_box q a1.
Proof.
  intros. dependent induction H; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H0. subst. destruct IHTyping; auto. eauto.
  - move: (invert_Beta_Box2 H0) => h0. subst. eauto.
Qed.

Lemma canonical_Sum : forall a A B1 B2, Typing nil nil a A -> Beta A (a_Sum B1 B2) -> value a -> exists a1, a = a_Inj1 a1 \/ a = a_Inj2 a1.
Proof.
  intros. dependent induction H; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H0. subst. auto.
Qed.

(* Theorem 6.5 *)
Lemma progress : forall a A,
  Typing nil nil a A -> value a \/ exists a', Step a a'.
Proof.
  intros a A H. dependent induction H; eauto.
  - inversion H0. subst. eauto.
  - move: (Typing_ctx H) => C. move: (Typing_ctx H0) => C0. destruct_ctx.
    destruct IHTyping1; auto.
    + (* fun is a value *)
      have LC: lc_tm a. eapply Typing_lc; eauto.
      eapply canonical_Pi in H; auto. 2: { eapply B_Refl; eauto using Typing_lc2.  }
      destruct H as [q1 [A1 [a1' E]]]; auto. subst.
      inversion LC. subst.
      right. eexists.
      eapply S_Beta; eauto using Typing_lc.
    + (* fun steps *)
      destruct H1 as [a' SS].
      right. eexists. eauto using Typing_lc.
  - move: (Typing_ctx H) => C. move: (Typing_ctx H1) => C0. destruct_ctx.
    destruct IHTyping1; auto.
    + eapply canonical_Unit in H; auto. subst.
      right. eexists.
      eapply S_UnitBeta; eauto using Typing_lc.
    + destruct H0 as [a' SS].
      right. eexists.
      eapply S_UnitCong; eauto using Typing_lc.
  - move: (Typing_ctx H) => C. destruct_ctx.
    destruct IHTyping; auto.
    + have LC: lc_tm a. eauto using Typing_lc.
      pick fresh y.
      repeat match goal with [H : forall x, x `notin` ?L -> Typing _ _ _ _ |- _ ] => specialize (H y ltac:(auto)) end.
      move: (canonical_Box _ _ q A H) => h.
      destruct h as [a1 E]; auto.
      eapply B_Refl; eauto using Typing_lc2.
      subst.
      right. eexists.
      inversion LC.
      eapply S_BoxBeta; eauto using Typing_lc.
      eapply (lc_a_LetBoxB_exists y); eauto using Typing_lc.
      eapply (lc_a_Lam_exists y); eauto using Typing_lc, Typing_lc2.
      eapply (lc_a_Lam_exists y); eauto using Typing_lc2, Typing_lc2.
      eauto using Typing_lc.
    + destruct H4 as [a1 E]; auto.
      right. eexists.
      pick fresh y.
      eapply S_BoxCong; eauto using Typing_lc.
      eapply (lc_a_LetBoxB_exists y); eauto using Typing_lc.
      eapply (lc_a_Lam_exists y); eauto using Typing_lc, Typing_lc2.
      eapply (lc_a_Lam_exists y); eauto using Typing_lc2, Typing_lc2.
      eauto using Typing_lc.
  - move: (Typing_ctx H0) => C. destruct_ctx.
    have LC: lc_tm a. eapply Typing_lc; eauto.
    have LC2: lc_tm (a_Sum A1 A2). eapply Typing_lc2; eauto.
    destruct IHTyping1; auto.
    + eapply canonical_Sum in H0; auto.
      destruct H0 as [a0 [V1 | V2]]; subst.
      ++ right.
         eexists.
         inversion LC.
         eapply S_Case1Beta; eauto using Typing_lc.
      ++ right.
         eexists.
         inversion LC.
         eapply S_Case2Beta; eauto using Typing_lc.
    + destruct H7 as [a' SS].
      right. eexists.
      eapply S_CaseCong; eauto using Typing_lc.
  - right.
    move: (Typing_ctx H0) => C. destruct_ctx.
    have L1: lc_tm a by eauto using Typing_lc.
    have L2: lc_tm (a_Sigma q A1 A2) by eauto using Typing_lc2.
    have L4: lc_tm (a_Lam r (a_Sigma q A1 A2) B).
    { pick fresh y.
      move: (H3 y ltac:(auto)) => h.
      move: (Typing_lc h) => LB.
      eapply lc_a_Lam_exists. auto. eauto.
    }
    have L3: lc_tm (a_Spread a b (a_Lam r (a_Sigma q A1 A2) B)).
    {
      pick fresh y. pick fresh z.
      move: (H1 y ltac:(auto) z ltac:(auto)) => Tb.
      move: (Typing_lc Tb) => LB.
      eapply lc_a_Spread_exists; eauto.
    }
    destruct IHTyping; eauto.
    + have BB: Beta (a_Sigma q A1 A2) (a_Sigma q A1 A2).
      { eapply B_Refl; eauto. }
      move: (canonical_Sigma a _ q A1 A2 H0 BB H) => h.
      move: h => [a1 [b1 EQ]]. subst a.
      inversion L1. subst.
      eexists.
      eapply S_SpreadBeta; eauto using Typing_lc.
    + move: H => [a' SS].
      eexists.
      eapply S_SpreadCong; eauto.
Qed.


(** * DSL benchmark: Gates *)

Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.Init.Peano.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.PArith.BinPosDef.
Require Import Coq.ZArith.BinInt Coq.ZArith.ZArith Coq.ZArith.Zdiv Coq.ZArith.Znumtheory Coq.NArith.NArith. (* import Zdiv before Znumtheory *)
Require Import Coq.NArith.Nnat.

Require Import Crypto.Spec.ModularArithmetic.
Require Import Crypto.Arithmetic.PrimeFieldTheorems Crypto.Algebra.Field.
Require Import Crypto.Util.Decidable. (* Crypto.Util.Notations. *)
Require Import Coq.setoid_ring.Ring_theory Coq.setoid_ring.Field_theory Coq.setoid_ring.Field_tac.

From Circom Require Import Circom Util Default Tuple LibTactics Simplify Repr.
From Circom.CircomLib Require Import Bitify.

Local Coercion N.of_nat : nat >-> N.
Local Coercion Z.of_nat : nat >-> Z.

Local Open Scope F_scope.

Definition f_and (x: F) (y: F) := x = 1%F /\ y = 1%F.
Definition f_or (x: F) (y: F) := x = 1%F \/ y = 1%F.
Definition f_not (x: F) := x = 0%F.
Definition f_nand (x: F) (y: F) := ~(x = 1%F /\ y = 1%F).
Definition f_nor (x: F) (y: F) := ~(x = 1%F \/ y = 1%F).
Definition f_xor (x: F) (y: F) := x <> y.

(** ** NOT *)

(* print_endline (generate_lemmas cnot (typecheck_circuit d_empty cnot));; *)

Lemma Not_obligation0: forall (_in : F) (v : F), ((_in = 0%F) \/ (_in = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = _in)) -> True).
Proof. intuition. Qed.

Lemma Not_obligation1: forall (_in : F) (v : F), ((_in = 0%F) \/ (_in = 1%F)) -> True -> ((v = 1%F) -> True).
Proof. intuition. Qed.

Lemma Not_obligation2: forall (_in : F) (v : F), ((_in = 0%F) \/ (_in = 1%F)) -> True -> ((v = (_in + 1%F)%F) -> True).
Proof. intuition. Qed.

Lemma Not_obligation3: forall (_in : F) (v : F), ((_in = 0%F) \/ (_in = 1%F)) -> True -> ((v = 2%F) -> True).
Proof. Admitted.

Lemma Not_obligation4: forall (_in : F) (v : F), ((_in = 0%F) \/ (_in = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = _in)) -> True).
Proof. intuition. Qed.

Lemma Not_obligation5: forall (_in : F) (v : F), ((_in = 0%F) \/ (_in = 1%F)) -> True -> ((v = (2%F * _in)%F) -> True).
Proof. Admitted.

Lemma Not_obligation6: forall (_in : F) (v : F), ((_in = 0%F) \/ (_in = 1%F)) -> True -> ((v = ((_in + 1%F)%F - (2%F * _in)%F)%F) -> (((v = 0%F) \/ (v = 1%F)) /\ (((v = 1%F) -> (f_not _in)) /\ ((v = 0%F) -> ~(f_not _in))))).
Proof. Admitted.

(** ** XOR *)

(* print_endline (generate_lemmas cxor (typecheck_circuit d_empty cxor));; *)

Lemma Xor_obligation0: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = a)) -> True).
Proof. intuition. Qed.

Lemma Xor_obligation1: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = b)) -> True).
Proof. intuition. Qed.

Lemma Xor_obligation2: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (a + b)%F) -> True).
Proof. intuition. Qed.

Lemma Xor_obligation3: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = 2%F) -> True).
Proof. Admitted.

Lemma Xor_obligation4: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = a)) -> True).
Proof. intuition. Qed.

Lemma Xor_obligation5: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = b)) -> True).
Proof. intuition. Qed.

Lemma Xor_obligation6: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (a * b)%F) -> True).
Proof. intuition. Qed.

Lemma Xor_obligation7: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (2%F * (a * b)%F)%F) -> True).
Proof. Admitted.

Lemma Xor_obligation8: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = ((a + b)%F - (2%F * (a * b)%F)%F)%F) -> (((v = 0%F) \/ (v = 1%F)) /\ (((v = 1%F) -> (f_xor a b)) /\ ((v = 0%F) -> ~(f_xor a b))))).
Proof. Admitted.

(** ** AND *)

(* print_endline (generate_lemmas cand (typecheck_circuit d_empty cand));; *)

Lemma And_obligation0: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = a)) -> True).
Proof. intuition. Qed.

Lemma And_obligation1: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = b)) -> True).
Proof. intuition. Qed.

Lemma And_obligation2: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (a * b)%F) -> (((v = 0%F) \/ (v = 1%F)) /\ (((v = 1%F) -> (f_and a b)) /\ ((v = 0%F) -> ~(f_and a b))))).
Proof.
  unwrap_C. unfold f_and. intros.
  intuit; try fqsatz.
  - left; fqsatz.
  - left; fqsatz.
  - left; fqsatz.
  - right; fqsatz.
Qed.

(** ** NAND *)

(* print_endline (generate_lemmas cnand (typecheck_circuit d_empty cnand));; *)

Lemma Nand_obligation0: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = 1%F) -> True).
Proof. intuition. Qed.

Lemma Nand_obligation1: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = a)) -> True).
Proof. intuition. Qed.

Lemma Nand_obligation2: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = b)) -> True).
Proof. intuition. Qed.

Lemma Nand_obligation3: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (a * b)%F) -> True).
Proof. intuition. Qed.

Lemma Nand_obligation4: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (1%F - (a * b)%F)%F) -> (((v = 0%F) \/ (v = 1%F)) /\ (((v = 1%F) -> (f_nand a b)) /\ ((v = 0%F) -> ~(f_nand a b))))).
Proof.
  unwrap_C. unfold f_nand. intros.
  intuit; try fqsatz.
  - right; fqsatz.
  - right; fqsatz.
  - right; fqsatz.
  - left; fqsatz.
Qed.

(** ** OR *)

(* print_endline (generate_lemmas cor (typecheck_circuit d_empty cor));; *)

Lemma Or_obligation0: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = a)) -> True).
Proof. intuition. Qed.

Lemma Or_obligation1: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = b)) -> True).
Proof. intuition. Qed.

Lemma Or_obligation2: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (a + b)%F) -> True).
Proof. intuition. Qed.

Lemma Or_obligation3: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = a)) -> True).
Proof. intuition. Qed.

Lemma Or_obligation4: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = b)) -> True).
Proof. intuition. Qed.

Lemma Or_obligation5: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (a * b)%F) -> True).
Proof. intuition. Qed.

Lemma Or_obligation6: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = ((a + b)%F - (a * b)%F)%F) -> (((v = 0%F) \/ (v = 1%F)) /\ (((v = 1%F) -> (f_or a b)) /\ ((v = 0%F) -> ~(f_or a b))))).
Proof.
  unwrap_C. unfold f_or. intros.
  intuit; try fqsatz.
  - left; fqsatz.
  - right; fqsatz.
  - right; fqsatz.
  - right; fqsatz.
Qed.

(** ** NOR *)

(* print_endline (generate_lemmas cnor (typecheck_circuit d_empty cnor));; *)

Lemma Nor_obligation0: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = a)) -> True).
Proof. intuition. Qed.

Lemma Nor_obligation1: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = b)) -> True).
Proof. intuition. Qed.

Lemma Nor_obligation2: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (a * b)%F) -> True).
Proof. intuition. Qed.

Lemma Nor_obligation3: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = 1%F) -> True).
Proof. intuition. Qed.

Lemma Nor_obligation4: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = ((a * b)%F + 1%F)%F) -> True).
Proof. intuition. Qed.

Lemma Nor_obligation5: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = a)) -> True).
Proof. intuition. Qed.

Lemma Nor_obligation6: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (((a * b)%F + 1%F)%F - a)%F) -> True).
Proof. intuition. Qed.

Lemma Nor_obligation7: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = b)) -> True).
Proof. intuition. Qed.

Lemma Nor_obligation8: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = ((((a * b)%F + 1%F)%F - a)%F - b)%F) -> (((v = 0%F) \/ (v = 1%F)) /\ (((v = 1%F) -> (f_nor a b)) /\ ((v = 0%F) -> ~(f_nor a b))))).
Proof.
  unwrap_C. unfold f_nor. intros.
  intuit; try fqsatz.
  - right; fqsatz.
  - left; fqsatz.
  - left; fqsatz.
  - left; fqsatz.
Qed.