Require Import MMLL.SL.FLLTactics.
Require Import MMLL.SL.CutElimination.

Set Implicit Arguments.

(* Create HintDb LLBase.
 *)
Section FLLReasoning.
Context {OLS : OLSig}.
Context {SI : Signature}.

 Variable th : oo -> Prop.

Lemma BipoleReasoning {USI: UnbSignature} n B D F G:   seqN th n B D (DW (MAnd (perp F) G)) -> (exists m M, n = S m /\  seqN th m B M (DW G) /\ Permutation D (atom F :: M)) \/ (exists m i C, n = S m /\ seqN th m B D (DW G) /\ mt i = true /\Permutation ((i,atom F) :: C) B).
 Proof with sauto.
   intros.
   inversion H...
   2:{ inversion H1. }
   assert(Permutation B B0).
   rewrite (cxtDestruct B).
   rewrite (cxtDestruct B0).
   rewrite (SetU_then_empty B)...
   rewrite (SetU_then_empty B0)...
   apply allSeTU...
   apply allSeTU...
   assert(Permutation B D0).
   rewrite (cxtDestruct B).
   rewrite (cxtDestruct D0).
   rewrite (SetU_then_empty B)...
   rewrite (SetU_then_empty D0)...
   apply allSeTU...
   apply allSeTU...
    rewrite <- H0 in H9.
    rewrite <- H1 in H10.
    clear H0 H1 H3 H4 H5.
    inversion H9...
    left.
   exists n0.
   exists N...
   right.
   exists n0.
   exists i.
   exists C.
   split...
   rewrite H2...
   inversion H1.
   Qed.

 (* Theorem FocusingClause : forall n B D A F,
     seqN th n B D (DW ((perp A) ** F)) ->
 (exists m N, n = S m /\ Permutation D ((atom A)::N) /\
                seqN th m B N  (DW F)) \/
   (exists m i, n = S m /\ In (i, atom A) B /\
                seqN th m B D  (DW F)).
  Proof with sauto.
  intros.
  InvTriAll.
  - left.
    eexists. exists N...
  - right.
    eexists.
    split...  HProof.
 Qed.
 *)

       Lemma FocusingInitRuleU {SIU: UnbSignature} : forall h D A A' B,
      seqN th h B D (DW ((perp A) ⊗ (perp A'))) ->
      Permutation D [atom A; atom A'] \/
      (exists i C, D = [atom A] /\ Permutation ((i, atom A') :: C) B /\ mt i = true  ) \/
      (exists i C, D = [atom A'] /\ Permutation ((i, atom A) :: C) B  /\ mt i = true ) \/
      (exists i j C1 C2, Permutation ((i, atom A') :: C1) B /\ Permutation ((j, atom A) :: C2) B /\ mt i = true /\mt j = true /\ D=[]).
  Proof with sauto.
    intros.
    apply BipoleReasoning in H...
    inversion H2...
    2:{ solveF. }
    right. left.
    exists i. exists C.
    split...
    inversion H2...
    right. right. left.
    exists x0. exists x1.
    split...
    right. right. right.
    exists i. exists x0.
    exists C. exists x1.
    split...
    solveF.
  Qed.

  (*  Theorem FocusingStruct : forall n D B A,
   seqN th n B D (DW ((perp A) ⊗ (? (atom A)))) ->
   (exists m N, n = S (S (S m)) /\  Permutation D ((atom
   A)::N) /\
                seqN th m (B++[atom A]) N  (UP [] )) \/
    (exists m, n = S (S (S m))  /\ In (atom A) B /\

                seqN th m (B++[(atom A)]) D  (UP [] )).
   Proof with sauto.
   intros.
   InvTriAll.
   left.
  exists n0. exists N...
  right.
  exists n0...
  HProof.
 Qed.
 *)

  Theorem FocusingExists :
    forall n FX D G,
    seqN th n G D (DW (Some FX)) ->
      exists m t , n =  S m /\ proper t /\ uniform_oo FX /\
    seqN th m G D (DW (FX t)).
  Proof with sauto.
    intros.
    inversion H... solveF.
    eexists n0, t.
    split;eauto.
  Qed.

  Theorem FocusingQuest :
    forall n a A D G,
    seqN th n G D (DW ((? a) (atom A))) ->
      exists m , n =   S (S m)  /\
                 seqN th m ((a,atom A)::G) D (UP []).
  Proof with sauto.
    intros.
    inversion H...
    inversion H5...
    2: solveF.
    eexists n.
    split;eauto.
  Qed.

 Theorem FocusingBangPar {Unb: UnbSignature}:
    forall n a A B D G, mt a = true -> m4 a = true ->
    seqN th n G D (DW ((! a) ((atom A) ⅋ ( atom B)))) ->
      exists m C4 CN, n =  S (S (S (S (S m)))) + length C4  /\ D = [] /\ Permutation G (C4++CN) /\ SetK4 C4 /\ SetT C4 /\ LtX a C4 /\
                 seqN th m C4 [atom B; atom A] (UP []).
  Proof with sauto.
    intros.
    inversion H1...
    solveF. solveSignature1.
    eapply InvSubExpPhaseUTK4 in H8...
    2: apply allU.
    inversion H12...
    inversion H15...
    inversion H19...
    2: solveF.

    eexists n, x, x0.
    split;[| split;eauto].
    rewrite <- NatComp in H2...
    lia. Qed.

 Theorem FocusingBang {Unb: UnbSignature}:
    forall n a A C D G, mt a = true -> m4 a =true ->
    seqN th n ((loc,C)::G) D (DW (Bang a (atom A ))) ->
      exists m X1 X2, n = S (S (S m)) + length X1 /\ Permutation G (X1++X2) /\ SetT X1 /\ SetK4 X1 /\ LtX a X1 /\ D = [] /\
                  ( seqN th m X1 [atom A] (UP [])).
  Proof with sauto.
    intros.
    assert(D=[]).
    { inversion H1... solveF. }
    subst.
    apply InvBangTNLoc in H1...
    inversion H4...
    eexists n0, x, x0.
    split;auto.
    lia.
    split;auto.

 Qed.

 Theorem FocusingBangU {Unb: UnbSignature}:
    forall n a A D G, mt a = true ->
    seqN th n G D (DW (Bang a (atom A ))) ->
      exists m, n = S (S m) /\ D = [] /\
                  ( seqN th m G [atom A] (UP [])).
  Proof with sauto.
    intros.
    assert(D=[]).
    { inversion H0... solveF. }
    subst.
    apply InvBangTN in H0...
    inversion H0...
    eexists n0.
    split...
    lia.
 Qed.

 Theorem FocusingBang' {Unb: UnbSignature}:
    forall n a A D G, mt a = true -> m4 a = true ->
    seqN th n G D (DW ((! a) (atom A))) ->
      exists m C4 CN, n = S (S (S m)) + length C4  /\  Permutation G (C4++CN) /\  SetT C4 /\ SetK4 C4 /\ LtX a C4 /\
 D = [] /\                seqN th m C4 [atom A] (UP []).
  Proof with sauto.
    intros.
    inversion H1...
    solveF. solveSignature1.
    eapply InvSubExpPhaseUTK4 in H8...
    2: apply allU.
    inversion H12...

    eexists n, x, x0.
    split;[| split;eauto].
    rewrite <- NatComp in H2...
    lia. Qed.

 Theorem FocusingBangSet {Unb: UnbSignature}:
    forall n a A C D G, mt a = true -> m4 a =true ->
    seqN th n (Loc C++G) D (DW (Bang a (atom A ))) ->
      exists m X1 X2, n = S (S (S m)) + length X1 /\ Permutation G (X1++X2) /\ SetT X1 /\ SetK4 X1 /\ LtX a X1 /\ D = [] /\
                  ( seqN th m X1 [atom A] (UP [])).
  Proof with sauto.
     induction C;   intros.
    eapply FocusingBang'...
    simpl in H1.
    rewrite Permutation_cons_append in H1.
    rewrite app_assoc_reverse in H1.
    specialize (IHC _ _ H H0 H1)...
    checkPermutationCases H5.
    2: exists x, x0, x2...

    rewrite <- Permutation_cons_append in H3.
    rewrite H3 in H6.
    inversion H6...
    solveSignature1.
  Qed.

  Theorem FocusingPar :
    forall n A B D G,
    seqN th n G D (DW ((atom A) ⅋ ( atom B))) ->
      exists m , n =  S (S(S(S m)))  /\
                 seqN th m G (atom B::atom A::D) (UP []).
  Proof with sauto.
    intros.
    inversion H...
    inversion H5...
    inversion H6...
    inversion H9...
    eexists n.
    split;eauto.
    inversion H7.
  Qed.

  Theorem FocusingPlus:
    forall n A B D G ,
    seqN th n G D (DW ( (atom A) ⊕ (atom B))) ->
     ( exists m , n = (S(S (S m)))  /\
                 (seqN th m G (atom A ::D) (UP []) )) \/
    ( exists m , n = (S(S (S m)))  /\
                 seqN th m G (atom B::D) (UP []) ).
  Proof with sauto.
    intros.
    inversion H...
    inversion H4...
    inversion H6...
    left.
    eexists n0.
    split;eauto.
    inversion H4...
    inversion H6...
    right.
    eexists n0.
    split;eauto.
    inversion H1.
  Qed.

  Theorem FocusingWith :
    forall n A B D G,
      seqN th n G D (DW ( (atom A) & (atom B))) ->
      exists m , n = S(S(S m))  /\
                 ( (seqN th m G (atom A::D) (UP []) ) /\
                   (seqN th m G (atom B::D) (UP []) )) .
  Proof with sauto.
    intros.
    inversion H...
    inversion H5...
    inversion H7...
    inversion H9...
    eexists n0.
    split;eauto.
    solveF.
  Qed.

  Theorem FocusingTensor {USI: UnbSignature}:
    forall n A B D G,
      seqN th n G D (DW ( (atom A) ⊗ (atom B))) ->
       exists m M N , n = S(S(S m))  /\ Permutation D (M++N) /\
                  ( seqN th m G (atom A::M) (UP [])) /\
                  ( seqN th m G (atom B::N) (UP [])).
   Proof with sauto.
    intros.
    inversion H...
    2:{ inversion H1. }
   assert(Permutation G B0).
   rewrite (cxtDestruct G).
   rewrite (cxtDestruct B0).
   rewrite (SetU_then_empty G)...
   rewrite (SetU_then_empty B0)...
   apply allSeTU...
   apply allSeTU...
   assert(Permutation G D0).
   rewrite (cxtDestruct G).
   rewrite (cxtDestruct D0).
   rewrite (SetU_then_empty G)...
   rewrite (SetU_then_empty D0)...
   apply allSeTU...
   apply allSeTU...

   rewrite <- H0 in H9.
   rewrite <- H1 in H10.

    inversion H9...
    inversion H10...
    inversion H13...
    inversion H15...
    eexists n0, M, N.
    split;eauto.
  Qed.

 Theorem FocusingTensorC {USI: UnbSignature}:
    forall n a b A B D G,
      seqN th n G D (DW ( Quest a (atom A) ⊗ Quest b (atom B))) ->
       exists m M N , n = S(S(S m))  /\ Permutation D (M++N) /\
                  ( seqN th m ((a,atom A)::G) M (UP [])) /\
                  ( seqN th m ((b,atom B)::G) N (UP [])).
   Proof with sauto.
    intros.
    inversion H...
    2:{ inversion H1. }
   assert(Permutation G B0).
   rewrite (cxtDestruct G).
   rewrite (cxtDestruct B0).
   rewrite (SetU_then_empty G)...
   rewrite (SetU_then_empty B0)...
   apply allSeTU...
   apply allSeTU...
   assert(Permutation G D0).
   rewrite (cxtDestruct G).
   rewrite (cxtDestruct D0).
   rewrite (SetU_then_empty G)...
   rewrite (SetU_then_empty D0)...
   apply allSeTU...
   apply allSeTU...

   rewrite <- H0 in H9.
   rewrite <- H1 in H10.

    inversion H9...
    inversion H10...
    inversion H13...
    inversion H15...
    eexists n0, M, N.
    split;eauto. solveF. solveF.
  Qed.

   Theorem FocusingClauseL {USI: UnbSignature}: forall B D A F,
     seq th B D (DW F) -> seq th B  (atom A::D) (DW ((perp A) ⊗ F)).
   Proof with sauto.
   intros.
   LLTensor [atom A] D.
   Qed.

 Theorem FocusingClauseL'  {USI: UnbSignature}: forall B D D' A F,
   Permutation D (atom A::D') -> seq th B D' (DW F) -> seq th B  D (DW ((perp A) ⊗ F)).
   Proof with auto using FocusingClauseL.
   intros.
   rewrite H...
  Qed.

   Theorem FocusingClauseC  {USI: UnbSignature}: forall i B D A F, mt i = true ->
   In (i, atom A) B ->  seq th B D (DW F) -> seq th B  D (DW ((perp A) ⊗ F)).
   Proof with sauto.
   intros.
   rewrite <- (app_nil_l D).
   apply InPermutation in H0...
   LLTensor (nil (A:=oo)) D.
   init2 i x.
   Qed.

End FLLReasoning.


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

(***
Modulus : 2^189 - 25
Base: 64
***)

Definition curve : CurveParameters :=
  {|
    sz := 3%nat;
    base := 64;
    bitwidth := 64;
    s := 2^189;
    c := [(1, 25)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

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

    mul_code := None;

    square_code := None;

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

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


(* This script shows, in two different ways, the inconsistency of the
propositional extensionality axiom with the guard condition for cofixpoints. It
is the dual of the problem on fixpoints (cf subterm.v, subterm2.v,
subterm3.v). Posted on Coq-club by Maxime Dénès (02/26/2014). *)

(* First example *)

CoInductive CoFalse : Prop := CF : CoFalse -> False -> CoFalse.

CoInductive Pandora : Prop := C : CoFalse -> Pandora.

Axiom prop_ext : forall P Q : Prop, (P<->Q) -> P = Q.

Lemma foo : Pandora = CoFalse.
apply prop_ext.
constructor.
intro x; destruct x; assumption.
exact C.
Qed.

Fail CoFixpoint loop : CoFalse :=
match foo in (_ = T) return T with eq_refl => C loop end.

Fail Definition ff : False := match loop with CF _ t => t end.

(* Second example *)

Inductive omega : Prop := Omega : omega -> omega.

Lemma H : omega = CoFalse.
Proof.
apply prop_ext; constructor.
  induction 1; assumption.
destruct 1; destruct H0.
Qed.

Fail CoFixpoint loop' : CoFalse :=
  match H in _ = T return T with
    eq_refl =>
    Omega match eq_sym H in _ = T return T with eq_refl => loop' end
  end.

Fail Definition ff' : False := match loop' with CF _ t => t end.


From Undecidability.L Require Export L Datatypes.LNat Datatypes.LBool Functions.Encoding Computability.Seval.
Require Import Coq.Logic.ConstructiveEpsilon.

Definition cChoice := constructive_indefinite_ground_description_nat_Acc.

Lemma eq_term_dec (s t : term) : (s = t) + (s <> t).
Proof.
  revert t. induction s; intros t; destruct t; try(right; intros H; inv H; fail).
  - decide (n = n0). left. congruence. right. congruence.
  - destruct (IHs1 t1), (IHs2 t2); try (right; congruence). left. congruence.
  - destruct (IHs t). left; congruence. right; congruence.
Qed.

Lemma enc_extinj {X} {H:registered X} (m n:X) : enc m == enc n -> m = n.
Proof.
  intros eq. apply unique_normal_forms in eq; try Lproc. now apply inj_enc.
Qed.

Lemma lcomp_comp Y {Ry:registered Y} (u:term) (g: term -> Y):
  (forall x (y:Y), enc y = x -> y = g x) ->
  (exists y:Y, u == enc y) -> {y:Y| u == enc y}.
Proof.
  intros Hg Hu.
  assert (exists n (y:Y), eva n u = Some (enc y)).
  {
    destruct Hu as [y Hy]. apply equiv_lambda in Hy;try Lproc.
    assert (eval (u) (enc y)). split. assumption. Lproc.
    apply eval_seval in H. destruct H as [n Hn]. exists n. exists y. now apply seval_eva.
  }
  eapply cChoice in H. destruct H as [n H].
  destruct (eva n u) as [t|] eqn:Heva.
  -exists (g t). destruct H as [y H]. rewrite <- Heva in H. apply eva_equiv in H.
   assert (lambda t)by now apply eva_lam in Heva. apply eva_equiv in Heva. rewrite Heva in H. erewrite <- Hg. apply equiv_lambda in Heva;try Lproc. rewrite Heva. exact H. apply unique_normal_forms in H;try Lproc. congruence.
  -exists (g #0). destruct H as [? H]. inv H.
  -intros n. destruct (eva n u) eqn:eq.
   +left. destruct H as [n' [y H]]. exists y. apply eva_equiv in H.
    assert (lambda t) by now apply eva_lam in eq. apply eva_equiv in eq. rewrite H in eq. apply unique_normal_forms in eq;[|Lproc..].  congruence.
   +right. intros [y eq']. congruence.
Qed.

Definition bool_enc_inv b:=
  match b with
    | lam (lam (var 1)) => true
    | _ => false
  end.

Lemma bool_enc_inv_correct : (forall x (y:bool), enc y = x -> y = bool_enc_inv x).
Proof.
  intros x [];intros;subst;reflexivity.
  Qed.

Arguments lcomp_comp _{_} _ {_} _ _.

(*
Lemma ldec_dec P u: decides u P -> forall s, dec(P s).
Proof.
  intros H s. specialize (H s).
  assert (exists (b:bool), u (enc s) == enc b). destruct H as [? [H' _]]. exists x. assumption.
  eapply lcomp_comp in H0. destruct H0 as [[|] H0].
  -left. destruct H as [b [eq R]]. rewrite eq in H0. apply enc_extinj in H0. now subst.
  -right. destruct H as [b [eq R]]. rewrite eq in H0. apply enc_extinj in H0. now subst.
  -exact bool_enc_inv_correct.
Qed.
*)


Definition Lem (b: Prop -> Prop) := (forall Q: Prop, b Q -> Q \/ ~Q).

Definition C (b: Prop -> Prop) (P: Prop) := Lem b -> P.

Definition c_unit: forall (b: Prop -> Prop) (P: Prop), P -> C b P := (fun (b: Prop -> Prop) (P: Prop) (vP: P) (lem: Lem b) => vP).

Definition c_bind: forall (b: Prop -> Prop) (P Q: Prop), C b P -> (P -> C b Q) -> C b Q := (fun (b: Prop -> Prop) (P: Prop) (Q: Prop)
(vcP: C b P) (f: P -> C b Q) (lem: Lem b) => f (vcP lem) lem).

Lemma c_prop1: forall (b f: Prop -> Prop), (forall P: Prop, C b (f P)) -> C b (forall P: Prop, f P).
Proof.
    intros b f H LEM P.
    apply (H P LEM).
Qed.

Lemma c_prop2: forall (b: Prop -> Prop) (P Q: Prop), (P -> C b Q) -> C b (P -> Q).
Proof.
    intros b P Q HPQ LEM vP.
    apply (HPQ vP LEM).
Qed.

Lemma c_lem: forall (b: Prop -> Prop) (P: Prop), b P -> C b (P \/ ~P).
Proof.
    intros b P HP LEM.
    apply (LEM P).
    assumption.
Qed.

Theorem c_monad_1: forall (b: Prop -> Prop) (A B: Prop) (vA: A) (f: A -> C b B),
    c_bind _ _ _ (c_unit _ _ vA) f = f vA.
Proof.
    intros b A B vA f.
    unfold c_unit; unfold c_bind. change (fun x => f vA x) with (f vA).
    reflexivity.
Qed.

Theorem c_monad_2: forall (b: Prop -> Prop) (A: Prop) (vcA: C b A),
    c_bind _ _ _ vcA (c_unit _ _) = vcA.
Proof.
    intros b A vcA.
    unfold c_unit; unfold c_bind. change (fun x => vcA x) with vcA.
    reflexivity.
Qed.

Theorem c_monad_3: forall (b: Prop -> Prop) (P Q R: Prop) (vcP: C b P) (f: P -> C b Q) (g: Q -> C b R),
    c_bind _ _ _ vcP (fun (x: P) => c_bind _ _ _ (f x) g) =
     c_bind _ _ _ (c_bind _ _ _ vcP f) g.
Proof.
    intros b P Q R vcP f g.
    unfold c_unit; unfold c_bind. reflexivity.
Qed.

Ltac cremove_0 bo H X Y Z := let a := fresh "H" in pose proof (c_prop2 bo _ _ H) as a;
apply (c_bind bo _ Z) in a; [ assumption | ]; let b := fresh "H" in
intro b; move b before H; clear H; clear a; rename b into H.

Ltac cremove_1 bo H X Y Z :=
    let a := fresh "H" in assert (X -> Y) as a;
    [ let b := fresh "H" in intro b; apply (c_unit bo X) in b; apply H in b; assumption
     | clear H; rename a into H ].

Ltac cremove_2 bo H X Y :=
    apply (c_bind _ _ Y) in H; [assumption | ]; let a := fresh "H" in
    intro a; move a before H; clear H; rename a into H.

Lemma cremove_hyp: forall (b: Prop -> Prop) (P Q: Prop), C b (P -> Q) -> C b P -> C b Q.
Proof.
    intros b P Q H1 H2.
    cremove_2 b H1 (P -> Q) Q.
    cremove_2 b H2 P Q.
    apply H1 in H2. apply c_unit; assumption.
Qed.

Ltac cremove_3 bo H X Y :=
    let a := fresh "H" in assert (a := cremove_hyp _ X Y H); move a before H; clear H; rename a into H
.

Ltac cremove := repeat lazymatch goal with
 | [ H: ?X -> C ?b ?Y |- C _ ?Z ] =>
    cremove_0 b H X Y Z
 | [ H: C ?b ?X -> ?Y |- C _ ?Z ] =>
    cremove_1 b H X Y Z
 | [ H: C ?b ?X |- C _ ?Y ] =>
    cremove_2 b H X Y
 | [ |- C _ (?X -> ?Y) ] =>
    apply (c_prop1 X Y)
 | [ |- ?X -> _ ] => intro
 | [ H: C ?b (?X -> ?Y) |- _ ] =>
    cremove_3 b H X Y
end.

Ltac cassumption := lazymatch goal with
 | [ H: ?X |- C _ ?X ] => apply c_unit; assumption
end.

Ltac capply H := apply (c_unit _ _ H).
Ltac decided := apply c_unit.

Ltac cdestruct H := cremove; destruct H.
Lemma o_and: forall (b: Prop -> Prop) (P Q: Prop), C b P /\ C b Q -> C b (P /\ Q).
Proof.
    intros b P Q H.
    destruct H as [ H0 H1 ].
    cremove.
    decided.
    apply (conj H0 H1).
Qed.

Ltac csplit := lazymatch goal with
 | [ |- C _ (?A /\ ?B) ] => apply (o_and _ A B); split
end.

Ltac exm P := match goal with
| [ HP : ?b P |- _ ] => let a := fresh "H" in pose proof (c_lem b P HP) as a;
  let k := type of a in let c := lazymatch goal with | [ |- C b ?Z ] => Z end in cremove_2 b a k c; destruct a
end.

Lemma classic_false: forall (b: Prop -> Prop), (exists P: Prop, C b P /\ ~P) -> C b False.
Proof.
    intros b H.
    destruct H. destruct H.
    cremove. absurd x; assumption.
Qed.

Lemma classic_not: forall (b: Prop -> Prop) (P: Prop), b P -> (P -> C b False) -> C b (~ P).
Proof.
    intros b P HP H LEM.
    destruct (LEM P HP) as [vP | vnP].
    pose proof (H vP LEM) as vFalse; destruct vFalse.
    apply vnP.
Qed.
Proof.
    intros b P HP H.
    exm P.
    apply H in H0.
    cremove; inversion H0.
    cassumption.
Qed.

Lemma o_mp: forall (b: Prop -> Prop) (P Q: Prop), C b (P -> Q) -> C b P -> C b Q.
Proof.
    intros b P Q H1 H2.
    cremove. specialize (H1 H2). cassumption.
Qed.

Lemma o_fmapd: forall (b: Prop -> Prop) (A B P: Prop), C b (A \/ B) -> (A -> C b P) -> (B -> C b P) -> C b P.
Proof.
    intros b A B P.
    cremove.
    destruct H. capply (H0 H).
    capply (H1 H).
Qed.

Lemma o_dfmapo: forall (b: Prop -> Prop) (P A B: Prop), C b P -> (P -> C b (A \/ B)) -> C b (A \/ B).
Proof.
    intros b P A B H1 H2.
    cremove.
    capply (H2 H1).
Qed.

Lemma o_dfmapd: forall (b: Prop -> Prop) (A B P Q: Prop), C b (A \/ B) -> (A -> C b (P \/ Q)) ->
    (B -> C b (P \/ Q)) -> C b (P \/ Q).
Proof.
    intros b A B P Q H1 H2 H3.
    cremove.
    destruct H1.
    capply (H2 H).
    capply (H3 H).
Qed.

Lemma o_fmapo_c: forall (b: Prop -> Prop) (P Q: Prop), (P -> C b Q) -> C b P -> C b Q.
Proof.
intros b P Q H R.
cremove.
capply (H R).
Qed.

Lemma  dis_elim: forall (b: Prop -> Prop) (A B P: Prop), C b (A \/ B) -> C b (A -> P) -> C b (B -> P) -> C b P.
Proof.
intros b A B P H0 H1 H2.
cremove.
destruct H0. pose proof (H1 H). capply H0.
pose proof (H2 H). capply H0.
Qed.

Lemma o_red: forall (b: Prop -> Prop) (P: Prop), C b (C b P) -> C b P.
Proof.
    intros b P H.
    cremove.
    assumption.
Qed.

Lemma o_mp_inv': forall (b: Prop -> Prop) (P Q: Prop), (C b P -> C b Q) -> C b (P -> Q).
Proof.
    intros b P Q H1.
    cremove.
    cassumption.
Qed.

Lemma c_mp: forall (b: Prop -> Prop) (A B P Q: Prop), C b (A \/ B) -> C b (A -> P) -> C b (B -> Q) -> C b (P \/ Q).
Proof.
    intros b A B P Q D Cap Cbq.
    cremove.
    destruct D.
    specialize (Cap H); capply (or_introl Q Cap).
    specialize (Cbq H); capply (or_intror P Cbq).
Qed.

Lemma PP: forall (b: Prop -> Prop) (P Q: Prop), b P -> (P -> Q) /\ (~P -> Q) -> C b Q.
Proof.
    intros b P Q HP Hpq.
    pose proof (c_lem b P).
    cremove. decided.
    destruct H.
    assumption.
    destruct Hpq as [ Hpq _ ]. apply (Hpq H).
    destruct Hpq as [ _ Hpq ]. apply (Hpq H).
Qed.

Lemma NNPP: forall (b: Prop -> Prop) (P: Prop), b P -> ~~P -> C b P.
Proof.
intros b P HP Hnnp.
exm P; decided.
assumption.
specialize (Hnnp H); inversion Hnnp.
Qed.

Lemma Peirce: forall (b: Prop -> Prop) (P: Prop), b P -> ((P -> False) -> P) -> C b P.
Proof.
intros b P HP H.
exm P; decided. assumption.
apply H in H0. assumption.
Qed.

Lemma not_imply_elim: forall (b: Prop -> Prop) (P Q: Prop), b P -> ~ (P -> Q) -> C b P.
Proof.
intros b P Q HP H. apply (NNPP b). assumption. red.
intro. apply H. intro. absurd P; assumption.
Qed.

Lemma not_imply_elim2: forall (b: Prop -> Prop) (P Q: Prop), b Q -> ~ (P -> Q) -> C b (~ Q).
Proof.
intros b P Q HQ H. exm Q; decided. assert False. apply H. intro; assumption.
inversion H1. assumption.
Qed.

Lemma imply_to_or: forall (b: Prop -> Prop) (P Q: Prop), b P -> (P -> Q) -> C b (~ P \/ Q).
Proof.
intros b P Q HP H. exm P; decided. right. apply (H H0).
left. assumption.
Qed.

Lemma imply_to_and: forall (b: Prop -> Prop) (P Q: Prop), b P -> b Q -> ~ (P -> Q) -> C b (P /\ ~ Q).
Proof.
intros b P Q HP HQ H.
csplit. apply (not_imply_elim b P Q HP H). apply (not_imply_elim2 b P Q HQ H).
Qed.

Lemma or_to_imply: forall (b: Prop -> Prop) (P Q: Prop), b Q -> ~ P \/ Q -> P -> C b Q.
Proof.
intros b P Q HQ H H1.
destruct H.
absurd P; assumption.
cassumption.
Qed.

Lemma not_and_or: forall (b: Prop -> Prop) (P Q: Prop), b P -> b Q -> ~ (P /\ Q) -> C b ( ~P \/ ~Q ).
Proof.
intros b P Q HP HQ H.
exm P. exm Q. pose proof (conj H0 H1). absurd (P /\ Q); assumption.
all: decided. right; assumption. left; assumption.
Qed.

Lemma not_all_not_ex: forall (b: Prop -> Prop) (U: Type) (P: U -> Prop), b (exists n : U, P n) -> ~(forall n: U, ~ P n) -> C b (exists n: U, P n).
Proof.
intros b U P HP H.
apply NNPP.
assumption.
intro abs.
apply H.
intros n H2.
apply abs; exists n; exact H2.
Qed.

Lemma not_all_ex_not_p: forall (b O: Prop -> Prop) ,
  b (exists n : Prop, (fun x : Prop => ~ O x) n) ->
  b (forall n: Prop, ~ ~ O n) ->
  (forall n: Prop, (b (O n))) ->
  ~(forall P: Prop, O P) -> C b (exists P: Prop, ~ O P).
Proof.
intros b O HP HQ HR H.
pose proof (not_all_not_ex b _ (fun x => ~ O x) HP). cremove. apply (c_unit b) in H0.
apply (cremove_hyp _ _ _ H0).
apply classic_not.
assumption.
intro Hall.
unfold not in H.
apply (c_unit b) in H.
cremove_3 b H (forall n : Prop, O n) False.
apply H. cremove. apply c_prop1. intro n. specialize (Hall n).
apply (NNPP b) in Hall. assumption. apply HR.
Qed.

Inductive CI: Prop -> Prop :=
 | ci_unit: forall P: Prop, P -> CI P
 | ci_prop1: forall (f: Prop -> Prop), (forall P: Prop, CI (f P)) -> CI (forall P: Prop, f P)
 | ci_prop2: forall (P Q: Prop), (P -> CI Q) -> CI (P -> Q)
 | ci_bind: forall P Q: Prop, CI P -> (P -> CI Q) -> CI Q
 | ci_lem: forall P: Prop, CI (P \/ ~P)
.

Lemma if_exm: forall P: Prop, Lem (fun _: Prop => True) -> CI P -> P.
  Proof.
      intros P H CI.
      induction CI.
      assumption.
      assumption.
      assumption.
      apply (H1 IHCI).
      apply (H P). trivial.
Qed.

Ltac ciremove_0 H X Y Z := let a := fresh "H" in pose proof (ci_prop2 _ _ H) as a;
apply (ci_bind _ Z) in a; [ assumption | ]; let b := fresh "H" in
intro b; move b before H; clear H; clear a; rename b into H.

Ltac ciremove_1 H X Y Z :=
    let a := fresh "H" in assert (X -> Y) as a;
    [ let b := fresh "H" in intro b; apply (ci_unit X) in b; apply H in b; assumption
     | clear H; rename a into H ].

Ltac ciremove_2 H X Y :=
    apply (ci_bind _ Y) in H; [assumption | ]; let a := fresh "H" in
    intro a; move a before H; clear H; rename a into H.

Lemma ciremove_hyp: forall P Q: Prop, CI (P -> Q) -> CI P -> CI Q.
Proof.
    intros P Q H1 H2.
    ciremove_2 H1 (P -> Q) Q.
    ciremove_2 H2 P Q.
    apply H1 in H2. apply ci_unit; assumption.
Qed.

Ltac ciremove_3 H X Y :=
    let a := fresh "H" in assert (a := ciremove_hyp X Y H); move a before H; clear H; rename a into H
.

Ltac ciremove := repeat lazymatch goal with
 | [ H: ?X -> CI ?Y |- CI ?Z ] =>
    ciremove_0 H X Y Z
 | [ H: CI ?X -> ?Y |- CI ?Z ] =>
    ciremove_1 H X Y Z
 | [ H: CI ?X |- CI ?Y ] =>
    ciremove_2 H X Y
 | [ |- CI (?X -> ?Y) ] =>
    apply (ci_prop1 X Y)
 | [ |- ?X -> _ ] => intro
 | [ H: CI (?X -> ?Y) |- _ ] =>
    ciremove_3 H X Y
end.

Ltac ciassumption := lazymatch goal with
 | [ H: ?X |- CI ?X ] => apply ci_unit; assumption
end.

Ltac ciapply H := apply (ci_unit _ H).
Ltac cidecided := apply ci_unit.

Ltac cidestruct H := ciremove; destruct H.
Lemma oi_and: forall P Q: Prop, CI P /\ CI Q -> CI (P /\ Q).
Proof.
    intros P Q H.
    destruct H as [ H0 H1 ].
    ciremove.
    cidecided.
    apply (conj H0 H1).
Qed.

Ltac cisplit := lazymatch goal with
 | [ |- CI (?A /\ ?B) ] => apply (oi_and A B); split
end.

Ltac ciexm P := let a := fresh "H" in pose proof (ci_lem P) as a;
  let b := type of a in let c := lazymatch goal with | [ |- CI ?Z ] => Z end in ciremove_2 a b c; destruct a.

Lemma ci_false: (exists P: Prop, CI P /\ ~P) -> CI False.
Proof.
    intros H.
    destruct H. destruct H.
    ciremove. absurd x; assumption.
Qed.

Lemma ci_not: forall P: Prop, (P -> CI False) -> CI (~ P).
Proof.
    intros P H.
    ciexm P.
    apply H in H0.
    ciremove; inversion H0.
    ciassumption.
Qed.

Lemma oi_mp: forall P Q: Prop, CI (P -> Q) -> CI P -> CI Q.
Proof.
    intros P Q H1 H2.
    ciremove. specialize (H1 H2). ciassumption.
Qed.

Lemma oi_fmapd: forall A B P: Prop, CI (A \/ B) -> (A -> CI P) -> (B -> CI P) -> CI P.
Proof.
    intros A B P.
    ciremove.
    destruct H. ciapply (H0 H).
    ciapply (H1 H).
Qed.

Lemma oi_dfmapo: forall P A B: Prop, CI P -> (P -> CI (A \/ B)) -> CI (A \/ B).
Proof.
    intros P A B H1 H2.
    ciremove.
    ciapply (H2 H1).
Qed.

Lemma oi_dfmapd: forall A B P Q: Prop, CI (A \/ B) -> (A -> CI (P \/ Q)) -> (B -> CI (P \/ Q)) -> CI (P \/ Q).
Proof.
    intros A B P Q H1 H2 H3.
    ciremove.
    destruct H1.
    ciapply (H2 H).
    ciapply (H3 H).
Qed.

Lemma oi_fmapo_c: forall P Q: Prop, (P -> CI Q) -> CI P -> CI Q.
Proof.
intros P Q H R.
ciremove.
ciapply (H R).
Qed.

Lemma  disi_elim: forall A B P: Prop, CI (A \/ B) -> CI (A -> P) -> CI (B -> P) -> CI P.
Proof.
intros A B P H0 H1 H2.
ciremove.
destruct H0. pose proof (H1 H). ciapply H0.
pose proof (H2 H). ciapply H0.
Qed.

Lemma oi_red: forall P: Prop, CI (CI P) -> CI P.
Proof.
    intros P H.
    ciremove.
    ciassumption.
Qed.

Lemma oi_mp_inv': forall P Q: Prop, (CI P -> CI Q) -> CI (P -> Q).
Proof.
    intros P Q H1.
    ciremove.
    ciassumption.
Qed.

Lemma ci_mp: forall A B P Q: Prop, CI (A \/ B) -> CI (A -> P) -> CI (B -> Q) -> CI (P \/ Q).
Proof.
    intros A B P Q D Cap Cbq.
    ciremove.
    destruct D.
    specialize (Cap H); ciapply (or_introl Q Cap).
    specialize (Cbq H); ciapply (or_intror P Cbq).
Qed.

Lemma PPi: forall P Q: Prop, (P -> Q) /\ (~P -> Q) -> CI Q.
Proof.
    intros P Q Hpq.
    pose proof (ci_lem P).
    ciremove. cidecided.
    destruct H.
    destruct Hpq as [ Hpq _ ]. apply (Hpq H).
    destruct Hpq as [ _ Hpq ]. apply (Hpq H).
Qed.

Lemma NNPPi: forall P: Prop, ~~P -> CI P.
Proof.
intros P Hnnp.
ciexm P; cidecided.
assumption.
specialize (Hnnp H); inversion Hnnp.
Qed.

Lemma Peircei: forall P: Prop, ((P -> False) -> P) -> CI P.
Proof.
intros P H.
ciexm P; cidecided. assumption.
apply H in H0. assumption.
Qed.

Lemma not_imply_elimi: forall P Q: Prop, ~ (P -> Q) -> CI P.
Proof.
intros P Q H. apply NNPPi. red.
intro. apply H. intro. absurd P; assumption.
Qed.

Lemma not_imply_elim2i: forall P Q: Prop, ~ (P -> Q) -> CI (~ Q).
Proof.
intros P Q H. ciexm Q; cidecided. assert False. apply H. intro; assumption.
inversion H1. assumption.
Qed.

Lemma imply_to_ori: forall P Q: Prop, (P -> Q) -> CI (~ P \/ Q).
Proof.
intros P Q H. ciexm P; cidecided. right. apply (H H0).
left. assumption.
Qed.

Lemma imply_to_andi: forall P Q: Prop, ~ (P -> Q) -> CI (P /\ ~ Q).
Proof.
intros P Q H.
cisplit. apply (not_imply_elimi P Q H). apply (not_imply_elim2i P Q H).
Qed.

Lemma or_to_implyi: forall P Q: Prop, ~ P \/ Q -> P -> CI Q.
Proof.
intros P Q H H1.
destruct H.
absurd P; assumption.
ciassumption.
Qed.

Lemma not_and_ori: forall P Q: Prop, ~ (P /\ Q) -> CI ( ~P \/ ~Q ).
Proof.
intros P Q H.
ciexm P. ciexm Q. pose proof (conj H0 H1). absurd (P /\ Q); assumption.
all: cidecided. right; assumption. left; assumption.
Qed.

Lemma not_all_not_exi: forall (U: Type) (P: U -> Prop) , ~(forall n: U, ~ P n) -> CI (exists n: U, P n).
Proof.
intros U P H.
apply NNPPi.
intro abs.
apply H.
intros n H2.
apply abs; exists n; exact H2.
Qed.

Lemma not_all_ex_not_pi: forall (O: Prop -> Prop) , ~(forall P: Prop, O P) -> CI (exists P: Prop, ~ O P).
Proof.
intros O H.
pose proof (not_all_not_exi _ (fun x => ~ O x)). ciremove. apply ci_unit in H0.
apply (ciremove_hyp _ _ H0).
apply ci_not.
intro Hall.
unfold not in H.
apply ci_unit in H.
ciremove_3 H (forall n : Prop, O n) False.
apply H. ciremove. apply ci_prop1. intro n. specialize (Hall n).
apply NNPPi in Hall. assumption.
Qed.

Lemma using_CI: forall A : Prop, ((forall P: Prop, CI P -> P) -> A) -> CI A.
Proof.
    intros A H.
    ciexm (forall P: Prop, CI P -> P).
    cidecided. apply (H H0).
    assert (CI (exists P: Prop, ~ (CI P -> P))).
    apply not_all_ex_not_pi. assumption.
    cidestruct H1.
    apply imply_to_andi in H1.
    cidestruct H1.
    ciremove. absurd x; assumption.
Qed.

Lemma using_ciexm: forall A: Prop, (Lem (fun _ => True) -> A) -> CI A.
Proof.
    intros A H.
    apply using_CI.
    intro Hctoi.
    assert (forall P: Prop, P \/ ~P).
    intro P.
    pose proof (ci_lem P). specialize (Hctoi (P \/ ~P) H0). assumption.
    assert (Lem (fun _: Prop => True)).
    unfold Lem. intros. apply H0.
    apply (H H1).
Qed.

Theorem equiv_C_CI: forall P: Prop, C (fun _ => True) P <-> CI P.
Proof.
    split; intro H.
    apply using_ciexm. assumption.
    intro Hciexm. apply (if_exm _ Hciexm H).
Qed.

Definition ci_proof_lem: CI (Lem (fun _ => True)).
Proof.
    apply using_ciexm.
    intro H; apply H.
Qed.

Definition weak_lem :=
(fun (P : Prop) (vnP : P -> False) (vnnP : ~ P -> False) => vnnP vnP)
: forall (P: Prop), (P -> False) -> (~P -> False) -> False.

Definition notnot_lem:= (fun P : Prop =>
 (fun H : ~ (P \/ ~ P) =>
  weak_lem P (fun vP : P => H (or_introl vP)) (fun vnP : ~ P => H (or_intror vnP)))
 : ~ ~ (P \/ ~ P)).

Lemma not_all_not_not_ex: forall (U: Type) (P: U -> Prop) , ~(forall n: U, ~ P n) -> ~~(exists n: U, P n).
Proof.
intros U P H.
intro abs.
apply H.
intros n H2.
apply abs; exists n; exact H2.
Qed.

Lemma weak_lem_ex: forall (U: Type) (P: U -> Prop), ((forall n: U, ~ P n) -> False) -> ((exists n: U, P n) -> False) -> False.
Proof.
intros U P.
intros HF HE.
apply (weak_lem (exists n: U, P n)).
assumption.
apply not_all_not_not_ex.
assumption.
Qed.

Lemma forall_transfer: forall (U: Type) (P: U -> Prop) (R: Prop), (exists n: U, True) -> (forall n: U, P n -> R) -> (forall n: U, P n) -> R.
Proof.
intros U P R eU H1 H2.
destruct eU.
specialize (H1 x).
specialize (H2 x).
apply (H1 H2).
Qed.

Lemma atp: forall P R: Prop, ((P -> R) -> R) -> ~P -> R.
intros P R hprr hnp.
assert (P -> R).
intro K. assert False. apply (hnp K). destruct H.
apply (hprr H).
Qed.

Lemma not_ex_not_not_all: forall (U: Type) (P: U -> Prop) , ~(exists n: U, ~ P n)  -> (forall n: U, ~~ P n) .
Proof.
intros U P H n pn.
apply H.
exists n.
assumption.
Qed.

Definition DNS := (forall (O: Prop -> Prop), (forall Q: Prop, ~~ (O Q)) -> ~~ (forall Q: Prop, O Q)).

Definition DN (P: Prop) := DNS -> ~~ P.

Definition DNRel (P Q: Prop) := P = Q.

Definition CDNProp : CI DNS.
Proof.
apply using_CI.
intro Hctoi.
intros O P.
enough (forall Q: Prop, O Q).
intro K. apply (K H).
intro vQ.
specialize (P vQ).
apply (Hctoi _ (NNPPi _ P)).
Qed.

Lemma using_nn: forall A: Prop, DN A -> CI A.
Proof.
  intros A H.
  apply using_CI.
  intro Hctoi.
  apply (Hctoi _ (NNPPi _ (H (Hctoi _ CDNProp)))).
Qed.

Lemma DNLem: DN Lem .
Proof.
intro H.
apply (H _).
intro P.
apply notnot_lem.
Qed.

Lemma nn_using: forall A: Prop, CI A ->
  DN A.
Proof.
intros A H HI. intro K.
apply (weak_lem (forall P: Prop, P \/ ~P)).
intro Lem. apply (K (if_exm A Lem H)).
apply (DNLem HI).
Qed.

Lemma equiv_DN_CI: forall A: Prop, DN A <-> CI A.
Proof.
    intro A. split. apply using_nn. apply nn_using.
Qed.

Lemma NNmp: forall P Q: Prop, (P -> Q) -> ~~P -> ~~Q.
Proof.
intros P Q H nnP K.
apply (weak_lem P).
intro vP. apply (K (H vP)).
intro nP. apply (nnP nP).
Qed.

Lemma NNNN: forall P: Prop, ~~~~P -> ~~P.
Proof.
intros P H.
intro nP.
apply (weak_lem (~~P)).
intro nnnP. apply (nnnP nP).
intro nnnP. apply (H nnnP).
Qed.`


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*i 	$Id$	 i*)

(*s Sets operations on maps *)

Require Import Bool.
Require Import Sumbool.
Require Import NArith.
Require Import Ndigits.
Require Import Ndec.
Require Import Map.

Section Dom.

  Variables A B : Type.

  Fixpoint MapDomRestrTo (m:Map A) : Map B -> Map A :=
    match m with
    | M0 => fun _:Map B => M0 A
    | M1 a y =>
        fun m':Map B => match MapGet B m' a with
                        | None => M0 A
                        | _ => m
                        end
    | M2 m1 m2 =>
        fun m':Map B =>
          match m' with
          | M0 => M0 A
          | M1 a' y' =>
              match MapGet A m a' with
              | None => M0 A
              | Some y => M1 A a' y
              end
          | M2 m'1 m'2 =>
              makeM2 A (MapDomRestrTo m1 m'1) (MapDomRestrTo m2 m'2)
          end
    end.

  Lemma MapDomRestrTo_semantics :
   forall (m:Map A) (m':Map B),
     eqm A (MapGet A (MapDomRestrTo m m'))
       (fun a0:ad =>
          match MapGet B m' a0 with
          | None => None
          | _ => MapGet A m a0
          end).
  Proof.
    unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (MapGet B m' a); trivial.
    intros. simpl in |- *. elim (sumbool_of_bool (Neqb a a1)). intro H. rewrite H.
    rewrite <- (Neqb_complete _ _ H). case (MapGet B m' a); try reflexivity.
    intro. apply M1_semantics_1.
    intro H. rewrite H. case (MapGet B m' a).
    case (MapGet B m' a1); intros; exact (M1_semantics_2 A a a1 a0 H).
    case (MapGet B m' a1); reflexivity.
    simple induction m'. trivial.
    unfold MapDomRestrTo in |- *. intros. elim (sumbool_of_bool (Neqb a a1)).
    intro H1.
    rewrite (Neqb_complete _ _ H1). rewrite (M1_semantics_1 B a1 a0).
    case (MapGet A (M2 A m0 m1) a1); try reflexivity.
    intro. apply M1_semantics_1.
    intro H1. rewrite (M1_semantics_2 B a a1 a0 H1). case (MapGet A (M2 A m0 m1) a); try reflexivity.
    intro. exact (M1_semantics_2 A a a1 a2 H1).
    intros. change
   (MapGet A (makeM2 A (MapDomRestrTo m0 m2) (MapDomRestrTo m1 m3)) a =
    match MapGet B (M2 B m2 m3) a with
    | None => None
    | Some _ => MapGet A (M2 A m0 m1) a
    end) in |- *.
    rewrite (makeM2_M2 A (MapDomRestrTo m0 m2) (MapDomRestrTo m1 m3) a).
    rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (Ndiv2 a)). rewrite (H m2 (Ndiv2 a)).
    rewrite (MapGet_M2_bit_0_if B m2 m3 a). rewrite (MapGet_M2_bit_0_if A m0 m1 a).
    case (Nbit0 a); reflexivity.
  Qed.

  Fixpoint MapDomRestrBy (m:Map A) : Map B -> Map A :=
    match m with
    | M0 => fun _:Map B => M0 A
    | M1 a y =>
        fun m':Map B => match MapGet B m' a with
                        | None => m
                        | _ => M0 A
                        end
    | M2 m1 m2 =>
        fun m':Map B =>
          match m' with
          | M0 => m
          | M1 a' y' => MapRemove A m a'
          | M2 m'1 m'2 =>
              makeM2 A (MapDomRestrBy m1 m'1) (MapDomRestrBy m2 m'2)
          end
    end.

  Lemma MapDomRestrBy_semantics :
   forall (m:Map A) (m':Map B),
     eqm A (MapGet A (MapDomRestrBy m m'))
       (fun a0:ad =>
          match MapGet B m' a0 with
          | None => MapGet A m a0
          | _ => None
          end).
  Proof.
    unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (MapGet B m' a); trivial.
    intros. simpl in |- *. elim (sumbool_of_bool (Neqb a a1)). intro H. rewrite H.
    rewrite (Neqb_complete _ _ H). case (MapGet B m' a1). trivial.
    apply M1_semantics_1.
    intro H. rewrite H. case (MapGet B m' a).
    case (MapGet B m' a1); trivial.
    rewrite (M1_semantics_2 A a a1 a0 H).
    case (MapGet B m' a1); trivial.
    simple induction m'. trivial.
    unfold MapDomRestrBy in |- *. intros. rewrite (MapRemove_semantics A (M2 A m0 m1) a a1).
    elim (sumbool_of_bool (Neqb a a1)). intro H1. rewrite H1. rewrite (Neqb_complete _ _ H1).
    rewrite (M1_semantics_1 B a1 a0). reflexivity.
    intro H1. rewrite H1. rewrite (M1_semantics_2 B a a1 a0 H1). reflexivity.
    intros. change
   (MapGet A (makeM2 A (MapDomRestrBy m0 m2) (MapDomRestrBy m1 m3)) a =
    match MapGet B (M2 B m2 m3) a with
    | None => MapGet A (M2 A m0 m1) a
    | Some _ => None
    end) in |- *.
    rewrite (makeM2_M2 A (MapDomRestrBy m0 m2) (MapDomRestrBy m1 m3) a).
    rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (Ndiv2 a)). rewrite (H m2 (Ndiv2 a)).
    rewrite (MapGet_M2_bit_0_if B m2 m3 a). rewrite (MapGet_M2_bit_0_if A m0 m1 a).
    case (Nbit0 a); reflexivity.
  Qed.

  Definition in_dom (a:ad) (m:Map A) :=
    match MapGet A m a with
    | None => false
    | _ => true
    end.

  Lemma in_dom_M0 : forall a:ad, in_dom a (M0 A) = false.
  Proof.
    trivial.
  Qed.

  Lemma in_dom_M1 : forall (a a0:ad) (y:A), in_dom a0 (M1 A a y) = Neqb a a0.
  Proof.
    unfold in_dom in |- *. intros. simpl in |- *. case (Neqb a a0); reflexivity.
  Qed.

  Lemma in_dom_M1_1 : forall (a:ad) (y:A), in_dom a (M1 A a y) = true.
  Proof.
    intros. rewrite in_dom_M1. apply Neqb_correct.
  Qed.

  Lemma in_dom_M1_2 :
   forall (a a0:ad) (y:A), in_dom a0 (M1 A a y) = true -> a = a0.
  Proof.
    intros. apply (Neqb_complete a a0). rewrite (in_dom_M1 a a0 y) in H. assumption.
  Qed.

  Lemma in_dom_some :
   forall (m:Map A) (a:ad),
     in_dom a m = true -> {y : A | MapGet A m a = Some y}.
  Proof.
    unfold in_dom in |- *. intros. elim (option_sum _ (MapGet A m a)). trivial.
    intro H0. rewrite H0 in H. discriminate H.
  Qed.

  Lemma in_dom_none :
   forall (m:Map A) (a:ad), in_dom a m = false -> MapGet A m a = None.
  Proof.
    unfold in_dom in |- *. intros. elim (option_sum _ (MapGet A m a)). intro H0. elim H0.
    intros y H1. rewrite H1 in H. discriminate H.
    trivial.
  Qed.

  Lemma in_dom_put :
   forall (m:Map A) (a0:ad) (y0:A) (a:ad),
     in_dom a (MapPut A m a0 y0) = orb (Neqb a a0) (in_dom a m).
  Proof.
    unfold in_dom in |- *. intros. rewrite (MapPut_semantics A m a0 y0 a).
    elim (sumbool_of_bool (Neqb a a0)). intro H. rewrite H. rewrite (Neqb_comm a a0) in H.
    rewrite H. rewrite orb_true_b. reflexivity.
    intro H. rewrite H. rewrite (Neqb_comm a a0) in H. rewrite H. rewrite orb_false_b.
    reflexivity.
  Qed.

  Lemma in_dom_put_behind :
   forall (m:Map A) (a0:ad) (y0:A) (a:ad),
     in_dom a (MapPut_behind A m a0 y0) = orb (Neqb a a0) (in_dom a m).
  Proof.
    unfold in_dom in |- *. intros. rewrite (MapPut_behind_semantics A m a0 y0 a).
    elim (sumbool_of_bool (Neqb a a0)). intro H. rewrite H. rewrite (Neqb_comm a a0) in H.
    rewrite H. case (MapGet A m a); reflexivity.
    intro H. rewrite H. rewrite (Neqb_comm a a0) in H. rewrite H. case (MapGet A m a); trivial.
  Qed.

  Lemma in_dom_remove :
   forall (m:Map A) (a0 a:ad),
     in_dom a (MapRemove A m a0) = andb (negb (Neqb a a0)) (in_dom a m).
  Proof.
    unfold in_dom in |- *. intros. rewrite (MapRemove_semantics A m a0 a).
    elim (sumbool_of_bool (Neqb a a0)). intro H. rewrite H. rewrite (Neqb_comm a a0) in H.
    rewrite H. reflexivity.
    intro H. rewrite H. rewrite (Neqb_comm a a0) in H. rewrite H.
    case (MapGet A m a); reflexivity.
  Qed.

  Lemma in_dom_merge :
   forall (m m':Map A) (a:ad),
     in_dom a (MapMerge A m m') = orb (in_dom a m) (in_dom a m').
  Proof.
    unfold in_dom in |- *. intros. rewrite (MapMerge_semantics A m m' a).
    elim (option_sum A (MapGet A m' a)). intro H. elim H. intros y H0. rewrite H0.
    case (MapGet A m a); reflexivity.
    intro H. rewrite H. rewrite orb_b_false. reflexivity.
  Qed.

  Lemma in_dom_delta :
   forall (m m':Map A) (a:ad),
     in_dom a (MapDelta A m m') = xorb (in_dom a m) (in_dom a m').
  Proof.
    unfold in_dom in |- *. intros. rewrite (MapDelta_semantics A m m' a).
    elim (option_sum A (MapGet A m' a)). intro H. elim H. intros y H0. rewrite H0.
    case (MapGet A m a); reflexivity.
    intro H. rewrite H. case (MapGet A m a); reflexivity.
  Qed.

End Dom.

Section InDom.

  Variables A B : Type.

  Lemma in_dom_restrto :
   forall (m:Map A) (m':Map B) (a:ad),
     in_dom A a (MapDomRestrTo A B m m') =
     andb (in_dom A a m) (in_dom B a m').
  Proof.
    unfold in_dom in |- *. intros. rewrite (MapDomRestrTo_semantics A B m m' a).
    elim (option_sum B (MapGet B m' a)). intro H. elim H. intros y H0. rewrite H0.
    rewrite andb_b_true. reflexivity.
    intro H. rewrite H. rewrite andb_b_false. reflexivity.
  Qed.

  Lemma in_dom_restrby :
   forall (m:Map A) (m':Map B) (a:ad),
     in_dom A a (MapDomRestrBy A B m m') =
     andb (in_dom A a m) (negb (in_dom B a m')).
  Proof.
    unfold in_dom in |- *. intros. rewrite (MapDomRestrBy_semantics A B m m' a).
    elim (option_sum B (MapGet B m' a)). intro H. elim H. intros y H0. rewrite H0.
    unfold negb in |- *. rewrite andb_b_false. reflexivity.
    intro H. rewrite H. unfold negb in |- *. rewrite andb_b_true. reflexivity.
  Qed.

End InDom.

Definition FSet := Map unit.

Section FSetDefs.

  Variable A : Type.

  Definition in_FSet : ad -> FSet -> bool := in_dom unit.

  Fixpoint MapDom (m:Map A) : FSet :=
    match m with
    | M0 => M0 unit
    | M1 a _ => M1 unit a tt
    | M2 m m' => M2 unit (MapDom m) (MapDom m')
    end.

  Lemma MapDom_semantics_1 :
   forall (m:Map A) (a:ad) (y:A),
     MapGet A m a = Some y -> in_FSet a (MapDom m) = true.
  Proof.
    simple induction m. intros. discriminate H.
    unfold MapDom in |- *. unfold in_FSet in |- *. unfold in_dom in |- *. unfold MapGet in |- *. intros a y a0 y0.
    case (Neqb a a0). trivial.
    intro. discriminate H.
    intros m0 H m1 H0 a y. rewrite (MapGet_M2_bit_0_if A m0 m1 a). simpl in |- *. unfold in_FSet in |- *.
    unfold in_dom in |- *. rewrite (MapGet_M2_bit_0_if unit (MapDom m0) (MapDom m1) a).
    case (Nbit0 a). unfold in_FSet, in_dom in H0. intro. apply H0 with (y := y). assumption.
    unfold in_FSet, in_dom in H. intro. apply H with (y := y). assumption.
  Qed.

  Lemma MapDom_semantics_2 :
   forall (m:Map A) (a:ad),
     in_FSet a (MapDom m) = true -> {y : A | MapGet A m a = Some y}.
  Proof.
    simple induction m. intros. discriminate H.
    unfold MapDom in |- *. unfold in_FSet in |- *. unfold in_dom in |- *. unfold MapGet in |- *. intros a y a0. case (Neqb a a0).
    intro. split with y. reflexivity.
    intro. discriminate H.
    intros m0 H m1 H0 a. rewrite (MapGet_M2_bit_0_if A m0 m1 a). simpl in |- *. unfold in_FSet in |- *.
    unfold in_dom in |- *. rewrite (MapGet_M2_bit_0_if unit (MapDom m0) (MapDom m1) a).
    case (Nbit0 a). unfold in_FSet, in_dom in H0. intro. apply H0. assumption.
    unfold in_FSet, in_dom in H. intro. apply H. assumption.
  Qed.

  Lemma MapDom_semantics_3 :
   forall (m:Map A) (a:ad),
     MapGet A m a = None -> in_FSet a (MapDom m) = false.
  Proof.
    intros. elim (sumbool_of_bool (in_FSet a (MapDom m))). intro H0.
    elim (MapDom_semantics_2 m a H0). intros y H1. rewrite H in H1. discriminate H1.
    trivial.
  Qed.

  Lemma MapDom_semantics_4 :
   forall (m:Map A) (a:ad),
     in_FSet a (MapDom m) = false -> MapGet A m a = None.
  Proof.
    intros. elim (option_sum A (MapGet A m a)). intro H0. elim H0. intros y H1.
    rewrite (MapDom_semantics_1 m a y H1) in H. discriminate H.
    trivial.
  Qed.

  Lemma MapDom_Dom :
   forall (m:Map A) (a:ad), in_dom A a m = in_FSet a (MapDom m).
  Proof.
    intros. elim (sumbool_of_bool (in_FSet a (MapDom m))). intro H.
    elim (MapDom_semantics_2 m a H). intros y H0. rewrite H. unfold in_dom in |- *. rewrite H0.
    reflexivity.
    intro H. rewrite H. unfold in_dom in |- *. rewrite (MapDom_semantics_4 m a H). reflexivity.
  Qed.

  Definition FSetUnion (s s':FSet) : FSet := MapMerge unit s s'.

  Lemma in_FSet_union :
   forall (s s':FSet) (a:ad),
     in_FSet a (FSetUnion s s') = orb (in_FSet a s) (in_FSet a s').
  Proof.
    exact (in_dom_merge unit).
  Qed.

  Definition FSetInter (s s':FSet) : FSet := MapDomRestrTo unit unit s s'.

  Lemma in_FSet_inter :
   forall (s s':FSet) (a:ad),
     in_FSet a (FSetInter s s') = andb (in_FSet a s) (in_FSet a s').
  Proof.
    exact (in_dom_restrto unit unit).
  Qed.

  Definition FSetDiff (s s':FSet) : FSet := MapDomRestrBy unit unit s s'.

  Lemma in_FSet_diff :
   forall (s s':FSet) (a:ad),
     in_FSet a (FSetDiff s s') = andb (in_FSet a s) (negb (in_FSet a s')).
  Proof.
    exact (in_dom_restrby unit unit).
  Qed.

  Definition FSetDelta (s s':FSet) : FSet := MapDelta unit s s'.

  Lemma in_FSet_delta :
   forall (s s':FSet) (a:ad),
     in_FSet a (FSetDelta s s') = xorb (in_FSet a s) (in_FSet a s').
  Proof.
    exact (in_dom_delta unit).
  Qed.

End FSetDefs.

Lemma FSet_Dom : forall s:FSet, MapDom unit s = s.
Proof.
  simple induction s. trivial.
  simpl in |- *. intros a t. elim t. reflexivity.
  intros. simpl in |- *. rewrite H. rewrite H0. reflexivity.
Qed.


(* * Basic definitions of decidablility and Functions
- includes basic Lemmas about said functions
 *)

From Undecidability.Shared.Libs.PSL Require Export Base.
From Undecidability.Shared.Libs.PSL Require Import FinTypesDef.

(* * Definition of useful tactics *)

(* dec is used to destruct all decisions appearing in the goal or assumptions. *)
Ltac dec := repeat (destruct Dec).

(* This tactic completely solves listComplete goals for base types *)
Ltac listComplete := intros x; simpl; dec; destruct x; try congruence.
(* simplifies (decision x = x) *)
Ltac deq x := destruct (Dec (x=x)) as [[]  | isnotequal]; [> | contradict isnotequal; reflexivity] .

(* Function that takes two lists and returns the list of all pairs of elements from the two lists *)
Fixpoint prodLists {X Y: Type} (A: list X) (B: list Y) {struct A} :=
  match A with
  | nil => nil
  | cons x A' => map (fun y => (x,y)) B ++ prodLists A' B end.

(* Crossing any list with the empty list always yields the empty list *)
Lemma prod_nil (X Y: Type) (A: list X) :
  prodLists A ([]: list Y) = [].
Proof.
  induction A.
  - reflexivity.
  - cbn. assumption.
Qed.

(* This function takes a (A: list X) and yields a list (option X) which for every x in A contains Some x. The resultung list also contains None. The order is preserved. None is the first element of the resulting list. *)

Definition toOptionList {X: Type} (A: list X) :=
  None :: map (@Some _) A .

Definition toSumList1 {X: Type}  (Y: Type) (A: list X): list (X + Y) :=
  map inl A.
Definition toSumList2 {Y: Type}  (X: Type) (A: list Y): list (X + Y) :=
  map inr A.

(* * Basic lemmas about functions *)

(* In the list containing all pairs of (x,y') with y' from a list B the pair (x,y) is contained exactly as many times as y is contained in the list B. *)

Lemma countMap (X Y: eqType) (x:X) (B: list Y) y :
  count ( map (fun y => (x,y)) B) (x, y) = count B y.
Proof.
  induction B.
  - reflexivity.
  - simpl. dec;  congruence.
Qed.

(* If a list is split somewhere in two list the number of occurences of an element in the list is equal to the sum of the number of occurences in the left and the right part. *)

Lemma countSplit (X: eqType) (A B: list X) (x: X)  : count A x + count B x = count (A ++ B) x.
Proof.
  induction A.
  - reflexivity.
  - cbn. decide (x=a).
    +cbn. f_equal; exact IHA.
    + exact IHA.
Qed.

(* In a list of tupels with x as a left element the number of tupels with something different from x as a left element is 0. *)
Lemma countMapZero  (X Y: eqType) (x x':X) (B: list Y) y : x' <> x -> count  ( map (fun y => (x,y)) B) (x', y) =0.
Proof.
  intros ineq. induction B.
  - reflexivity.
  -  simpl. dec.
     + inversion e; congruence.
     + exact IHB.
Qed.

Lemma notInZero (X: eqType) (x: X) A :
  not (x el A) <-> count A x = 0.
Proof.
  split; induction A.
  -  reflexivity.
  - intros H. cbn in *. dec.
    + exfalso. apply H. left. congruence.
    + apply IHA. intros F. apply H. now right.
  - tauto.
  - cbn. dec.
    + subst a. lia.
    + intros H [E | E].
      * now symmetry in E.
      * tauto.
Qed.

Lemma countIn (X:eqType) (x:X) A:
  count A x > 0 -> x el A.
Proof.
  induction A.
  - cbn. lia.
  - cbn.  dec.
    + intros. left. symmetry. exact e.
    + intros. right. apply IHA. exact H.
Qed.

Lemma InCount (X:eqType) (x:X) A:
  x el A -> count A x > 0.
Proof.
  induction A.
  - intros [].
  - intros [[] | E]; cbn.
    + deq a. lia.
    + specialize (IHA E). dec; lia.
Qed.

Lemma count_in_equiv (X: eqType) (x:X) A : count A x > 0 <-> x el A.
Proof.
  split.
  - apply countIn.
  - apply InCount.
Qed.

Lemma countApp (X: eqType) (x: X) (A B: list X) :
  count (A ++ x::B) x > 0.
Proof.
  auto using InCount.
Qed.

(*  Dupfree Lists containing every x countain x exactly once *)
Lemma dupfreeCount (X: eqType) (x:X) (A: list X) : dupfree A -> x el A -> count A x = 1.
Proof.
  intros D E. induction D.
  -  contradiction E.
  - cbn. dec.
    + f_equal. subst x0. now apply notInZero.
    + destruct E as [E | E]; [> congruence | auto].
Qed.

(* toSumlist1 does not change the number of occurences of an existing element in the list *)
Lemma toSumList1_count (X: eqType) (x: X) (Y: eqType) (A: list X) :
  count (toSumList1 Y A) (inl x) =  count A x .
Proof.
  induction A; simpl; dec; congruence.
Qed.

(* toSumlist2 odes not change the numbe of occurences of an existing element in the list *)
Lemma toSumList2_count (X Y: eqType) (y: Y) (A: list Y):
  count (toSumList2 X A) (inr y) = count A y.
Proof.
  induction A; simpl; dec; congruence.
Qed.

(* to sumList1 does not produce inr proofs *)
Lemma toSumList1_missing (X Y: eqType) (y: Y) (A: list X):
  count (toSumList1 Y A ) (inr y) = 0.
Proof.
  induction A; dec; firstorder.
Qed.

(* toSumlist2 does not produce inl proofs *)
Lemma toSumList2_missing (X Y: eqType) (x: X) (A: list Y):
  count (toSumList2 X A ) (inl x) = 0.
Proof.
  induction A; dec; firstorder.
Qed.

(* * Cardinality Lemmas for lists*)
Lemma cons_incll (X: Type) (A B: list X) (x:X) : x::A <<= B -> A <<= B.
Proof.
  unfold "<<=". auto.
Qed.

Lemma card_length_leq (X: eqType) (A: list X) : card A <= length A.
Proof.
  induction A; auto. cbn. dec; lia.
Qed.

(* * Various helpful Lemmas *)

(* If the concatenation of two lists is nil then each list was nil *)
Lemma appendNil (X: Type) (A B: list X) :
  A ++ B = nil -> A = nil /\ B = nil.
Proof.
  intros H. assert (|A ++ B| = 0) by now rewrite H.
  rewrite app_length in H0. rewrite <- !length_zero_iff_nil. lia.
Qed.

Lemma countZero (X: eqType) (x: X) (A: list X) : count A x = 0 -> not (x el A).
Proof.
  induction A; cbn in *; dec; firstorder congruence.
Qed.

(* The product of two numbers is greater zero if both numbers are greater zero *)
Lemma NullMul a b : a > 0 -> b > 0 -> a * b > 0.
Proof.
  induction 1; cbn; lia.
Qed.


Load "tact_DH_2".

Theorem pi2''_pi2': phi35 ~ phi45.

Proof.
unfold phi35, phi45.
unfold phi5.
 repeat unf_phi. simpl. repeat unf_trm.
repeat unf.

rewrite andB_assoc with (b2:= (EQ_M (m x2) (grn 1))).
rewrite andB_comm with (b1:= ((EQ_M (m x2) (grn 1)))).
rewrite <-andB_assoc with (b3:= (EQ_M (m x2) (grn 1))).
rewrite andB_comm with (b2:=  (EQ_M (m x2) (grn 1))).
unfold mx2rn2.
 repeat rewrite EQ_BRmsg_msg' with (m1 := (m x2)) (m2:= (grn 1)) (m:= (m x2))   (m3:= (exp (G 0) (m x2) (r 2))) (b:=  (((((((EQ_M (reveal x4) (i 2)) & (EQ_M (to x3) (i 1))) &
                             (EQ_M (to x2) (i 2))) &
                            (EQ_M (to x1) (i 1))) &
                           (notb (EQ_M (act x3) new))) &
                          (EQ_M (act x1) new)) & (EQ_M (m x3) (grn 2)))).

simpl.
rewrite andB_comm with (b1:=  (((((((EQ_M (reveal x4) (i 1)) &
                                 (EQ_M (to x3) (i 1))) &
                                (EQ_M (to x2) (i 2))) &
                               (EQ_M (to x1) (i 1))) &
                              (notb (EQ_M (act x3) new))) &
                             (EQ_M (act x1) new)) &
                            (EQ_M (m x2) (grn 1)))) (b2:=  (EQ_M (m x3) (grn 2))) .
unfold mx3rn1.
simpl.
repeat rewrite EQ_BRmsg_msg' with (m1 := (m x3)) (m2:= (grn 2)) (m:= (m x3))   (m3:= (exp (G 0) (m x3) (r 1)))  (b:=   (((((((EQ_M (reveal x4) (i 1)) &
                                 (EQ_M (to x3) (i 1))) &
                                (EQ_M (to x2) (i 2))) &
                               (EQ_M (to x1) (i 1))) &
                              (notb (EQ_M (act x3) new))) &
                             (EQ_M (act x1) new)) &
                            (EQ_M (m x2) (grn 1)))).
simpl.

rewrite commexp with (G:=  (pi1 (ggen (N 0)))) (g:=  (pi2 (ggen (N 0)))) (x:= (r 1)) (y:= (r 2)).
reflexivity.

Qed.


Require Import TestCommon.
Require Import Regularity.

Open Scope L2GMu.
Definition id := Λ => (λ (##0) => (#0)).
Definition id_typ := ∀ (##0 ==> ##0).

Ltac simpl_op := cbn; try case_if; auto.
(* Ltac solve_simple_type := repeat ((* let L := gather_vars in try apply typing_abs with L; *) intros; econstructor; eauto; cbn; try case_if; eauto). *)
Ltac crush_simple_type := repeat (cbv; (try case_if); econstructor; eauto).

Lemma well_typed_id : {empty, emptyΔ, empty} ⊢(Treg) id ∈ id_typ.
  cbv; autotyper1.
Qed.

Lemma well_formed_id :
  term id
  /\ type id_typ
  /\ wft empty emptyΔ id_typ.
  destruct* (typing_regular well_typed_id).
Qed.

Definition id_app := (id <|| typ_unit <| trm_unit).
Lemma id_app_types : {empty, emptyΔ, empty} ⊢(Treg) id_app ∈ typ_unit.
Proof.
  cbv.
  autotyper1.
  instantiate (1 := (##0 ==> ##0)).
  auto.
  autotyper1.
  auto.
Qed.

Ltac crush_eval := repeat (try (apply eval_finish; eauto); econstructor; simpl_op).

Lemma id_app_evals : evals id_app trm_unit.
Proof.
  crush_eval.
  Unshelve. fs. fs. fs. fs.
Qed.

Require Import Preservation.
Lemma preservation_evals : forall Σ e T TT e',
    {Σ, emptyΔ, empty} ⊢(TT) e ∈ T ->
    evals e e' ->
    {Σ, emptyΔ, empty} ⊢(Tgen) e' ∈ T.
Proof.
  introv Typ Ev.
  eapply Tgen_from_any in Typ.
  induction Ev.
  - apply* IHEv.
    lets HP: preservation_thm.
    unfold preservation in HP.
    apply* HP.
  - auto.
Qed.

Eval cbn in (preservation_evals _ _ _ _ _ id_app_types id_app_evals).

Definition let_id_app := trm_let (id) (#0 <|| typ_unit <| trm_unit).
Lemma let_id_app_types : {empty, emptyΔ, empty} ⊢(Treg) let_id_app ∈ typ_unit.
Proof.
  cbv.
  autotyper1.
  4: {
    instantiate (1 := (##0 ==> ##0)).
    cbn. autotyper1.
  }
  autotyper1.
  autotyper1.
  autotyper1.
  auto.
Qed.

Lemma let_id_app_evals : evals let_id_app trm_unit.
Proof.
  crush_eval.
  Unshelve.
  fs. fs. fs. fs. fs. fs. fs. fs. fs. fs. fs.
Qed.

Definition loop := fixs (typ_unit ==> typ_unit) => λ typ_unit => (#1 <| #0).

Lemma loop_type : {empty, emptyΔ, empty} ⊢(Treg) loop ∈ (typ_unit ==> typ_unit).
Proof.
  cbv.
  autotyper1.
Qed.

Definition divergent := loop <| trm_unit.

Lemma divergent_type : {empty, emptyΔ, empty} ⊢(Treg) divergent ∈ typ_unit.
Proof.
  cbv. autotyper1.
Qed.

Compute divergent_type.

Lemma divergent_diverges : evals divergent divergent.
Proof.
  cbv.
  econstructor.
  - crush_eval.
  - unfold open_ee. cbn; repeat case_if.
    econstructor.
    + crush_eval.
    + repeat case_if.
      apply eval_finish.

      Unshelve.
      fs. fs. fs. fs. fs. fs. fs.
Qed.