Require Import List.
Require Import ZArith.
Require Import Lia.
Require Import Init.Nat.
Require Import Logic.Eqdep.
Require Import Logic.Eqdep_dec.
Require Import Arith.PeanoNat.
Require Import Bool.Bool.
Require Import Util.
Require Import Group.
Require Import AsynchronousGames.
Require Import Lifting.

Inductive leq_sum (P Q : PartialOrder) :
{i : I P + I Q & (sum unit (match i with
                            | inl i => N P i
                            | inr j => N Q j
                            end))} ->
{i : I P + I Q & (sum unit (match i with
                            | inl i => N P i
                            | inr j => N Q j
                            end))} ->
Prop :=
| leq_sum_left : forall i m m' a b,
leq P (existT _ i m) (existT _ i m') ->
a = (existT _ (inl i) m) ->
b = (existT _ (inl i) m') ->
leq_sum P Q a b
| leq_sum_right : forall i m m' a b,
leq Q (existT _ i m) (existT _ i m') ->
a = (existT _ (inr i) m) ->
b = (existT _ (inr i) m') ->
leq_sum P Q a b.

Definition partial_order_sum (P Q : PartialOrder) : PartialOrder :=
        {|
            I := (I P) + (I Q);
            N i := match i with
                      | inl i => N P i
                      | inr j => N Q j
                   end;
            leq := leq_sum P Q;
         |}.

Inductive incompatible_sum (E F : EventStructure) :
(M (partial_order_sum (P E) (P F))) ->
(M (partial_order_sum (P E) (P F))) ->
Prop :=
| incomp_sum_least : forall i i' m m',
(i <> i') ->
incompatible_sum E F (existT _ i m) (existT _ i' m')
| incomp_sum_left : forall i m m' a b,
incompatible E (existT _ i m) (existT _ i m') ->
a = (existT _ (inl i) m) ->
b = (existT _ (inl i) m') ->
incompatible_sum E F a b
| incomp_sum_right : forall i m m' a b,
incompatible F (existT _ i m) (existT _ i m') ->
a = (existT _ (inr i) m) ->
b = (existT _ (inr i) m') ->
incompatible_sum E F a b.

Definition event_structure_sum (E F : EventStructure) : EventStructure :=
        {|
            P := partial_order_sum (P E) (P F);
            incompatible := incompatible_sum E F;
            ideal m := match m with
                      | existT _ (inl i) m =>
                      map (fun x => match x with
                                    | existT _ i (inl tt) => existT _ (inl i) (inl tt)
                                    | existT _ i (inr m) => existT _ (inl i) (inr m)
                      end) (ideal E (existT _ i m))
                      | existT _ (inr i) m =>
                      map (fun x => match x with
                                    | existT _ i (inl tt) => existT _ (inr i) (inl tt)
                                    | existT _ i (inr m) => existT _ (inr i) (inr m)
                      end) (ideal F (existT _ i m))
                      end;
         |}.

Fixpoint cast_sum_to_left E F (l : Position (event_structure_sum E F))
: Position E :=
match l with
| nil => nil
| (existT _ (inl i) m) :: xs
=> (existT _ i m) :: (cast_sum_to_left E F xs)
| (existT _ (inr i) m) :: xs => cast_sum_to_left E F xs
end.

Fixpoint cast_sum_to_right E F (l : Position (event_structure_sum E F))
: Position F :=
match l with
| nil => nil
| (existT _ (inr i) m) :: xs
=> (existT _ i m) :: (cast_sum_to_right E F xs)
| (existT _ (inl i) m) :: xs => cast_sum_to_right E F xs
end.

Definition inl_move_is_projection (A B : AsynchronousArena)
(m : M (P (event_structure_sum (E A) (E B))))
(m' : M (P (E A))) : Prop :=
exists i k, m = existT _ (inl i) k /\ m' = existT _ i k.

Definition inr_move_is_projection (A B : AsynchronousArena)
(m : M (P (event_structure_sum (E A) (E B))))
(m' : M (P (E B))) : Prop :=
exists i k, m = existT _ (inr i) k /\ m' = existT _ i k.

Definition infinite_payoff_right_finite (A B : AsynchronousArena)
(f : nat -> M (P (event_structure_sum (E A) (E B))) )
(inf : bool) :=
(exists g, (forall n, inl_move_is_projection A B (f n) (g n)) /\
(infinite_payoff A g inf))
\/
(exists g, (forall n, inr_move_is_projection A B (f n) (g n)) /\
(infinite_payoff B g inf)).

Definition asynchronous_arena_sum (A B : AsynchronousArena)
: AsynchronousArena :=
         {|
            E := event_structure_sum (E A) (E B);
            polarity m := match m with
                          | existT _ (inl i) m => (polarity A) (existT _ i m)
                          | existT _ (inr i) m => (polarity B) (existT _ i m)
                          end;
            finite_payoff_position l :=
                let left := (cast_sum_to_left (E A) (E B) l) in
                if Nat.eqb (length l) (length left) then
                finite_payoff_position A left else
                finite_payoff_position B (cast_sum_to_right (E A) (E B) l);
            finite_payoff_walk w :=
              let fp := cast_sum_to_left _ _ (fst (fst w)) in
              let fm := cast_sum_to_left _ _ (snd (fst w)) in
              let sp := cast_sum_to_left _ _ (fst (snd w)) in
              let sm := cast_sum_to_left _ _ (snd (snd w)) in
              if Nat.eqb (length fm) (length (snd (fst w))) &&
                 Nat.eqb (length sm) (length (snd (snd w))) then
              finite_payoff_walk A ((fp, fm), (sp, sm)) else
              let fp := cast_sum_to_right _ _ (fst (fst w)) in
              let fm := cast_sum_to_right _ _ (snd (fst w)) in
              let sp := cast_sum_to_right _ _ (fst (snd w)) in
              let sm := cast_sum_to_right _ _ (snd (snd w)) in
              finite_payoff_walk B ((fp, fm), (sp, sm));
             infinite_payoff f inf := infinite_payoff_right_finite A B f inf;
             positive_or_negative := true
         |}.

Definition asynchronous_game_sum_positive (G H: AsynchronousGame) : AsynchronousGame :=
        {|
             A := asynchronous_arena_sum (A G) (A H);
             X := product_group (X G) (X H);
             Y := product_group (Y G) (Y H);
             action g m h := match m with
                                | existT _ (inl i) m =>
                                  (match action G (fst g) (existT _ i m) (fst h) with
                                    | existT _ i m => existT _ (inl i) m
                                  end)
                                | existT _ (inr i) m =>
                                  (match action H (snd g) (existT _ i m) (snd h) with
                                    | existT _ i m => existT _ (inr i) m
                                  end)
                              end;
        |}.

Definition asynchronous_game_sum (G H: AsynchronousGame) : AsynchronousGame :=
match positive_or_negative (A G), positive_or_negative (A H) with
| true, true => asynchronous_game_sum_positive G H
| true, false => asynchronous_game_sum_positive G (lifting H (1)%Z true)
| false, true => asynchronous_game_sum_positive (lifting G (1)%Z true) H
| false, false => asynchronous_game_sum_positive (lifting G (1)%Z true) (lifting H (1)%Z true)
end.

(*Proof.
- intros. destruct x. destruct x.
+ apply leq_sum_left with (i:=i) (m:=s) (m':=s).
++ apply reflexive.
++ auto.
++ auto.
+ apply leq_sum_right with (i:=i) (m:=s) (m':=s).
++ apply reflexive.
++ auto.
++ auto.
- intros. destruct x. destruct y. destruct x.
+ destruct x0.
++ destruct H. inversion H.
+++ subst. inversion H3. subst. apply inj_pairT2 in H3. subst.
inversion H2. subst. apply inj_pairT2 in H2. subst. inversion H0.
++++ subst. inversion H4. subst. apply inj_pairT2 in H4. subst.
inversion H3. subst. apply inj_pairT2 in H3. subst.
assert ((existT (fun i : I P => (unit + N P i)%type) i m'0)
= (existT (fun i : I P => (unit + N P i)%type) i m0)).
{apply anti_symmetric. auto. } apply inj_pairT2 in H3. subst. auto.
++++ subst. inversion H4.
+++ subst. inversion H3.
++ destruct H. inversion H.
+++ subst. inversion H3.
+++ subst. inversion H2.
+ destruct H. destruct x0.
++ inversion H.
+++ subst. inversion H2.
+++ subst. inversion H3.
++ inversion H.
+++ subst. inversion H3.
+++ subst. inversion H3. subst. apply inj_pairT2 in H3. subst.
inversion H2. subst. apply inj_pairT2 in H2. subst. inversion H0.
++++ subst. inversion H4.
++++ subst. inversion H4. subst. apply inj_pairT2 in H4. subst.
inversion H3. subst. apply inj_pairT2 in H3. subst.
assert ((existT (fun i : I Q => (unit + N Q i)%type) i m0)
        = (existT (fun i : I Q => (unit + N Q i)%type) i m'0)).
{apply anti_symmetric. auto. }
apply inj_pairT2 in H3. subst. auto.
- intros. destruct x. destruct y. destruct z. destruct H. inversion H.
+ subst. inversion H3. subst. apply inj_pairT2 in H3. subst.
inversion H2. subst. apply inj_pairT2 in H2. subst. inversion H0.
++ subst. inversion H4. subst. apply inj_pairT2 in H4. subst.
inversion H3. subst. apply inj_pairT2 in H3. subst.
assert (leq P (existT (fun i : I P => (unit + N P i)%type) i0 m)
       (existT (fun i : I P => (unit + N P i)%type) i0 m'0)).
{apply transitive with (y:=(existT (fun i : I P => (unit + N P i)%type) i0 m0)). auto. }
apply leq_sum_left with (i:=i0) (m:=m) (m':=m'0). auto. auto. auto.
++ subst. inversion H3.
+ subst. inversion H3. subst. apply inj_pairT2 in H3. subst.
inversion H2. subst. apply inj_pairT2 in H2. subst. inversion H0.
++ subst. inversion H3.
++ subst. inversion H3. subst. apply inj_pairT2 in H3. subst. inversion H4. subst.
apply inj_pairT2 in H4. subst.
assert ( leq Q (existT (fun i : I Q => (unit + N Q i)%type) i0 m)
       (existT (fun i : I Q => (unit + N Q i)%type) i0 m'0)).
{apply transitive with (y:=(existT (fun i : I Q => (unit + N Q i)%type) i0 m0)). auto. }
apply leq_sum_right with (i:=i0) (m:=m) (m':=m'0). auto. auto. auto.
- intros. unfold iff. split.
+ intros. inversion H.
++ subst. inversion H1. inversion H2. auto.
++ subst. inversion H1. inversion H2. auto.
+ intros. subst. destruct i'.
++ apply leq_sum_left with (i:=i) (m:=inl tt) (m':=m).
+++ apply unit_is_least. auto.
+++ auto.
+++ auto.
++ apply leq_sum_right with (i:=i) (m:=inl tt) (m':=m).
+++ apply unit_is_least. auto.
+++ auto.
+++ auto.
- intros. inversion H.
+ subst. inversion H1. inversion H2. subst. auto.
+ subst. inversion H1. inversion H2. subst. auto.
- intros. destruct i.
+ destruct j.
++ destruct (index_equality P i i0).
+++ subst. left. auto.
+++ right. unfold not. intros. inversion H. contradiction n.
++ right. unfold not. intros. inversion H.
+ destruct j.
++ right. unfold not. intros. inversion H.
++ destruct (index_equality Q i i0).
+++ subst. left. auto.
+++ right. unfold not. intros. inversion H. contradiction n.
Defined.

Proof.
- intros. inversion H.
+ subst. apply incomp_sum_least. auto.
+ subst. inversion H.
++ subst. contradiction H2. auto.
++ subst. inversion H2. subst. apply inj_pairT2 in H2. subst.
apply inj_pairT2 in H3. subst.
apply incomp_sum_left with (m:=m'0) (m':=m0).
+++ apply symmetric. auto.
+++ auto.
+++ auto.
++ subst. inversion H3.
+ subst. apply incomp_sum_right with (m:=m') (m':=m).
++ apply symmetric. auto.
++ auto.
++ auto.
- unfold not. intros. inversion H.
+ subst. contradiction H2. auto.
+ subst. apply inj_pairT2 in H2. subst.
assert (~ incompatible E
       (existT (fun i : I (P E) => (unit + N (P E) i)%type) i
          m')
       (existT (fun i : I (P E) => (unit + N (P E) i)%type) i
          m')).
{apply irreflexive. } contradiction H1.
+ subst. apply inj_pairT2 in H2. subst.
assert (~ incompatible F
       (existT (fun i : I (P F) => (unit + N (P F) i)%type) i
          m')
       (existT (fun i : I (P F) => (unit + N (P F) i)%type) i
          m')).
{apply irreflexive. } contradiction H1.
- intros. simpl. flatten_all.
+ subst. unfold iff. split.
++ intros. inversion H.
+++ subst. destruct m.
++++ destruct m'.
+++++ apply in_map_iff.
refine (ex_intro _ (existT _ i0 (inl tt)) _). split.
++++++ destruct u. auto.
++++++ inversion H2. subst. apply inj_pairT2 in H2. subst.
apply ideal_finite. destruct u. destruct u0. auto.
+++++ inversion H2. subst. apply inj_pairT2 in H2. subst.
apply in_map_iff.
refine (ex_intro _ (existT _ i0 (inl tt)) _). split.
++++++ destruct u. auto.
++++++ apply ideal_finite. destruct u. auto.
++++ inversion H2. subst. apply inj_pairT2 in H2. subst.
apply in_map_iff.
refine (ex_intro _ (existT _ i0 (inr n)) _). split.
+++++ auto.
+++++ apply ideal_finite. auto.
+++ subst. inversion H2.
++ intros. apply in_map_iff in H. destruct H. destruct H.
subst. destruct x. apply ideal_finite in H0.
assert (H1 := H0). apply leq_same_component in H0. subst. destruct s0.
+++ destruct u. apply leq_sum_left with (i:=i) (m:=inl tt) (m':=s).
++++ apply unit_is_least. auto.
++++ auto.
++++ auto.
+++ apply leq_sum_left with (i:=i) (m:=inr n) (m':=s).
++++ auto.
++++ auto.
++++ auto.
+ subst. unfold iff. split.
++ intros. inversion H.
+++ subst. inversion H2.
+++ subst. inversion H2. subst. apply inj_pairT2 in H2. subst.
apply in_map_iff.
refine (ex_intro _ (existT _ i0 m) _). split.
++++ simpl. destruct m.
+++++ destruct u. auto.
+++++ auto.
++++ apply ideal_finite. auto.
++ intros. apply in_map_iff in H. destruct H. destruct H. subst.
destruct x. apply ideal_finite in H0. assert (H1 := H0).
apply leq_same_component in H0. subst. destruct s0.
+++ destruct u. apply leq_sum_right with (i:=i) (m:=inl tt) (m':=s); auto.
+++ apply leq_sum_right with (i:=i) (m:=inr n) (m':=s); auto.
- intros. destruct H. inversion H.
+ subst. inversion H0; subst; inversion H3; subst; apply incomp_sum_least; auto.
+ subst. inversion H0.
++ subst. inversion H3. subst. apply inj_pairT2 in H3. subst.
apply incomp_sum_left with (i:=i0) (m:=m) (m':=m'0).
apply incompatible_closed with (y:=existT (fun i : I (P E) => (unit + N (P E) i)%type) i0 m0).
auto. auto. auto.
++ subst. apply incomp_sum_least. easy.
+ subst. inversion H0.
++ subst. apply incomp_sum_least. easy.
++ subst. inversion H3. subst. apply inj_pairT2 in H3. subst.
apply incomp_sum_right with (i:=i0) (m:=m) (m':=m'0).
apply incompatible_closed with (existT (fun i : I (P F) => (unit + N (P F) i)%type) i0 m0).
auto. auto. auto.
Defined.

Fact initial_in_sum_is_initial :
forall E F m, initial_move (P (event_structure_sum E F)) m <->
((exists i n, m = existT _ (inl i) n /\ initial_move (P E) (existT _ i n))
\/
(exists i n, m = existT _ (inr i) n /\ initial_move (P F) (existT _ i n))).
Proof. unfold iff. split.
+ intros. rewrite initial_is_unit in H. destruct H. subst. destruct x.
++ left. refine (ex_intro _ i _). refine (ex_intro _ (inl tt) _). split.
+++ auto.
+++ apply initial_is_unit. refine (ex_intro _ i _). auto.
++ right. refine (ex_intro _ i _). refine (ex_intro _ (inl tt) _). split.
+++ auto.
+++ apply initial_is_unit. refine (ex_intro _ i _). auto.
+ intros. destruct H.
++ destruct H. destruct H. destruct H. subst. rewrite initial_is_unit.
rewrite initial_is_unit in H0. destruct H0. inversion H. subst. apply inj_pairT2 in H.
subst. refine (ex_intro _ (inl x1) _). auto.
++ destruct H. destruct H. destruct H. subst. rewrite initial_is_unit.
rewrite initial_is_unit in H0. destruct H0. inversion H. subst. apply inj_pairT2 in H.
subst. refine (ex_intro _ (inr x1) _). auto.
Qed.

Fact second_in_sum_is_second :
forall E F m, second_move (P (event_structure_sum E F)) m <->
((exists i n, m = existT _ (inl i) n /\ second_move (P E) (existT _ i n))
\/
(exists i n, m = existT _ (inr i) n /\ second_move (P F) (existT _ i n))).
Proof. unfold iff. split.
+ intros. unfold second_move in H. destruct H. rewrite initial_is_unit in H.
destruct m. destruct x.
++ left. refine (ex_intro _ i _). refine (ex_intro _ s _). split.
+++ auto.
+++  unfold second_move. split.
++++ rewrite initial_is_unit. unfold not. intros. destruct H1. inversion H1.
subst. apply inj_pairT2 in H1. subst. contradiction H. refine (ex_intro _ (inl x) _).
auto.
++++ intros. destruct n. destruct H1. assert (H3 := H1).
apply leq_same_component in H1. subst.
assert (initial_move (P (event_structure_sum E F))
(existT _ (inl i) s0)).
{apply H0. split.
+ simpl. apply leq_sum_left with (i:=i) (m:=s0) (m':=s). auto. auto. auto.
+ unfold not. intros. apply inj_pairT2 in H1. subst. contradiction H2. auto. }
rewrite initial_is_unit. rewrite initial_is_unit in H1. destruct H1. inversion H1.
subst. apply inj_pairT2 in H1. subst. refine (ex_intro _ i _). auto.
++ right. refine (ex_intro _ i _). refine (ex_intro _ s _). split.
+++ auto.
+++  unfold second_move. split.
++++ rewrite initial_is_unit. unfold not. intros. destruct H1. inversion H1.
subst. apply inj_pairT2 in H1. subst. contradiction H. refine (ex_intro _ (inr x) _).
auto.
++++ intros. destruct n. destruct H1. assert (H3 := H1).
apply leq_same_component in H1. subst.
assert (initial_move (P (event_structure_sum E F))
(existT _ (inr i) s0)).
{apply H0. split.
+ simpl. apply leq_sum_right with (i:=i) (m:=s0) (m':=s). auto. auto. auto.
+ unfold not. intros. apply inj_pairT2 in H1. subst. contradiction H2. auto. }
rewrite initial_is_unit. rewrite initial_is_unit in H1. destruct H1. inversion H1.
subst. apply inj_pairT2 in H1. subst. refine (ex_intro _ i _). auto.
+ intros. destruct H.
++ destruct H. destruct H. destruct H. subst. unfold second_move in H0. unfold second_move.
destruct H0. rewrite initial_is_unit in H. split.
+++ rewrite initial_is_unit. unfold not. intros. contradiction H. destruct H1.
inversion H1. subst. apply inj_pairT2 in H1. subst. refine (ex_intro _ x _). auto.
+++ intros. destruct n. destruct H1. assert (H3 := H1).
apply leq_same_component in H1. subst. inversion H3.
++++ subst. inversion H5. subst. apply inj_pairT2 in H5. subst. apply inj_pairT2 in H4. subst.
assert (initial_move (P E)
(existT (fun i : I (P E) => (unit + N (P E) i)%type) i m)).
{apply H0. split.
+ auto.
+ unfold not. intros. apply inj_pairT2 in H4. subst. contradiction H2. auto. }
rewrite initial_is_unit in H4. rewrite initial_is_unit. destruct H4. inversion H4. subst.
apply inj_pairT2 in H7. subst. refine (ex_intro _ (inl x) _). auto.
++++ subst. inversion H5.
++ destruct H. destruct H. destruct H. subst. unfold second_move in H0.
destruct H0. unfold second_move. split.
+++ rewrite initial_is_unit in H. rewrite initial_is_unit. unfold not. intros.
contradiction H. destruct H1. inversion H1. subst. apply inj_pairT2 in H1. subst.
refine (ex_intro _ x _). auto.
+++ intros. destruct n. destruct H1. inversion H1.
++++ subst. inversion H5.
++++ subst. inversion H5. subst. apply inj_pairT2 in H5. subst. destruct x1.
+++++ inversion H4.
+++++
assert (initial_move (P F)
(existT (fun i : I (P F) => (unit + N (P F) i)%type) i0 s)).
{apply H0. inversion H4. subst. apply inj_pairT2 in H4. subst. split.
+ auto.
+ unfold not. intros. apply inj_pairT2 in H4. subst. contradiction H2. auto. }
rewrite initial_is_unit. rewrite initial_is_unit in H5. destruct H5.
inversion H5. subst. apply inj_pairT2 in H5. subst. refine (ex_intro _ (inr x) _).
auto.
Defined.

Proof.
- left. auto.
- intros. flatten_all.
+ subst. split.
++ intros. simpl. auto.
++ intros. simpl. apply initial_in_sum_is_initial in H. destruct H.
+++ destruct H. destruct H. destruct H. inversion H. subst. apply inj_pairT2 in H.
subst. apply polarity_first in H1. apply H1 in H0. auto.
+++ destruct H. destruct H. destruct H. inversion H.
+ subst. split.
++ intros. subst. simpl. auto.
++ intros. simpl. apply initial_in_sum_is_initial in H. destruct H.
+++ destruct H. destruct H. destruct H. inversion H.
+++ destruct H. destruct H. destruct H. inversion H. subst. apply inj_pairT2 in H.
subst. apply polarity_first in H1. apply H1 in H0. lia.
- intros. flatten_all.
+ subst. split.
++ intros. simpl. apply second_in_sum_is_second in H. destruct H.
+++ destruct H. destruct H. destruct H. inversion H. subst. apply inj_pairT2 in H. subst.
apply polarity_second in H1. apply H1 in H0. auto.
+++ destruct H. destruct H. destruct H. inversion H.
++ intros. simpl. auto.
+ intros. simpl. split.
++ intros. apply second_in_sum_is_second in H. destruct H.
+++ destruct H. destruct H. destruct H. inversion H.
+++ destruct H. destruct H. destruct H. inversion H. subst. apply inj_pairT2 in H. subst.
apply polarity_second in H1. apply H1 in H0. auto. lia.
++ intros. auto.
- intros. destruct H. destruct w. destruct p. destruct p0. simpl in *. subst. simpl.
apply initial_null. auto.
Defined.

Proof.
- split.
+ intros. flatten_all. subst.
++
assert (left_action _ _ (actl G)).
{apply restriction_to_left_is_action. }
destruct H0. unfold actl in *. unfold left_action. simpl in e1. rewrite H0 in e1. inversion e1. subst. apply inj_pairT2 in e1. subst. auto.
++
assert (left_action _ _ (actl H)).
{apply restriction_to_left_is_action. }
destruct H0. unfold actl in *. unfold left_action. simpl in e1.
rewrite H0 in e1. inversion e1. subst. apply inj_pairT2 in e1. subst. auto.
+ intros. destruct x. destruct x.
++ flatten_all.
+++ subst. simpl fst in *.
assert (left_action _ _ (actl G)).
{apply restriction_to_left_is_action. }
destruct H0. unfold actl in *. unfold left_action.
rewrite <- H1 in e3. inversion e. subst. apply inj_pairT2 in e. subst. rewrite e0 in e3.
rewrite e2 in e3. inversion e3. subst. apply inj_pairT2 in e3. subst. auto.
+++ inversion e.
++ flatten_all.
+++ inversion e.
+++ subst. simpl snd in *.
assert (left_action _ _ (actl H)).
{apply restriction_to_left_is_action. }
destruct H0. unfold actl in *. unfold left_action.
rewrite <- H1 in e3. inversion e. subst. apply inj_pairT2 in e. subst. rewrite e0 in e3.
rewrite e2 in e3. inversion e3. subst. apply inj_pairT2 in e3. subst. auto.
- split.
+ intros. flatten_all. subst.
++
assert (right_action _ _ (actr G)).
{apply restriction_to_right_is_action. }
destruct H0. unfold actr in *. unfold right_action. simpl in e1. rewrite H0 in e1. inversion e1. subst. apply inj_pairT2 in e1. subst. auto.
++
assert (right_action _ _ (actr H)).
{apply restriction_to_right_is_action. }
destruct H0. unfold actr in *. unfold right_action. simpl in e1.
rewrite H0 in e1. inversion e1. subst. apply inj_pairT2 in e1. subst. auto.
+ intros. destruct x. destruct x.
++ flatten_all.
+++ subst. simpl fst in *.
assert (right_action _ _ (actr G)).
{apply restriction_to_right_is_action. }
destruct H0. unfold actr in *. unfold right_action.
rewrite <- H1 in e3. inversion e. subst. apply inj_pairT2 in e. subst. rewrite e0 in e3.
rewrite e2 in e3. inversion e3. subst. apply inj_pairT2 in e3. subst. auto.
+++ inversion e.
++ flatten_all.
+++ inversion e.
+++ subst. simpl snd in *.
assert (right_action _ _ (actr H)).
{apply restriction_to_right_is_action. }
destruct H0. unfold actr in *. unfold right_action.
rewrite <- H1 in e3. inversion e. subst. apply inj_pairT2 in e. subst. rewrite e0 in e3.
rewrite e2 in e3. inversion e3. subst. apply inj_pairT2 in e3. subst. auto.
- intros. destruct m. destruct n. inversion H0.
+ subst. inversion H3. subst. apply inj_pairT2 in H3. apply inj_pairT2 in H6. subst. inversion H2.
subst. apply inj_pairT2 in H2. subst. flatten_all.
assert (leq _
(action G (fst g)
       (existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) i m)
       (fst h))
(action G (fst g)
       (existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) i m')
       (fst h))).
{apply coherence_1. auto. }
rewrite e0 in H2. rewrite e in H2. assert (H3:=H2). apply leq_same_component in H3. subst.
simpl. apply leq_sum_left with (i:=x0) (m:=s) (m':=s0). auto. auto. auto.
+ subst. inversion H3. subst. apply inj_pairT2 in H3. apply inj_pairT2 in H6. subst. inversion H2.
subst. apply inj_pairT2 in H2. subst. flatten_all.
assert (leq _
(action H (snd g)
      (existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type)
         i m) (snd h))
(action H (snd g)
      (existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type)
         i m') (snd h))).
{apply coherence_1. auto. }
rewrite e0 in H2. rewrite e in H2. assert (H3:=H2). apply leq_same_component in H3. subst.
simpl. apply leq_sum_right with (i:=x0) (m:=s) (m':=s0). auto. auto. auto.
- intros. destruct m. destruct x.
+ flatten_all. simpl. rewrite <- e. apply coherence_2.
+ flatten_all. simpl. rewrite <- e. apply coherence_2.
- intros. destruct g. destruct h. destruct i; simpl fst; simpl snd.
+ destruct (action G g
       (existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) i
          (inl tt)) g1) eqn:eqn1. refine (ex_intro _ (inl x) _). flatten_all.
assert (existT
         (fun i : I (P (E (A G))) =>
          (unit + N (P (E (A G))) i)%type) x s =
existT
      (fun i : I (P (E (A G))) =>
       (unit + N (P (E (A G))) i)%type) x0 s0).
{rewrite <- eqn1. rewrite <- e. auto. } inversion H0. subst. apply inj_pairT2 in H3. subst.
assert (exists k,
 action G g
      (existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) i (inl tt)) g1 =
existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) k (inl tt)).
{apply action_preserves_initial. }
destruct H1.
assert (existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) x0 s0 =
existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) x (inl tt)).
{rewrite <- e. rewrite <- H1. auto. } inversion H2. subst. apply inj_pairT2 in H2.
subst. auto.
+ flatten_all.
assert (exists k,
action H g0
      (existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) i (inl tt)) g2 =
existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) k (inl tt)).
{apply action_preserves_initial. }
destruct H0.
assert (existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) x s =
     existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) x0 (inl tt)).
{rewrite <- e. rewrite <- H0. auto. }
inversion H1. subst. apply inj_pairT2 in H1. subst. refine (ex_intro _ (inr x0) _). auto.
- intros. destruct i.
+ flatten_all. refine (ex_intro _ (inl x) _).
assert (exists k k1,
action G (fst g)
      (existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) i (inr m))
      (fst h) =
existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) k (inr k1)).
{apply action_preserves_non_initial. }
destruct H0. destruct H0. rewrite e in H0. inversion H0. subst. apply inj_pairT2 in H3. subst.
refine (ex_intro _ x1 _). auto.
+ flatten_all. refine (ex_intro _ (inr x) _).
assert (exists k k1,
action H (snd g)
      (existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) i (inr m))
      (snd h) =
existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) k (inr k1)).
{apply action_preserves_non_initial. }
destruct H0. destruct H0. rewrite e in H0. inversion H0. subst. apply inj_pairT2 in H3. subst.
refine (ex_intro _ x1 _). auto.
Defined.
*)


From Coq.ssr Require Export ssreflect.
From stdpp Require Import base gmap.

(* This model follows the transactional commit TLA+ specification:

     https://github.com/tlaplus/Examples/blob/master/specifications/transaction_commit/TCommit.tla

   originally developed as part of the "Consensus on Transaction Commit" paper

     https://www.microsoft.com/en-us/research/uploads/prod/2004/01/twophase-revised.pdf
*)
Section tla_style.
  Context {K : Type} `{Countable K}.
  Context (RMs : gset K).

  Inductive rm_state :=
  | WORKING
  | PREPARED
  | COMMITTED
  | ABORTED.

  Global Instance : EqDecision rm_state.
  Proof. solve_decision. Qed.
  Global Instance : Countable rm_state.
  Proof.
    refine
      {| encode st :=
           match st with
           | WORKING => 1 | PREPARED => 2 | COMMITTED => 3 | ABORTED => 4
           end%positive;
         decode p :=
           match p with
           | 1 => Some WORKING | 2 => Some PREPARED | 3 => Some COMMITTED
           | 4 => Some ABORTED | _ => None
           end%positive |}; by intros [].
  Qed.

  Definition TCState := gmap K rm_state.

  Instance : Countable TCState.
  Proof. apply _. Qed.

  Definition TCInit := gset_to_gmap WORKING RMs.

  Definition canCommit (rmState : TCState) :=
    ∀ rm, rm ∈ RMs → rmState !! rm = Some PREPARED ∨ rmState !! rm = Some COMMITTED.
  Definition notCommitted (rmState : TCState) :=
    ∀ rm, rm ∈ RMs → ¬ (rmState !! rm = Some COMMITTED).

  Inductive TCNext : TCState → TCState → Prop :=
  | tc_prepare rm rmState :
      rmState !! rm = Some WORKING →
      TCNext rmState (<[ rm := PREPARED ]> rmState)
  | tc_decide_commit rm rmState :
      rmState !! rm = Some PREPARED →
      canCommit rmState →
      TCNext rmState (<[ rm := COMMITTED ]> rmState)
  | tc_decide_abort rm rmState :
      (rmState !! rm = Some WORKING ∨ rmState !! rm = Some PREPARED) →
      notCommitted rmState →
      TCNext rmState (<[ rm := ABORTED ]> rmState).

  Theorem TCConsistent rmState rm1 rm2 st1 st2 :
    rm1 ∈ RMs ∧ rm2 ∈ RMs →
    rtc TCNext TCInit rmState →
    rmState !! rm1 = Some st1 ∧ rmState !! rm2 = Some st2 →
    ¬ (st1 = ABORTED ∧ st2 = COMMITTED).
  Proof.
    intros [Helem1 Helem2].
    apply (rtc_ind_r (λ r, r !! _ = _ ∧ r !! _ = _ → ¬ _)).
    { rewrite /TCInit !lookup_gset_to_gmap_Some.
      intros [[] []] []; subst. discriminate. }
    intros r' r'' Hrtc Hnext Hr'.
    inversion Hnext as [|??? HcanC | ??? HnotC]; simplify_eq.
    - destruct (decide (rm = rm1)); simplify_eq.
      { rewrite !lookup_insert. intros [??] [??]; simplify_eq. }
      rewrite lookup_insert_ne //.
      destruct (decide (rm = rm2)); simplify_eq.
      { rewrite !lookup_insert. intros [??] [??]; simplify_eq. }
      rewrite lookup_insert_ne //.
    - destruct (decide (rm = rm1)); simplify_eq.
      { rewrite !lookup_insert. intros [??] [??]; simplify_eq. }
      rewrite lookup_insert_ne //.
      intros [??] [??]; simplify_eq.
      destruct (HcanC rm1) as [|]; [done|simplify_map_eq..].
    - destruct (decide (rm = rm1)); simplify_eq.
      + destruct (decide (rm1 = rm2)); simplify_eq.
        { rewrite !lookup_insert. intros [??] [??]; simplify_eq. }
        rewrite lookup_insert lookup_insert_ne //.
        intros [??] [??]; simplify_eq. by eapply HnotC.
      + rewrite lookup_insert_ne //.
        destruct (decide (rm = rm2)); simplify_eq.
        { rewrite !lookup_insert. intros [??] [??]; simplify_eq. }
        rewrite lookup_insert_ne //.
  Qed.

End tla_style.


Require Export equiv.
Require Import reduction_lemmas.
Require Import Equivalence.

Lemma equiv_refl (g: env): Reflexive (Equiv g).
Proof.
unfold Reflexive. intros. eapply aE_Reflex.
Qed.

Lemma equiv_sym (g: env): Symmetric (Equiv g).
Proof.
  unfold Symmetric. intros. eapply aE_Symm. auto.
Qed.

Lemma equiv_trans (g: env): Transitive (Equiv g).
Proof.
  unfold Transitive. intros. eapply aE_Trans. apply H. auto.
Qed.

(* Lemma equiv_weakening (g: env) (x: name) (a: ctxmem) (e1 e2: exp):
  (Equiv g e1 e2) ->
  (Equiv (ctx_cons g x a) e1 e2).
Admitted. *)

Instance Equiv_equiv (g: env) : Equivalence (Equiv g).
Proof.
split. apply equiv_refl. apply equiv_sym. apply equiv_trans.
Qed.
Hint Rewrite Equiv_equiv.
Require Import String.

(*TODO: To use this, we need to declare some functions proper wrt to equiv.
Then we can do rewriting.
See page 17 of
https://www.labri.fr/perso/casteran/CoqArt/TypeClassesTut/typeclassestut.pdf *)

(* Require Import typing. *)


(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(** Properties, definitions, hints and tactics for monoids.
   In particular, [monoid_rewrite] does closed rewriting modulo
   associativity *)

Require Import Common.
Require Import Classes.
Require Import Graph.
Require Import BoolView.

Set Implicit Arguments.
Unset Strict Implicit.

Global Hint Extern 0 (equal _ _ _ _) => first [
    apply dot_assoc
  | apply dot_neutral_left
  | apply dot_neutral_right
]: algebra.
Global Hint Extern 2 (equal _ _ _ _) => first [
    apply dot_compat; instantiate
]: compat algebra.

(* Hint Resolve @dot_assoc @dot_neutral_left @dot_neutral_right: algebra. *)
(* Hint Resolve @dot_compat: compat algebra. *)
Hint Rewrite @dot_neutral_left @dot_neutral_right using ti_auto: simpl.

(** simple ad-hoc tactic for closed rewrites modulo associativity *)

Section monoid_rewrite_equal.
  Context `{M: Monoid}.

  Lemma add_continuation A B (r: X A B) (p: forall Q, X Q A -> X Q B) (P: Prop):
    ((forall Q (q: X Q A), p _ q == q*r) -> P) -> (forall Q (q: X Q A), p _ q == q*r) -> P.
  Proof. tauto. Qed.

  Lemma add_continuation_1 A0 A1 A2
    (l1: X A0 A1) (l2: X A1 A2)
    (r: X A0 A2):
    l1*l2 == r -> forall B (q: X B A0), q*l1*l2 == q*r.
  Proof. intros; rewrite <- H; auto with algebra. Qed.

  Lemma add_continuation_2 A0 A1 A2 A3
    (l1: X A0 A1) (l2: X A1 A2) (l3: X A2 A3)
    (r: X A0 A3):
    l1*l2*l3 == r -> forall B (q: X B A0), q*l1*l2*l3 == q*r.
  Proof. intros. rewrite <- H, 2dot_assoc. reflexivity. Qed.

  Lemma add_continuation_3 A0 A1 A2 A3 A4
    (l1: X A0 A1) (l2: X A1 A2) (l3: X A2 A3) (l4: X A3 A4)
    (r: X A0 A4):
    l1*l2*l3*l4 == r -> forall B (q: X B A0), q*l1*l2*l3*l4 == q*r.
  Proof. intros; rewrite <- H, 3dot_assoc. reflexivity. Qed.

  Lemma add_continuation_4 A0 A1 A2 A3 A4 A5
    (l1: X A0 A1) (l2: X A1 A2) (l3: X A2 A3) (l4: X A3 A4) (l5: X A4 A5)
    (r: X A0 A5):
    l1*l2*l3*l4*l5 == r -> forall B (q: X B A0), q*l1*l2*l3*l4*l5 == q*r.
  Proof. intros; rewrite <- H, 4dot_assoc. reflexivity. Qed.
End monoid_rewrite_equal.

Section monoid_rewrite_leq.
  Context `{M: IdemSemiRing}.

  (* This lemma cannot be in SemiRing only .. *)
  Instance dot_incr_temp A B C:
  Proper ((leq A B) ==> (leq B C) ==> (leq A C)) (dot A B C).
  Proof.
    unfold leq; intros x y E x' y' E'.
    rewrite <- E, <- E'.
    rewrite dot_distr_left, 2 dot_distr_right.
    rewrite <- (plus_assoc (x*x')) at 1.
    rewrite plus_assoc, plus_idem, plus_assoc.
    reflexivity.
  Qed.

  Lemma add_continuationl A B (r: X A B) (p: forall Q, X Q A -> X Q B) (P: Prop):
    ((forall Q (q: X Q A), p _ q <== q*r) -> P) -> (forall Q (q: X Q A), p _ q <== q*r) -> P.
  Proof. tauto. Qed.

  Lemma add_continuation_1l A0 A1 A2
    (l1: X A0 A1) (l2: X A1 A2)
    (r: X A0 A2):
    l1*l2 <== r -> forall B (q: X B A0), q*l1*l2 <== q*r.
  Proof. intros; rewrite <- H, dot_assoc. reflexivity. Qed.

  Lemma add_continuation_2l A0 A1 A2 A3
    (l1: X A0 A1) (l2: X A1 A2) (l3: X A2 A3)
    (r: X A0 A3):
    l1*l2*l3 <== r -> forall B (q: X B A0), q*l1*l2*l3 <== q*r.
  Proof. intros; rewrite <- H, 2dot_assoc. reflexivity. Qed.

  Lemma add_continuation_3l A0 A1 A2 A3 A4
    (l1: X A0 A1) (l2: X A1 A2) (l3: X A2 A3) (l4: X A3 A4)
    (r: X A0 A4):
    l1*l2*l3*l4 <== r -> forall B (q: X B A0), q*l1*l2*l3*l4 <== q*r.
  Proof. intros; rewrite <- H, 3dot_assoc. reflexivity. Qed.

  Lemma add_continuation_4l A0 A1 A2 A3 A4 A5
    (l1: X A0 A1) (l2: X A1 A2) (l3: X A2 A3) (l4: X A3 A4) (l5: X A4 A5)
    (r: X A0 A5):
    l1*l2*l3*l4*l5 <== r -> forall B (q: X B A0), q*l1*l2*l3*l4*l5 <== q*r.
  Proof. intros; rewrite <- H, 4dot_assoc. reflexivity. Qed.

  Lemma add_continuation_1r A0 A1 A2
    (l1: X A0 A1) (l2: X A1 A2)
    (r: X A0 A2):
    r <== l1*l2 -> forall B (q: X B A0), q*r <== q*l1*l2.
  Proof. intros; rewrite H, dot_assoc. reflexivity. Qed.

  Lemma add_continuation_2r A0 A1 A2 A3
    (l1: X A0 A1) (l2: X A1 A2) (l3: X A2 A3)
    (r: X A0 A3):
    r <== l1*l2*l3 -> forall B (q: X B A0), q*r <== q*l1*l2*l3.
  Proof. intros; rewrite H, 2dot_assoc. reflexivity. Qed.

  Lemma add_continuation_3r A0 A1 A2 A3 A4
    (l1: X A0 A1) (l2: X A1 A2) (l3: X A2 A3) (l4: X A3 A4)
    (r: X A0 A4):
    r <== l1*l2*l3*l4 -> forall B (q: X B A0), q*r <== q*l1*l2*l3*l4.
  Proof. intros; rewrite H, 3dot_assoc. reflexivity. Qed.

  Lemma add_continuation_4r A0 A1 A2 A3 A4 A5
    (l1: X A0 A1) (l2: X A1 A2) (l3: X A2 A3) (l4: X A3 A4) (l5: X A4 A5)
    (r: X A0 A5):
    r <== l1*l2*l3*l4*l5 -> forall B (q: X B A0), q*r <== q*l1*l2*l3*l4*l5.
  Proof. intros; rewrite H, 4dot_assoc. reflexivity. Qed.
End monoid_rewrite_leq.

Ltac add_continuation H H' := fail "todo: generic add_continuation";
  let Q := fresh "Q" in
  let q := fresh "q" in
  let r' := fresh "r" in
    match type of H with
      | equal ?A ?B ?l ?r =>
        (eapply (@add_continuation _ _ r);
          [ |
            intros Q q;
            eapply equal_trans; [ | apply (dot_compat (equal_refl q) H)]; instantiate; (* rewrite <- H *)
(*             MonoidQuote.simpl_term_by (q;l) Free.normalize; *)
            instantiate;
            match goal with |- equal _ _ _ ?body =>
              set (r':=body);
              pattern Q, q in r'; cbv delta [r'];
              reflexivity
            end
          ]; cbv beta; intro H'
        ) || fail 1 "Bug in [Monoid.add_continuation]"
      | _ => fail 1 "Not an equality"
    end.

Ltac _monoid_rewrite_equal H :=
  first [
    setoid_rewrite (add_continuation_1 H) |
    setoid_rewrite (add_continuation_2 H) |
    setoid_rewrite (add_continuation_3 H) |
    setoid_rewrite (add_continuation_4 H) |
    setoid_rewrite H |
    let H' := fresh in
      add_continuation H H';
      setoid_rewrite H'; clear H'
  ].

Ltac monoid_rewrite H :=
  lazymatch type of H with
    | _ == _ => _monoid_rewrite_equal H
    | _ <== _ =>
      first [
        setoid_rewrite (add_continuation_1l H) |
        setoid_rewrite (add_continuation_2l H) |
        setoid_rewrite (add_continuation_3l H) |
        setoid_rewrite (add_continuation_4l H) |
        setoid_rewrite H |
          let H' := fresh in
            add_continuation H H';
            setoid_rewrite <- H'; clear H'
      ]
    | _ => fail 1 "Not an (in)equality"
  end.

Tactic Notation "monoid_rewrite" "<-" constr(H) :=
  lazymatch type of H with
    | _ == _ => _monoid_rewrite_equal (equal_sym H)
    | _ <== _ =>
      first [
        setoid_rewrite <- (add_continuation_1r H) |
        setoid_rewrite <- (add_continuation_2r H) |
        setoid_rewrite <- (add_continuation_3r H) |
        setoid_rewrite <- (add_continuation_4r H) |
        setoid_rewrite <- H |
          let H' := fresh in
            add_continuation H H';
            setoid_rewrite <- H'; clear H'
      ]
    | _ => fail 1 "Not an (in)equality"
  end.

(*begintests
Section monoid_rewrite_tests.

  Require Import SemiLattice.
  Context `{ISR: IdemSemiRing}.

  Variable A: T.
  Variables a b c d e: X A A.

  Hypothesis H1:  a*b*c == a.
  Hypothesis H1': a*b*c <== a.
  Hypothesis H3:  a == e*c.
  Hypothesis H3': a <== e*c.
  Hypothesis H4:  a*(b+e)*c <== c.

  Instance dot_incr_temp' A B C:
  Proper ((leq A B) ==> (leq B C) ==> (leq A C)) (dot A B C).
  Proof.
    unfold leq; intros x y E x' y' E'.
    rewrite <- E, <- E'.
    rewrite dot_distr_left, 2 dot_distr_right.
    (* Fail aac_reflexivity.       (* BUG *) *)
    rewrite !plus_assoc, plus_idem. reflexivity.
  Qed.

  Goal a+d*a*b*c*d == a+d*e*c*d.
    monoid_rewrite H1.
    monoid_rewrite <- H3.
    reflexivity.
  Qed.

  Goal e*a*b*c+d*a*b*c == e*a+d*a.
    monoid_rewrite H1.
    reflexivity.
  Qed.

  Goal a+d*a*b*c*d <== a+d*e*c*d.
    monoid_rewrite H1'.
    monoid_rewrite <- H3'.
    reflexivity.
  Qed.

  Goal a+d*a*(b+e)*c*d <== a+d*c*d.
    monoid_rewrite H4.
    set (x:=c) at 1; monoid_rewrite <- H4.
  Abort.

End monoid_rewrite_tests.
endtests*)

(** Various properties about monoids and finite iterations *)
Section Props1.

  Context `{M: Monoid}.

  Fixpoint iter A (a: X A A) n :=
    match n with
      | 0 => 1
      | S n => a * iter a n
    end.

  Variables A B C: T.

  Lemma iter_once (a: X A A): iter a 1 == a.
  Proof. intros; simpl; apply dot_neutral_right. Qed.

  Lemma iter_split (a: X A A): forall m n, iter a (m+n) == iter a m * iter a n.
  Proof.
    induction m; intro n; simpl.
    auto with algebra.
    rewrite IHm. auto with algebra.
  Qed.

  Lemma iter_swap (a: X A A): forall n, a * iter a n == iter a n * a.
  Proof.
    intros until n.
    rewrite <- (iter_once a) at 4.
    rewrite <- iter_split.
    rewrite plus_comm.
    reflexivity.
  Qed.

  Lemma iter_swap2 (a: X A B) b: forall n, a * iter (b*a) n == iter (a*b) n * a.
  Proof.
    induction n; simpl.
     rewrite dot_neutral_left. trivial with algebra.
     monoid_rewrite IHn. rewrite 2 dot_assoc. reflexivity.
  Qed.

  Lemma iter_compat n (a b: X A A): a==b -> iter a n == iter b n.
  Proof.
    intros E; induction n; simpl.
    reflexivity.
    rewrite IHn, E; reflexivity.
  Qed.

  Lemma xif_dot: forall b (x y: X A B) (z: X B C), xif b x y * z == xif b (x*z) (y*z).
  Proof. intros. destruct b; trivial. Qed.

  Lemma dot_xif: forall b (x y: X B A) (z: X C B), z * xif b x y == xif b (z*x) (z*y).
  Proof. intros. destruct b; trivial. Qed.

End Props1.


Set Implicit Arguments.

Require Import Coq.Program.Equality String.
Require Import Binding CanonicalForms Definitions GeneralToTight InvertibleTyping Narrowing
            OperationalSemantics PreciseTyping RecordAndInertTypes Substitution Weakening.
Require Import ConstrSafety.

(** The typing of a term with a stack *)
Inductive sta_trm_typ : sta * trm -> typ -> Prop :=
| sta_trm_typ_c : forall G s t T,
    inert G ->
    well_typed G s ->
    G ⊢ t : T ->
    sta_trm_typ (s, t) T.

Hint Constructors sta_trm_typ.

Notation "'⊢' t ':' T" := (sta_trm_typ t T) (at level 40, t at level 59).

(** * Preservation *)

(** If a value [v] has type [T], then [v] has a precise type [T']
    that is a subtype of [T].
    This lemma corresponds to Lemma 3.15 in the paper. *)
Lemma val_typing: forall G v T,
  G ⊢ trm_val v : T ->
  exists T', G ⊢!v v : T' /\
        G ⊢ T' <: T.
Proof.
  intros G v T H. dependent induction H; eauto.
  destruct (IHty_trm _ eq_refl). destruct_all. eauto.
Qed.

(** Helper tactics for proving Preservation *)

Ltac binds_eq :=
  match goal with
  | [Hb1: binds ?x _ ?G,
     Hb2: binds ?x _ ?G |- _] =>
     apply (binds_functional Hb1) in Hb2; inversions Hb2
  end.

Ltac invert_red :=
  match goal with
  | [Hr: (_, _) |-> (_, _) |- _] => inversions Hr
  end.

Ltac solve_IH :=
  match goal with
  | [IH: well_typed _ _ ->
         inert _ ->
         forall t', (_, _) |-> (_, _) -> _,
       Wf: well_typed _ _,
       In: inert _,
       Hr: (_, _) |-> (_, ?t') |- _] =>
    specialize (IH Wf In t' Hr); destruct_all
  end;
  match goal with
  | [Hi: _ & ?G' ⊢ _ : _ |- _] =>
    exists G'; repeat_split_right; auto
  end.

Ltac solve_let :=
  invert_red; solve_IH; fresh_constructor; eauto; apply* weaken_rules.

(** [s: G]                  #
#
    [inert [G]              #
#
    [(s, t) |-> (s', t')]   #
#
    [G ⊢ t: T]              #
#
    [―――――――――――――――――――]   #
#
    [exists G', inert G']        #
#
    [s': G, G']             #
#
    [G, G' ⊢ t': T]         *)
Lemma preservation_helper: forall G s t s' t' T,
    well_typed G s ->
    inert G ->
    (s, t) |-> (s', t') ->
    G ⊢ t : T ->
    exists G', inert G' /\
          well_typed (G & G') s' /\
          G & G' ⊢ t' : T.
Proof.
  introv Hwf Hin Hred Ht. gen t'.
  induction Ht; intros; try solve [invert_red].
  - Case "ty_all_elim"%string.
    match goal with
    | [Hx: _ ⊢ trm_var (avar_f _) : typ_all _ _ |- _] =>
        pose proof (canonical_forms_fun Hin Hwf Hx) as [L [T' [t [Bis [Hsub Hty]]]]];
          inversions Hred;
          binds_eq
    end.
    exists (@empty typ). rewrite concat_empty_r. repeat_split_right; auto.
    pick_fresh y. assert (y \notin L) as FrL by auto. specialize (Hty y FrL).
    apply* renaming_typ; eauto.
  - Case "ty_new_elim"%string.
    pose proof (canonical_forms_obj Hin Hwf Ht) as [S [ds [t [Bis [Has Ty]]]]].
    invert_red. binds_eq.
    exists (@empty typ). rewrite concat_empty_r. repeat_split_right; auto.
    match goal with
    | [Hd: defs_has _ (def_trm _ ?t') |- G ⊢ t': T] =>
      rewrite* <- (defs_has_inv Has Hd)
    end.
  - Case "ty_let"%string.
    destruct t; try solve [solve_let].
    + SCase "[t = (let x = a in u)] where a is a variable".
      repeat invert_red.
      exists (@empty typ). rewrite concat_empty_r. repeat_split_right; auto.
      apply* renaming_fresh.
    + SCase "[t = (let x = v in u)] where v is a value".
      repeat invert_red.
      match goal with
        | [Hn: ?x # ?s |- _] =>
          pose proof (well_typed_notin_dom Hwf Hn) as Hng
      end.
      pose proof (val_typing Ht) as [V [Hv Hs]].
      exists (x ~ V). repeat_split_right.
      ** rewrite <- concat_empty_l. constructor~. apply (precise_inert_typ Hv).
      ** apply~ well_typed_push. apply (precise_to_general_v Hv).
      ** eapply renaming_fresh with (L:=L \u dom G \u \{x}). apply* ok_push.
         intros. apply* weaken_rules. apply ty_sub with (T:=V); auto. apply* weaken_subtyp.
  - Case "ty_sub"%string.
    solve_IH.
    match goal with
    | [Hs: _ ⊢ _ <: _,
       Hg: _ & ?G' ⊢ _: _ |- _] =>
      apply weaken_subtyp with (G2:=G') in Hs;
      eauto
    end.
Qed.

(** ** Preservation Theorem *)

(** [⊢ (s, t): T]           #
#
    [(s, t) |-> (s', t')]   #
#
    [―――――――――――――――――――]   #
#
    [⊢ (s', t'): T]         *)
Theorem preservation : forall s s' t t' T,
    ⊢ (s, t) : T ->
    (s, t) |-> (s', t') ->
    ⊢ (s', t') : T.
Proof.
  introv Ht Hr. destruct Ht as [* Hi Hwf Ht].
  lets Hp: (preservation_helper Hwf Hi Hr Ht). destruct Hp as [G' [Hi' [Hwf' Ht']]].
  apply sta_trm_typ_c with (G:=G & G'); auto. apply* inert_concat.
Qed.

(** * Progress *)

(** Helper tactic for proving progress *)
Ltac solve_let_prog :=
  match goal with
      | [IH: ⊢ (?s, ?t) : ?T ->
             inert _ ->
             well_typed _ _ -> _,
         Hi: inert _,
         Hwt: well_typed _ _ |- _] =>
        assert (⊢ (s, t): T) as Hs by eauto;
        specialize (IH Hs Hi Hwt) as [IH | [s' [t' Hr]]];
        eauto; inversion IH
      end.

(** ** Progress Theorem *)

(** [⊢ (s, t): T]           #
#
    [(s, t) |-> (s', t')]   #
#
    [―――――――――――――――――――]   #
#
    [t] is in normal form   #
#
    or [exists s', t'] such that [(s, t) |-> (s', t')] *)
Theorem progress: forall s t T,
    ⊢ (s, t) : T ->
    norm_form t \/ exists s' t', (s, t) |-> (s', t').
Proof.
  introv Ht. inversion Ht as [G s' t' T' Hi Hwt HT]. subst.
  induction HT; eauto.
  - Case "ty_all_elim"%string.
    pose proof (canonical_forms_fun Hi Hwt HT1). destruct_all. right*.
  - Case "ty_new_elim"%string.
    pose proof (canonical_forms_obj Hi Hwt HT). destruct_all. right*.
  - Case "ty_let"%string.
    right. destruct t; try solve [solve_let_prog].
    + pose proof (var_typing_implies_avar_f HT) as [x A]. subst*.
    + pick_fresh x. exists (s & x ~ v) (open_trm x u). auto.
Qed.


Set Universe Polymorphism.

Module type.

Inductive type :=
| atm : Type -> type
| arr : type -> type -> type
| one : type
| tns : type -> type -> type
| nul : type
| pls : type -> type -> type
.

Fixpoint pure (t : type) : Type :=
match t with
| atm A => A
| arr t u => (pure t) -> (pure u)
| one => unit
| tns t u => prod (pure t) (pure u)
| nul => False
| pls t u => sum (pure t) (pure u)
end.

End type.

Module CBN.

Import type.

Definition ℜ (X : Type) := X.

Fixpoint eval (t : type) R : Type :=
match t with
| atm T => T -> ℜ R
| arr t u => (forall R : Type, eval t R -> ℜ R) * eval u R
| one => ℜ R
| tns t u => ((forall R : Type, eval t R -> ℜ R) * (forall R : Type, eval u R -> ℜ R)) -> ℜ R
| nul => False -> ℜ R
| pls t u => ((forall R : Type, eval t R -> ℜ R) + (forall R : Type, eval u R -> ℜ R)) -> ℜ R
end.

Notation "[ A ⊢ R ]" := (eval A R).

Fixpoint eval_env (Γ : list type) : Type :=
match Γ with
| nil => unit
| cons A Γ => prod (forall R, eval A R -> ℜ R) (eval_env Γ)
end.

Definition seq Γ A := forall R, eval_env Γ -> eval A R -> ℜ R.

Lemma axiom : forall Γ A, seq (cons A Γ) A.
Proof.
intros Γ A R [x γ] k; unfold seq; cbn.
exact (x R k).
Defined.

Lemma wkn : forall Γ A B, seq Γ B -> seq (cons A Γ) B.
Proof.
intros Γ A B p R [_ γ] k; unfold seq; cbn.
refine (p _ γ k).
Defined.

Lemma arr_intro : forall Γ A B, seq (cons A Γ) B -> seq Γ (arr A B).
Proof.
intros Γ A B p R γ [x k].
refine (p _ (x, γ) k).
Defined.

Lemma arr_elim : forall Γ A B, seq Γ (arr A B) -> seq Γ A -> seq Γ B.
Proof.
intros Γ A B p q R γ k.
refine (p _ γ ((fun R => q R γ), k)).
Defined.

Lemma tns_intro : forall Γ A B, seq Γ A -> seq Γ B -> seq Γ (tns A B).
Proof.
intros Γ A B p q R γ k.
refine (k ((fun R => p R γ), (fun R => q R γ))).
Defined.

Lemma tns_elim : forall Γ A B C, seq Γ (tns A B) -> seq (cons A (cons B Γ)) C -> seq Γ C.
Proof.
intros Γ A B C p q R γ k.
refine (p _ γ (fun π => q _ (fst π, (snd π, γ)) k)).
Defined.

Lemma pls_introl : forall Γ A B, seq Γ A -> seq Γ (pls A B).
Proof.
intros Γ A B p R γ k.
refine (k (inl (fun R => p R γ))).
Defined.

Lemma pls_intror : forall Γ A B, seq Γ B -> seq Γ (pls A B).
Proof.
intros Γ A B p R γ k.
refine (k (inr (fun R => p R γ))).
Defined.

Lemma pls_elim : forall Γ A B C, seq Γ (pls A B) -> seq (cons A Γ) C -> seq (cons B Γ) C -> seq Γ C.
Proof.
intros Γ A B C p q r R γ k.
refine (p _ γ (fun π => match π with inl kl => q _ (kl, γ) k | inr kr => r _ (kr, γ) k end)).
Defined.

Lemma one_intro : forall Γ, seq Γ one.
Proof.
intros Γ R γ k; exact k.
Defined.

Lemma nul_elim : forall Γ A, seq Γ nul -> seq Γ A.
Proof.
intros Γ A p R γ k.
refine (p _ γ (fun π => match π with end)).
Defined.

(** Interesting feature *)
Lemma iota_sum_l : forall Γ A B C p q r,
  pls_elim Γ A B C (pls_introl _ _ _ p) q r = arr_elim _ _ _ (arr_intro _ _ _ q) p.
Proof.
intros Γ A B C p q r.
reflexivity.
Qed.

Record run (t : type) : Type := {
  reflect : (forall R, eval t R -> ℜ R) -> pure t;
  reify : pure t -> (forall R, eval t R -> ℜ R)
}.

Lemma runner : forall t, run t.
Proof.
induction t; split; cbn.
+ intros k; refine (k _ (fun x => x)).
+ intros x R k; refine (k x).
+ destruct IHt2 as [IHt2 _], IHt1 as [_ IHt1].
  intros k x; apply IHt2.
  intros R p; apply k; split.
  ++ apply IHt1, x.
  ++ apply p.
+ destruct IHt2 as [_ IHt2], IHt1 as [IHt1 _].
  intros k R [x p].
  refine (IHt2 _ _ p).
  apply k, IHt1, x.
+ intros k; refine (k _ tt).
+ intros [] R x; exact x.
+ destruct IHt2 as [IHt2 _], IHt1 as [IHt1 _].
  intros k; apply k.
  intros [pl pr]; split.
  ++ apply IHt1, pl.
  ++ apply IHt2, pr.
+ destruct IHt2 as [_ IHt2], IHt1 as [_ IHt1].
  intros [x y] R p.
  apply (p (IHt1 x, IHt2 y)).
+ intros k; refine (k _ (False_rect _)).
+ intros [].
+ destruct IHt2 as [IHt2 _], IHt1 as [IHt1 _].
  intros k; apply k.
  intros [pl|pr].
  ++ left; apply IHt1, pl.
  ++ right; apply IHt2, pr.
+ destruct IHt2 as [_ IHt2], IHt1 as [_ IHt1].
  intros [x|y].
  ++ intros R k; apply k; left; apply (IHt1 x).
  ++ intros R k; apply k; right; apply (IHt2 y).
Defined.

End CBN.

Module CBV.

Import type.

Definition ℜ (X : Type) := X.

Fixpoint evalv (t : type) : Type :=
match t with
| atm T => T
| arr t u => forall R : Type, (evalv t) * (evalv u -> ℜ R) -> ℜ R
| one => unit
| tns t u => (evalv t) * (evalv u)
| nul => False
| pls t u => evalv t + evalv u
end.

Definition eval t R := evalv t -> ℜ R.

Notation "[ A ⊢ R ]" := (eval A R).

Fixpoint eval_env (Γ : list type) : Type :=
match Γ with
| nil => unit
| cons A Γ => prod (evalv A) (eval_env Γ)
end.

Definition seqv Γ A := eval_env Γ -> evalv A.
Definition seq Γ A := forall R, eval_env Γ -> eval A R -> ℜ R.

Lemma axiom : forall Γ A, seqv (cons A Γ) A.
Proof.
intros Γ A [x γ]; exact x.
Defined.

Lemma arr_intro : forall Γ A B, seq (cons A Γ) B -> seqv Γ (arr A B).
Proof.
intros Γ A B p γ R [x k].
refine (p _ (x, γ) k).
Defined.

Lemma arr_elim : forall Γ A B, seq Γ (arr A B) -> seq Γ A -> seq Γ B.
Proof.
intros Γ A B p q R γ k.
refine (p _ γ (fun f => f _ (q _ γ (fun x => x), k))).
Defined.

Lemma return_val : forall Γ A, seqv Γ A -> seq Γ A.
Proof.
intros Γ A p R γ k.
refine (k (p γ)).
Defined.

Lemma wkn : forall Γ A B, seq Γ B -> seq (cons A Γ) B.
Proof.
intros Γ A B p R [_ γ] k; unfold seq; cbn.
refine (p _ γ k).
Defined.

Lemma tns_intro : forall Γ A B, seq Γ A -> seq Γ B -> seq Γ (tns A B).
Proof.
intros Γ A B p q R γ k.
refine (k (p _ γ (fun x => x), q _ γ (fun x => x))).
Defined.

Lemma tns_elim : forall Γ A B C, seq Γ (tns A B) -> seq (cons A (cons B Γ)) C -> seq Γ C.
Proof.
intros Γ A B C p q R γ k.
refine (p _ γ (fun π => q _ (fst π, (snd π, γ)) k)).
Defined.

Lemma one_intro : forall Γ, seqv Γ one.
Proof.
intros Γ γ; refine tt.
Defined.

Lemma one_elim : forall Γ A, seq Γ one -> seq Γ A -> seq Γ A.
Proof.
intros Γ A p q R γ k.
refine (p _ γ (fun _ => q _ γ k)).
Defined.

Lemma pls_introl : forall Γ A B, seq Γ A -> seq Γ (pls A B).
Proof.
intros Γ A B p R γ k.
refine (k (inl (p _ γ (fun x => x)))).
Defined.

Lemma pls_intror : forall Γ A B, seq Γ B -> seq Γ (pls A B).
Proof.
intros Γ A B p R γ k.
refine (k (inr (p _ γ (fun x => x)))).
Defined.

Lemma pls_elim : forall Γ A B C, seq Γ (pls A B) -> seq (cons A Γ) C -> seq (cons B Γ) C -> seq Γ C.
Proof.
intros Γ A B C p q r R γ k.
refine (p _ γ (fun π => match π with inl kl => q _ (kl, γ) k | inr kr => r _ (kr, γ) k end)).
Defined.

Lemma nul_elim : forall Γ A, seq Γ nul -> seq Γ A.
Proof.
intros Γ A p R γ k.
refine (p _ γ (fun π => match π with end)).
Defined.

(** Interesting feature *)
Lemma iota_sum_l : forall Γ A B C p q r,
  pls_elim Γ A B C (pls_introl _ _ _ p) q r = arr_elim _ _ _ (return_val _ _ (arr_intro _ _ _ q)) p.
Proof.
intros Γ A B C p q r.
reflexivity.
Qed.

Record run (t : type) : Type := {
  reflect : (forall R : Type, eval t R -> ℜ R) -> pure t;
  reify : pure t -> evalv t
}.

Lemma runner : forall t, run t.
Proof.
induction t; split; cbn.
+ intros k; refine (k _ (fun x => x)).
+ refine (fun x => x).

+ destruct IHt2 as [IHt2 _], IHt1 as [_ IHt1].
  intros k x.
  refine (k _ (fun f => _)).
  refine (let r := f _ (IHt1 x, (fun f => IHt2 (fun _ k => k f))) in _); shelve_unifiable.
  apply r.
+ destruct IHt2 as [_ IHt2], IHt1 as [IHt1 _].
  intros f R [x p].
  refine (p (IHt2 (f (IHt1 (fun _ k => k x))))).

+ intros k; refine (k _ (fun x => x)).
+ intros []; exact tt.

+ destruct IHt2 as [IHt2 _], IHt1 as [IHt1 _].
  intros k; apply k.
  intros [pl pr]; split.
  ++ refine (IHt1 (fun _ k => k pl)).
  ++ refine (IHt2 (fun _ k => k pr)).
+ destruct IHt2 as [_ IHt2], IHt1 as [_ IHt1].
  intros [x y].
  apply ((IHt1 x, IHt2 y)).

+ intros k; refine (k _ (False_rect _)).
+ intros [].

+ destruct IHt2 as [IHt2 _], IHt1 as [IHt1 _].
  intros k; apply k.
  intros [pl|pr].
  ++ left; refine (IHt1 (fun _ k => k pl)).
  ++ right; refine (IHt2 (fun _ k => k pr)).
+ destruct IHt2 as [_ IHt2], IHt1 as [_ IHt1].
  intros [x|y].
  ++ left; apply (IHt1 x).
  ++ right; apply (IHt2 y).
Defined.

End CBV.

Module Delim.

Inductive type :=
| atm : Type -> type
| arr : type -> list type -> type -> type
| btm : type
(* | one : type *)
(* | tns : type -> type -> type *)
(* | nul : type *)
(* | pls : type -> type -> type *)
.

Fixpoint fold {A B} (f : A -> B -> A) (accu : A) (l : list B) : A :=
match l with
| nil => accu
| cons x l => f (fold f accu l) x
end.

Definition ℜ (X : Type) := X.

Fixpoint eval (t : type) R {struct t} : Type :=
match t with
| atm T => T -> ℜ R
| arr t σ u =>
  let fix f σ R : Type := match σ with
  | nil => ℜ R
  | cons t σ => (eval t  (f σ R))
  end in
  (forall R : Type, (eval t (f σ R)) -> ℜ R) * eval u R
| btm => unit
(* | one => ℜ R *)
(* | tns t u => ((forall R : Type, eval t R -> ℜ R) * (forall R : Type, eval u R -> ℜ R)) -> ℜ R *)
(* | nul => False -> ℜ R *)
(* | pls t u => ((forall R : Type, eval t R -> ℜ R) + (forall R : Type, eval u R -> ℜ R)) -> ℜ R *)
end.

Notation "[ A ⊢ R ]" := (eval A R).

Fixpoint peval (σ : list type) R {struct σ} : Type :=
match σ with
| nil => ℜ R
| cons t σ => (eval t (peval σ R))
end.

Fixpoint eval_env (Γ : list (type * list type)) : Type :=
match Γ with
| nil => unit
| cons (A, σ) Γ => prod (forall R, peval (cons A σ) R -> ℜ R) (eval_env Γ)
end.

Definition seq Γ A σ := forall R, eval_env Γ -> peval (cons A σ) R -> ℜ R.

Lemma axiom : forall Γ A σ, seq (cons (A, σ) Γ) A σ.
Proof.
intros Γ A σ R [x γ] k; unfold seq; cbn.
exact (x R k).
Defined.

Lemma wkn : forall Γ A B σ τ, seq Γ B σ -> seq (cons (A, τ) Γ) B σ.
Proof.
intros Γ A B σ τ p R [_ γ] k; unfold seq; cbn.
refine (p _ γ k).
Defined.

Lemma arr_intro : forall Γ A B σ τ, seq (cons (A, τ) Γ) B σ -> seq Γ (arr A τ B) σ.
Proof.
intros Γ A B σ τ p R γ [x k].
refine (p _ (x, γ) k).
Defined.

Lemma arr_elim : forall Γ A B σ τ, seq Γ (arr A τ B) σ -> seq Γ A τ -> seq Γ B σ.
Proof.
intros Γ A B σ τ p q R γ k.
refine (p _ γ ((fun R => q R γ), k)).
Defined.

Lemma settp : forall Γ A σ, seq Γ A (cons A σ) -> seq Γ A σ.
Proof.
intros Γ A σ p R γ k.
refine (p _ γ _).
cbn.
constructor.
Qed.

Lemma getp : forall Γ A σ, seq Γ A σ -> seq Γ btm (cons A σ).
Proof.
intros Γ A σ p R γ k.
refine (p _ γ _).
cbn in k.
cbn.
constructor.
Qed.

Eval compute in seq nil (arr (atm nat) nil (atm bool)) nil.

Lemma arr_elim : forall Γ A B σ τ, seq Γ (arr A τ B) σ-> seq Γ A τ -> seq Γ B σ.
Proof.
intros Γ A B σ τ p q R γ k.
refine (p _ γ ((fun R => q R γ), k)).
Defined.

Lemma tns_intro : forall Γ A B, seq Γ A -> seq Γ B -> seq Γ (tns A B).
Proof.
intros Γ A B p q R γ k.
refine (k ((fun R => p R γ), (fun R => q R γ))).
Defined.

Lemma tns_elim : forall Γ A B C, seq Γ (tns A B) -> seq (cons A (cons B Γ)) C -> seq Γ C.
Proof.
intros Γ A B C p q R γ k.
refine (p _ γ (fun π => q _ (fst π, (snd π, γ)) k)).
Defined.

Fixpoint rseq (Γ : list type) A :=
match Γ with
| nil => A
| cons B Γ => arr B (rseq Γ A)
end.

(*
Lemma reset : forall Γ A, [rseq Γ A ⊢ seq Γ A].
Proof.
intros Γ A; revert Γ; unfold seq; cbn.
induction A; cbn; intros Γ.
+ admit.
+ cbn.
+ admit.
+ admit.
+ admit.
+ admit.
Defined.

 *)
(*
Lemma tns_elim' : forall Γ A B C, seq Γ (tns A B) -> seq (cons A (cons B Γ)) C -> seq Γ C.
Proof.
intros Γ A B C p q R γ k.
specialize (p (prod (seq nil A) (seq nil B)) γ).
cbn in *.
destruct p as [pl pr].
intros [kl kr].
split.
apply kl.
clear.
unfold seq; cbn.
induction A; cbn.
unfold seq in pl, pr.
refine (q _ (_, (_, γ)) k).
clear - pl; intros R k; apply (pl _ tt k).
clear - pr; intros R k; apply (pr _ tt k).
Defined.

*)

Lemma pls_introl : forall Γ A B, seq Γ A -> seq Γ (pls A B).
Proof.
intros Γ A B p R γ k.
refine (k (inl (fun R => p R γ))).
Defined.

Lemma pls_intror : forall Γ A B, seq Γ B -> seq Γ (pls A B).
Proof.
intros Γ A B p R γ k.
refine (k (inr (fun R => p R γ))).
Defined.

Lemma pls_elim : forall Γ A B C, seq Γ (pls A B) -> seq (cons A Γ) C -> seq (cons B Γ) C -> seq Γ C.
Proof.
intros Γ A B C p q r R γ k.
refine (p _ γ (fun π => match π with inl kl => q _ (kl, γ) k | inr kr => r _ (kr, γ) k end)).
Defined.

Lemma one_intro : forall Γ, seq Γ one.
Proof.
intros Γ R γ k; exact k.
Defined.

Lemma nul_elim : forall Γ A, seq Γ nul -> seq Γ A.
Proof.
intros Γ A p R γ k.
refine (p _ γ (fun π => match π with end)).
Defined.

Lemma em : forall A, (seq nil (pls (atm A) (arr (atm A) nul))) -> A + ~ A.
Proof.
intros A Hem.
unfold seq in Hem; cbn in Hem.
specialize (Hem (A + ~ A)%type tt).
apply Hem.
intros [Hl|Hr].
+ left; apply Hl; trivial.
+ right; intros x; apply Hr.
  split; intuition.
Defined.

Lemma callcc : forall A B, (seq nil (arr (arr (arr (atm A) (atm B)) (atm A)) (atm A))) -> ((A -> B) -> A) -> A.
Proof.
intros A B Hcc.
unfold seq in Hcc.
cbn in Hcc.
specialize (Hcc A tt).
intros f.
apply Hcc.
split; [|intuition].
intros R [g k].
apply k, f.
intros x; apply g; intuition.
Defined.


(* !!! WARNING: AUTO GENERATED. DO NOT MODIFY !!! *)
Require Import Metalib.Metatheory.
(** syntax *)
Definition i := nat.

Inductive typ : Set :=  (*r types *)
 | t_int : typ (*r int *)
 | t_top : typ (*r top *)
 | t_arrow (A:typ) (B:typ) (*r function types *)
 | t_and (A:typ) (B:typ) (*r intersection *).

Inductive dexp : Set :=  (*r expressions *)
 | de_var_b (_:nat) (*r variables *)
 | de_var_f (x:var) (*r variables *)
 | de_top : dexp (*r top *)
 | de_lit (i5:i) (*r lit *)
 | de_abs (ee:dexp) (*r abstractions *)
 | de_app (ee1:dexp) (ee2:dexp) (*r applications *)
 | de_merge (ee1:dexp) (ee2:dexp) (*r merge *)
 | de_fixpoint (ee:dexp) (*r fixpoint *).

Inductive st : Set :=  (*r input type or projection label *)
 | st_ty (A:typ).

Definition ctx : Set := list ( atom * typ ).

Inductive exp : Set :=  (*r expressions *)
 | e_var_b (_:nat) (*r variables *)
 | e_var_f (x:var) (*r variables *)
 | e_top : exp (*r top *)
 | e_lit (i5:i) (*r lit *)
 | e_abs (e:exp) (A:typ) (B:typ) (*r abstractions *)
 | e_fixpoint (e:exp) (A:typ) (*r fixpoint *)
 | e_app (e1:exp) (e2:exp) (*r applications *)
 | e_merge (e1:exp) (e2:exp) (*r merge *)
 | e_anno (e:exp) (A:typ) (*r annotation *)
 | e_val (v:value) (*r value *)
with value : Set :=  (*r values *)
 | v_top : value (*r top *)
 | v_lit (i5:i) (*r lit *)
 | v_topv (v:value) (*r topv *)
 | v_absv (e:exp) (A:typ) (B:typ) (*r abstractions *)
 | v_merge (v1:value) (v2:value) (*r merge *).

Definition ls : Set := list st.

(* EXPERIMENTAL *)
(** auxiliary functions on the new list types *)
(** library functions *)
(** subrules *)
(** arities *)
(** opening up abstractions *)
Fixpoint open_dexp_wrt_dexp_rec (k:nat) (ee_5:dexp) (ee__6:dexp) {struct ee__6}: dexp :=
  match ee__6 with
  | (de_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => de_var_b nat
        | inleft (right _) => ee_5
        | inright _ => de_var_b (nat - 1)
      end
  | (de_var_f x) => de_var_f x
  | de_top => de_top
  | (de_lit i5) => de_lit i5
  | (de_abs ee) => de_abs (open_dexp_wrt_dexp_rec (S k) ee_5 ee)
  | (de_app ee1 ee2) => de_app (open_dexp_wrt_dexp_rec k ee_5 ee1) (open_dexp_wrt_dexp_rec k ee_5 ee2)
  | (de_merge ee1 ee2) => de_merge (open_dexp_wrt_dexp_rec k ee_5 ee1) (open_dexp_wrt_dexp_rec k ee_5 ee2)
  | (de_fixpoint ee) => de_fixpoint (open_dexp_wrt_dexp_rec (S k) ee_5 ee)
end.

Fixpoint open_value_wrt_exp_rec (k:nat) (e5:exp) (v_5:value) {struct v_5}: value :=
  match v_5 with
  | v_top => v_top
  | (v_lit i5) => v_lit i5
  | (v_topv v) => v_topv (open_value_wrt_exp_rec k e5 v)
  | (v_absv e A B) => v_absv (open_exp_wrt_exp_rec (S k) e5 e) A B
  | (v_merge v1 v2) => v_merge (open_value_wrt_exp_rec k e5 v1) (open_value_wrt_exp_rec k e5 v2)
end
with open_exp_wrt_exp_rec (k:nat) (e_5:exp) (e__6:exp) {struct e__6}: exp :=
  match e__6 with
  | (e_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => e_var_b nat
        | inleft (right _) => e_5
        | inright _ => e_var_b (nat - 1)
      end
  | (e_var_f x) => e_var_f x
  | e_top => e_top
  | (e_lit i5) => e_lit i5
  | (e_abs e A B) => e_abs (open_exp_wrt_exp_rec (S k) e_5 e) A B
  | (e_fixpoint e A) => e_fixpoint (open_exp_wrt_exp_rec (S k) e_5 e) A
  | (e_app e1 e2) => e_app (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
  | (e_merge e1 e2) => e_merge (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
  | (e_anno e A) => e_anno (open_exp_wrt_exp_rec k e_5 e) A
  | (e_val v) => e_val (open_value_wrt_exp_rec k e_5 v)
end.

Definition open_dexp_wrt_dexp ee_5 ee__6 := open_dexp_wrt_dexp_rec 0 ee__6 ee_5.

Definition open_value_wrt_exp e5 v_5 := open_value_wrt_exp_rec 0 v_5 e5.

Definition open_exp_wrt_exp e_5 e__6 := open_exp_wrt_exp_rec 0 e__6 e_5.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_dexp *)
Inductive lc_dexp : dexp -> Prop :=    (* defn lc_dexp *)
 | lc_de_var_f : forall (x:var),
     (lc_dexp (de_var_f x))
 | lc_de_top :
     (lc_dexp de_top)
 | lc_de_lit : forall (i5:i),
     (lc_dexp (de_lit i5))
 | lc_de_abs : forall (ee:dexp),
      ( forall x , lc_dexp  ( open_dexp_wrt_dexp ee (de_var_f x) )  )  ->
     (lc_dexp (de_abs ee))
 | lc_de_app : forall (ee1 ee2:dexp),
     (lc_dexp ee1) ->
     (lc_dexp ee2) ->
     (lc_dexp (de_app ee1 ee2))
 | lc_de_merge : forall (ee1 ee2:dexp),
     (lc_dexp ee1) ->
     (lc_dexp ee2) ->
     (lc_dexp (de_merge ee1 ee2))
 | lc_de_fixpoint : forall (ee:dexp),
      ( forall x , lc_dexp  ( open_dexp_wrt_dexp ee (de_var_f x) )  )  ->
     (lc_dexp (de_fixpoint ee)).

(* defns LC_value_exp *)
Inductive lc_value : value -> Prop :=    (* defn lc_value *)
 | lc_v_top :
     (lc_value v_top)
 | lc_v_lit : forall (i5:i),
     (lc_value (v_lit i5))
 | lc_v_topv : forall (v:value),
     (lc_value v) ->
     (lc_value (v_topv v))
 | lc_v_absv : forall (e:exp) (A B:typ),
      ( forall x , lc_exp  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     (lc_value (v_absv e A B))
 | lc_v_merge : forall (v1 v2:value),
     (lc_value v1) ->
     (lc_value v2) ->
     (lc_value (v_merge v1 v2))
with lc_exp : exp -> Prop :=    (* defn lc_exp *)
 | lc_e_var_f : forall (x:var),
     (lc_exp (e_var_f x))
 | lc_e_top :
     (lc_exp e_top)
 | lc_e_lit : forall (i5:i),
     (lc_exp (e_lit i5))
 | lc_e_abs : forall (e:exp) (A B:typ),
      ( forall x , lc_exp  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     (lc_exp (e_abs e A B))
 | lc_e_fixpoint : forall (e:exp) (A:typ),
      ( forall x , lc_exp  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     (lc_exp (e_fixpoint e A))
 | lc_e_app : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (e_app e1 e2))
 | lc_e_merge : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (e_merge e1 e2))
 | lc_e_anno : forall (e:exp) (A:typ),
     (lc_exp e) ->
     (lc_exp (e_anno e A))
 | lc_e_val : forall (v:value),
     (lc_value v) ->
     (lc_exp (e_val v)).
(** free variables *)
Fixpoint fv_value (v_5:value) : vars :=
  match v_5 with
  | v_top => {}
  | (v_lit i5) => {}
  | (v_topv v) => (fv_value v)
  | (v_absv e A B) => (fv_exp e)
  | (v_merge v1 v2) => (fv_value v1) \u (fv_value v2)
end
with fv_exp (e_5:exp) : vars :=
  match e_5 with
  | (e_var_b nat) => {}
  | (e_var_f x) => {{x}}
  | e_top => {}
  | (e_lit i5) => {}
  | (e_abs e A B) => (fv_exp e)
  | (e_fixpoint e A) => (fv_exp e)
  | (e_app e1 e2) => (fv_exp e1) \u (fv_exp e2)
  | (e_merge e1 e2) => (fv_exp e1) \u (fv_exp e2)
  | (e_anno e A) => (fv_exp e)
  | (e_val v) => (fv_value v)
end.

Fixpoint fv_dexp (ee_5:dexp) : vars :=
  match ee_5 with
  | (de_var_b nat) => {}
  | (de_var_f x) => {{x}}
  | de_top => {}
  | (de_lit i5) => {}
  | (de_abs ee) => (fv_dexp ee)
  | (de_app ee1 ee2) => (fv_dexp ee1) \u (fv_dexp ee2)
  | (de_merge ee1 ee2) => (fv_dexp ee1) \u (fv_dexp ee2)
  | (de_fixpoint ee) => (fv_dexp ee)
end.

(** substitutions *)
Fixpoint subst_exp (e_5:exp) (x5:var) (e__6:exp) {struct e__6} : exp :=
  match e__6 with
  | (e_var_b nat) => e_var_b nat
  | (e_var_f x) => (if eq_var x x5 then e_5 else (e_var_f x))
  | e_top => e_top
  | (e_lit i5) => e_lit i5
  | (e_abs e A B) => e_abs (subst_exp e_5 x5 e) A B
  | (e_fixpoint e A) => e_fixpoint (subst_exp e_5 x5 e) A
  | (e_app e1 e2) => e_app (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
  | (e_merge e1 e2) => e_merge (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
  | (e_anno e A) => e_anno (subst_exp e_5 x5 e) A
  | (e_val v) => e_val (subst_value e_5 x5 v)
end
with subst_value (e5:exp) (x5:var) (v_5:value) {struct v_5} : value :=
  match v_5 with
  | v_top => v_top
  | (v_lit i5) => v_lit i5
  | (v_topv v) => v_topv (subst_value e5 x5 v)
  | (v_absv e A B) => v_absv (subst_exp e5 x5 e) A B
  | (v_merge v1 v2) => v_merge (subst_value e5 x5 v1) (subst_value e5 x5 v2)
end.

Fixpoint subst_dexp (ee_5:dexp) (x5:var) (ee__6:dexp) {struct ee__6} : dexp :=
  match ee__6 with
  | (de_var_b nat) => de_var_b nat
  | (de_var_f x) => (if eq_var x x5 then ee_5 else (de_var_f x))
  | de_top => de_top
  | (de_lit i5) => de_lit i5
  | (de_abs ee) => de_abs (subst_dexp ee_5 x5 ee)
  | (de_app ee1 ee2) => de_app (subst_dexp ee_5 x5 ee1) (subst_dexp ee_5 x5 ee2)
  | (de_merge ee1 ee2) => de_merge (subst_dexp ee_5 x5 ee1) (subst_dexp ee_5 x5 ee2)
  | (de_fixpoint ee) => de_fixpoint (subst_dexp ee_5 x5 ee)
end.

(** definitions *)

(* defns TopLikeType *)
Inductive topLike : typ -> Prop :=    (* defn topLike *)
 | TL_top :
     topLike t_top
 | TL_and : forall (A B:typ),
     topLike A ->
     topLike B ->
     topLike (t_and A B).

(* defns OrdinaryType *)
Inductive ord : typ -> Prop :=    (* defn ord *)
 | O_int :
     ord t_int
 | O_arrow : forall (A B:typ),
     ord (t_arrow A B).

(* defns Disjoint *)
Inductive disjoint : typ -> typ -> Prop :=    (* defn disjoint *)
 | D_topL : forall (A:typ),
     disjoint t_top A
 | D_topR : forall (A:typ),
     disjoint A t_top
 | D_andL : forall (A1 A2 B:typ),
     disjoint A1 B ->
     disjoint A2 B ->
     disjoint (t_and A1 A2) B
 | D_andR : forall (A B1 B2:typ),
     disjoint A B1 ->
     disjoint A B2 ->
     disjoint A (t_and B1 B2)
 | D_axIntArr : forall (A1 A2:typ),
     disjoint t_int (t_arrow A1 A2)
 | D_axArrInt : forall (A1 A2:typ),
     disjoint (t_arrow A1 A2) t_int.

(* defns Subtyping *)
Inductive sub : typ -> typ -> Prop :=    (* defn sub *)
 | S_z :
     sub t_int t_int
 | S_top : forall (A:typ),
     sub A t_top
 | S_arr : forall (A1 A2 B1 B2:typ),
     sub B1 A1 ->
     sub A2 B2 ->
     sub (t_arrow A1 A2) (t_arrow B1 B2)
 | S_andl1 : forall (A1 A2 A3:typ),
     sub A1 A3 ->
     sub (t_and A1 A2) A3
 | S_andl2 : forall (A1 A2 A3:typ),
     sub A2 A3 ->
     sub (t_and A1 A2) A3
 | S_andr : forall (A1 A2 A3:typ),
     sub A1 A2 ->
     sub A1 A3 ->
     sub A1 (t_and A2 A3).

(* defns Semantics *)
Inductive TypedReduce : value -> typ -> value -> Prop :=    (* defn TypedReduce *)
 | TReduce_lit : forall (i5:i),
     TypedReduce (v_lit i5) t_int (v_lit i5)
 | TReduce_top : forall (v:value),
     lc_value v ->
     TypedReduce v t_top (v_topv v)
 | TReduce_arrow : forall (e:exp) (A B C D:typ),
     lc_value (v_absv e A B) ->
     sub C A ->
     sub B D ->
     TypedReduce (v_absv e A B)  (t_arrow C D)  (v_absv e A D)
 | TReduce_mergevl : forall (v1 v2:value) (A:typ) (v1':value),
     lc_value v2 ->
     TypedReduce v1 A v1' ->
     ord A ->
     TypedReduce (v_merge v1 v2) A v1'
 | TReduce_mergevr : forall (v1 v2:value) (A:typ) (v2':value),
     lc_value v1 ->
     TypedReduce v2 A v2' ->
     ord A ->
     TypedReduce (v_merge v1 v2) A v2'
 | TReduce_and : forall (v:value) (A B:typ) (v1 v2:value),
     TypedReduce v A v1 ->
     TypedReduce v B v2 ->
     TypedReduce v (t_and A B) (v_merge v1 v2)
with step : exp -> exp -> Prop :=    (* defn step *)
 | Step_abs : forall (e:exp) (A B:typ),
     lc_exp (e_abs e A B) ->
     step (e_abs e A B) (e_val (v_absv e A B))
 | Step_beta : forall (e:exp) (A B:typ) (v v':value),
     lc_value (v_absv e A B) ->
     TypedReduce v A v' ->
     step (e_app  ( (e_val (v_absv e A B)) )  (e_val v)) (e_anno  (  (open_exp_wrt_exp  e (e_val v') )  )  B)
 | Step_annov : forall (v:value) (A:typ) (v':value),
     TypedReduce v A v' ->
     step (e_anno (e_val v) A) (e_val v')
 | Step_appl : forall (e1 e2 e1':exp),
     lc_exp e2 ->
     step e1 e1' ->
     step (e_app e1 e2) (e_app e1' e2)
 | Step_appr : forall (v1:value) (e2 e2':exp),
     lc_value v1 ->
     step e2 e2' ->
     step (e_app (e_val v1) e2) (e_app (e_val v1) e2')
 | Step_mergel : forall (e1 e2 e1':exp),
     lc_exp e2 ->
     step e1 e1' ->
     step (e_merge e1 e2) (e_merge e1' e2)
 | Step_merger : forall (v1:value) (e2 e2':exp),
     lc_value v1 ->
     step e2 e2' ->
     step (e_merge (e_val v1) e2) (e_merge (e_val v1) e2')
 | Step_anno : forall (e:exp) (A:typ) (e':exp),
     step e e' ->
     step (e_anno e A) (e_anno e' A)
 | Step_mergev : forall (v1 v2:value),
     lc_value v1 ->
     lc_value v2 ->
     step (e_merge (e_val v1) (e_val v2)) (e_val (v_merge v1 v2))
 | Step_litv : forall (i5:i),
     step (e_lit i5) (e_val (v_lit i5))
 | Step_topv :
     step e_top (e_val v_top)
 | Step_fix : forall (e:exp) (A:typ),
     lc_exp (e_fixpoint e A) ->
     step (e_fixpoint e A)  (open_exp_wrt_exp  e (e_fixpoint e A) ) .

Definition disjointSpec A B :=
  forall C, sub A C -> sub B C -> topLike C.

Definition consistencySpec v1 v2 :=
  forall A v1' v2', ord A -> TypedReduce v1 A v1' -> TypedReduce v2 A v2' -> v1' = v2'.

(* defns Consistency *)
Inductive consistent : value -> value -> Prop :=    (* defn consistent *)
 | C_topL : forall (v:value),
     lc_value v ->
     consistent v_top v
 | C_topR : forall (v:value),
     lc_value v ->
     consistent v v_top
 | C_lit : forall (i5:i),
     consistent (v_lit i5) (v_lit i5)
 | C_absOne : forall (e:exp) (B C:typ),
     lc_value (v_absv e B C) ->
     consistent (v_absv e B C) (v_absv e B C)
 | C_litAbs : forall (i5:i) (e:exp) (B C:typ),
     lc_value (v_absv e B C) ->
     consistent (v_lit i5) (v_absv e B C)
 | C_absLit : forall (e:exp) (B C:typ) (i5:i),
     lc_value (v_absv e B C) ->
     consistent (v_absv e B C) (v_lit i5)
 | C_mergeL : forall (v1 v2 v:value),
     consistent v1 v ->
     consistent v2 v ->
     consistent (v_merge v1 v2) v
 | C_mergeR : forall (v v1 v2:value),
     consistent v v1 ->
     consistent v v2 ->
     consistent v (v_merge v1 v2).

(* defns Typing *)
Inductive Etyping : ctx -> exp -> typ -> Prop :=    (* defn Etyping *)
 | Etyp_val : forall (G:ctx) (v:value) (A:typ),
      uniq  G  ->
     Vtyping v A ->
     Etyping G (e_val v) A
 | Etyp_top : forall (G:ctx),
      uniq  G  ->
     Etyping G e_top t_top
 | Etyp_lit : forall (G:ctx) (i5:i),
      uniq  G  ->
     Etyping G (e_lit i5) t_int
 | Etyp_var : forall (G:ctx) (x:var) (A:typ),
      uniq  G  ->
      binds  x A G  ->
     Etyping G (e_var_f x) A
 | Etyp_abs : forall (L:vars) (G:ctx) (e:exp) (A D C B:typ),
      ( forall x , x \notin  L  -> Etyping  (cons ( x , A )  G )   ( open_exp_wrt_exp e (e_var_f x) )  B )  ->
     sub B D ->
     sub C A ->
     Etyping G  ( (e_abs e A D) )   (t_arrow C D)
 | Etyp_app : forall (G:ctx) (e1 e2:exp) (B A:typ),
     Etyping G e2 A ->
     Etyping G e1 (t_arrow A B) ->
     Etyping G (e_app e1 e2) B
 | Etyp_merge : forall (G:ctx) (e1 e2:exp) (A B:typ),
     Etyping G e1 A ->
     Etyping G e2 B ->
      disjointSpec A B  ->
     Etyping G (e_merge e1 e2) (t_and A B)
 | Etyp_anno : forall (G:ctx) (e:exp) (A B:typ),
     Etyping G e B ->
     sub B A ->
     Etyping G  ( (e_anno e A) )  A
 | Etyp_fix : forall (L:vars) (G:ctx) (e:exp) (A:typ),
      ( forall x , x \notin  L  -> Etyping  (cons ( x , A )  G )   ( open_exp_wrt_exp e (e_var_f x) )  A )  ->
     Etyping G  ( (e_fixpoint e A) )  A
with Vtyping : value -> typ -> Prop :=    (* defn Vtyping *)
 | Vtyp_top :
     Vtyping v_top t_top
 | Vtyp_topv : forall (v:value) (A:typ),
     Vtyping v A ->
     Vtyping  ( (v_topv v) )  t_top
 | Vtyp_lit : forall (i5:i),
     Vtyping (v_lit i5) t_int
 | Vtyp_absv : forall (L:vars) (e:exp) (A D C B:typ),
      ( forall x , x \notin  L  -> Etyping  (cons ( x , A )   nil  )   ( open_exp_wrt_exp e (e_var_f x) )  B )  ->
     sub B D ->
     sub C A ->
     Vtyping  ( (v_absv e A D) )   (t_arrow C D)
 | Vtyp_merge : forall (v1 v2:value) (A B:typ),
     Vtyping v1 A ->
     Vtyping v2 B ->
      consistencySpec v1 v2  ->
     Vtyping (v_merge v1 v2) (t_and A B).

(* defns DValue *)
Inductive DValue : dexp -> Prop :=    (* defn DValue *)
 | DVal_var : forall (x:var),
     DValue (de_var_f x)
 | DVal_top :
     DValue de_top
 | DVal_nat : forall (i5:i),
     DValue (de_lit i5)
 | DVal_abs : forall (ee:dexp),
     lc_dexp (de_abs ee) ->
     DValue (de_abs ee)
 | DVal_merge : forall (vv1 vv2:dexp),
     DValue vv1 ->
     DValue vv2 ->
     DValue (de_merge vv1 vv2).

(* defns DSemantics *)
Inductive DunfieldStep : dexp -> dexp -> Prop :=    (* defn DunfieldStep *)
 | DStep_appl : forall (ee1 ee2 ee1':dexp),
     lc_dexp ee2 ->
     DunfieldStep ee1 ee1' ->
     DunfieldStep (de_app ee1 ee2) (de_app ee1' ee2)
 | DStep_appr : forall (vv1 ee2 ee2':dexp),
     DValue vv1 ->
     DunfieldStep ee2 ee2' ->
     DunfieldStep (de_app vv1 ee2) (de_app vv1 ee2')
 | DStep_beta : forall (ee vv:dexp),
     lc_dexp (de_abs ee) ->
     DValue vv ->
     DunfieldStep (de_app  ( (de_abs ee) )  vv)  (  (open_dexp_wrt_dexp  ee vv )  )
 | DStep_fix : forall (ee:dexp),
     lc_dexp (de_fixpoint ee) ->
     DunfieldStep (de_fixpoint ee)  (open_dexp_wrt_dexp  ee (de_fixpoint ee) )
 | DStep_unmergel : forall (ee1 ee2:dexp),
     lc_dexp ee2 ->
     lc_dexp ee1 ->
     DunfieldStep (de_merge ee1 ee2) ee1
 | DStep_unmerger : forall (ee1 ee2:dexp),
     lc_dexp ee1 ->
     lc_dexp ee2 ->
     DunfieldStep (de_merge ee1 ee2) ee2
 | DStep_mergel : forall (ee1 ee2 ee1':dexp),
     lc_dexp ee2 ->
     DunfieldStep ee1 ee1' ->
     DunfieldStep (de_merge ee1 ee2) (de_merge ee1' ee2)
 | DStep_merger : forall (vv1 ee2 ee2':dexp),
     DValue vv1 ->
     DunfieldStep ee2 ee2' ->
     DunfieldStep (de_merge vv1 ee2) (de_merge vv1 ee2')
 | DStep_split : forall (ee:dexp),
     lc_dexp ee ->
     DunfieldStep ee (de_merge ee ee).

(* defns WellformedType *)
Inductive WF : ctx -> typ -> Prop :=    (* defn WF *)
 | Wf_int : forall (G:ctx),
     WF G t_int
 | Wf_top : forall (G:ctx),
     WF G t_top
 | Wf_arr : forall (G:ctx) (A B:typ),
     WF G A ->
     WF G B ->
     WF G (t_arrow A B)
 | Wf_and : forall (G:ctx) (A B:typ),
     WF G A ->
     WF G B ->
      disjointSpec A B  ->
     WF G (t_and A B).

(* defns ISubtyping *)
Inductive isub : typ -> typ -> Prop :=    (* defn isub *)
 | IS_z :
     isub t_int t_int
 | IS_top : forall (A:typ),
     isub A t_top
 | IS_arr : forall (A1 A2 B1 B2:typ),
     isub B1 A1 ->
     isub A2 B2 ->
     isub (t_arrow A1 A2) (t_arrow B1 B2)
 | IS_andl1 : forall (A1 A2 A3:typ),
     isub A1 A3 ->
     isub (t_and A1 A2) A3
 | IS_andl2 : forall (A1 A2 A3:typ),
     isub A2 A3 ->
     isub (t_and A1 A2) A3
 | IS_andr : forall (A1 A2 A3:typ),
     isub A1 A2 ->
     isub A1 A3 ->
     isub A1 (t_and A2 A3).

(* defns ITyping *)
Inductive ITyping : ctx -> dexp -> typ -> exp -> Prop :=    (* defn ITyping *)
 | ITyp_top : forall (G:ctx),
      uniq  G  ->
     ITyping G de_top t_top e_top
 | ITyp_lit : forall (G:ctx) (i5:i),
      uniq  G  ->
     ITyping G (de_lit i5) t_int (e_lit i5)
 | ITyp_var : forall (G:ctx) (x:var) (A:typ),
      uniq  G  ->
      binds  x A G  ->
     ITyping G (de_var_f x) A (e_var_f x)
 | ITyp_lam : forall (L:vars) (G:ctx) (ee:dexp) (A B:typ) (e:exp),
     WF G A ->
      ( forall x , x \notin  L  -> ITyping  (cons ( x , A )  G )   ( open_dexp_wrt_dexp ee (de_var_f x) )  B  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     ITyping G  ( (de_abs ee) )  (t_arrow A B) (e_abs e A B)
 | ITyp_app : forall (G:ctx) (ee1 ee2:dexp) (B:typ) (e1 e2:exp) (A:typ),
     ITyping G ee1 (t_arrow A B) e1 ->
     ITyping G ee2 A e2 ->
     ITyping G (de_app ee1 ee2) B (e_app e1 e2)
 | ITyp_merge : forall (G:ctx) (ee1 ee2:dexp) (A B:typ) (e1 e2:exp),
     ITyping G ee1 A e1 ->
     ITyping G ee2 B e2 ->
      disjointSpec A B  ->
     ITyping G (de_merge ee1 ee2) (t_and A B) (e_merge e1 e2)
 | ITyp_sub : forall (G:ctx) (ee:dexp) (B:typ) (e:exp) (A:typ),
     ITyping G ee A e ->
     isub A B ->
     ITyping G ee B (e_anno e B).

(** infrastructure *)
Hint Constructors topLike ord disjoint sub TypedReduce step consistent Etyping Vtyping DValue DunfieldStep WF isub ITyping lc_dexp lc_value lc_exp.


Require Import
        Essentials.Facts_Tactics
        Essentials.Notations
        Essentials.Types.
Require Import Metrics.Mappings.
Require Import Metrics.Complete_UltraMetric.
Require Import Categories.Category.Main.
Require Import MCat.MCat.

Local Open Scope order_scope.
Local Open Scope metric_scope.
Local Open Scope lattice_scope.

Section MCat_Op.
  Context {L : MLattice} (M : MCat L).

  (** Opposite of an M-categories is an M-category. *)
  Program Definition MCat_Op : MCat L :=
    {|
      MC_Obj := M;
      MC_Hom :=
        fun A B => MC_Hom M B A;
      MC_compose :=
        fun a b c =>
          {|
            NE_fun :=
              fun w =>
                MC_compose M ((snd w), (fst w))
          |};
      MC_id := fun _ => MC_id M
    |}.

  Local Ltac lub2ub t :=
    eapply PO_Trans;
    [|apply (lub_ub _ _ t)].

  Next Obligation.
  Proof.
    eapply PO_Trans; [apply NE_non_expansive|].
    apply lub_lst;
      intros [];
      [lub2ub false| lub2ub true]; trivial.
  Qed.

  Next Obligation.
  Proof.
    apply (MC_assoc_sym M).
  Defined.

  Next Obligation.
  Proof.
    apply (MC_assoc M).
  Defined.

  Next Obligation.
  Proof.
    apply (MC_id_unit_right M).
  Defined.

  Next Obligation.
  Proof.
    apply (MC_id_unit_left M).
  Defined.

End MCat_Op.

(** The underlying category of the opposite of an M-category is just
the opposit of the underlying category of that M-category. *)
Goal (∀ L (M : MCat L), (M^op)%category = (@MCat_Op L M)).
  exact (fun _ _ => eq_refl).
Abort.