Require Import ZArith.
Require Import Arith.Even.
Require Import ZArith.Int.
Require Import Logic.Eqdep.
Require Import Logic.FunctionalExtensionality.
Require Import Bool.Bool.
Require Import Lia.
Require Import List.
Require Import Util.
Require Import Group.
Require Import LinearLogic.
Require Import AsynchronousGames.
Require Import Strategy.
Require Import Dual.
Require Import Lifting.
Require Import Tensor.
Require Import Sum.
Require Import Exponential.
Require Import Conversion.

 Fact unfold_dual:
    forall AG XG YG actionG,
      dual {|
          A := AG;
          X := XG;
          Y := YG;
          action := actionG
        |} =
      {|
        A := asynchronous_arena_dual AG;
        X := Group.opposite_group YG;
        Y := Group.opposite_group XG;
        action := fun g m h => actionG h m g
      |}.
  Proof.
    intros.
    unfold dual; simpl.
    reflexivity.
  Qed.

Theorem zero_has_no_winning_strategy :
not (exists (s : Strategy ZERO), winning _ s).
Proof. unfold not. intros. destruct H. unfold winning in H.
destruct H. destruct H. assert (positive ZERO). unfold positive. simpl. auto.
assert (x nil <> None).
{apply H. auto. simpl. unfold valid_alternating_play. unfold valid_alternating_play. split.
- unfold valid_alternating_play. split.
+ apply NoDup_nil.
+ intros. destruct m. destruct x0.
- unfold alternating_play. intros. unfold nth_error_from_back in H3.
simpl in H3. destruct H3. inversion H4.
- simpl. apply even_O. }
destruct (x nil).
+ destruct m. destruct x0.
+ contradiction H3. auto.
Qed.

Fact top_has_winning_strategy :
(exists (s : Strategy TOP), winning _ s).
Proof. refine (ex_intro _ (fun _ => None) _). unfold winning. split.
+ unfold strategy_is_total. unfold positive. unfold negative. simpl. split.
++ intros. inversion H.
++ intros. assert (exists x xs, p = x :: xs).
{destruct p.
+ inversion H1.
+ refine (ex_intro _ m _). refine (ex_intro _ p _). auto. }
destruct H2. destruct x. destruct x.
+ split.
++ unfold strategy_preserves_validity. intros. destruct k. destruct x.
++ split.
+++ intros. destruct p.
++++ simpl. apply Z.leb_le. lia.
++++ destruct m. destruct x.
+++ split.
++++ intros. destruct (f 0). destruct x.
++++ intros. destruct w. destruct p. destruct p0.
destruct p.
+++++ destruct l.
++++++ destruct p0.
+++++++ destruct l0.
++++++++ simpl. apply Z.leb_le. lia.
++++++++ destruct m. destruct x.
+++++++ destruct m. destruct x.
++++++ destruct m. destruct x.
+++++ destruct m. destruct x.
Qed.

Fact one_has_a_winning_strategy :
(exists (s : Strategy ONE), winning _ s).
Proof. remember
((fun l =>
match l with
| nil => Some (existT _ tt (inl tt))
| _ => None
end) : Strategy ONE) as sigma.
refine (ex_intro _ sigma _).
assert (strategy_is_total _ sigma).
{unfold strategy_is_total. split.
++ unfold positive. simpl. intros. destruct p.
+++ subst. easy.
+++ inversion H1. subst.
assert (exists k xs, p = k :: xs).
{destruct p.
+ inversion H3.
+ refine (ex_intro _ m0 _). refine (ex_intro _ p _). auto. }
destruct H2. destruct H2. subst.
assert (m <> x).
{unfold not. intros. subst. unfold valid_alternating_play in H0. destruct H0.
unfold valid_alternating_play in H0. destruct H0. inversion H0. contradiction H7. left. auto. }
destruct m. destruct x1. destruct s.
++++ destruct x. destruct x. destruct s.
+++++ destruct u. destruct u0. contradiction H2. auto.
+++++ destruct n. destruct x.
++++ destruct n. destruct x1.
++ intros. unfold negative in H. simpl in H. inversion H. }
assert (~ strategy_induces_play ONE sigma nil).
{unfold not. intros.
unfold strategy_induces_play in H0. unfold positive in *. unfold negative in *.
simpl negative in *. simpl positive_or_negative in *.
assert (sigma (lastn 0 nil) =
      nth_error_from_back nil 0).
{destruct H0. apply H0. auto. split.
+ apply even_O.
+ lia. } unfold lastn in H1. unfold nth_error_from_back in H1. simpl in H1.
subst. inversion H1. }
unfold winning. split.
+ apply H.
+ split.
++ unfold strategy_preserves_validity. intros. destruct H1. destruct H2. subst.
inversion H3.
++ split.
+++ intros. simpl. destruct p.
++++ contradiction H0.
++++ destruct m. destruct x. destruct s.
+++++ destruct u. destruct p.
++++++ apply Z.leb_le. lia.
++++++ apply Z.leb_le. lia.
+++++ apply Z.leb_le. lia.
+++ split.
++++ intros. unfold valid_alternating_infinite_play in H1. destruct n.
+++++ simpl finite_part in *. contradiction H0.
+++++ simpl finite_part in *. destruct n.
++++++ simpl in *. destruct (f 0). destruct x. destruct s.
+++++++ destruct u. apply Z.leb_le; lia.
+++++++ apply Z.leb_le; lia.
++++++ simpl finite_part in *.
assert (valid_play (E (A ONE))
       (finite_part (M (partial_order_lifting zero_partial_order)) f 2 0)).
{apply H1. }
simpl finite_part in *. unfold valid_play in H3. destruct H3.
assert (f 0 <> f 1).
{unfold not. intros. rewrite H5 in H3. inversion H3. contradiction H8. left. auto. }
destruct (f 0). destruct x. destruct s.
+++++++ destruct u. destruct (f 1).
++++++++ destruct x. destruct s.
+++++++++ destruct u. contradiction H5. auto.
+++++++++ destruct n0. destruct x.
+++++++ destruct n0. destruct x.
++++ intros. destruct w. destruct p. destruct p0. destruct p.
+++++ destruct l.
++++++ destruct l0.
+++++++ simpl. apply Z.leb_le. lia.
+++++++ simpl. apply Z.leb_le. lia.
++++++ simpl. apply Z.leb_le. lia.
+++++ simpl. destruct l.
++++++ destruct p0.
+++++++ destruct l0.
++++++++ apply Z.leb_le. lia.
++++++++ apply Z.leb_le. lia.
+++++++ destruct l0.
++++++++ apply Z.leb_le. lia.
++++++++ apply Z.leb_le. lia.
++++++ destruct p0.
+++++++ apply Z.leb_le. lia.
+++++++ apply Z.leb_le. lia.
Qed.

Theorem bottom_has_no_winning_strategy :
not (exists (s : Strategy BOTTOM), winning _ s).
Proof. unfold not. intros. destruct H. unfold winning in H.
destruct H. unfold strategy_is_total in H. unfold positive in *.
unfold negative in *. simpl positive_or_negative in *. destruct H.
assert (valid_alternating_play (A (BOTTOM)) ((existT _ tt (inl tt)) :: nil)).
{unfold valid_alternating_play. split.
- unfold valid_alternating_play. split.
+ apply NoDup_cons.
++ auto.
++ apply NoDup_nil.
+ split.
++ intros. destruct m. destruct n. destruct H2. destruct H3.
simpl in H3. destruct x0. unfold nth_error_from_back in H2.
simpl in H2.
assert (a < length ((existT
          (fun _ : unit => (unit + M zero_partial_order)%type)
          tt (inl tt) :: nil))).
{apply nth_error_Some. unfold not. intros.
assert (forall A (a b c : A), a = b /\ b = c -> a = c).
{intros. destruct H6. subst. auto. }
assert (Some (existT (fun _ : unit => (unit + M zero_partial_order)%type) x1 s0)
= None).
{apply H6 with (b:= (nth_error
       (existT
          (fun _ : unit =>
           (unit + M zero_partial_order)%type)
          tt (inl tt) :: nil) a)). auto. } inversion H7. }
simpl in H5. assert (a = 0). {lia. } subst. simpl in H2. inversion H2.
subst. destruct s.
+++ destruct u. contradiction H4. auto.
+++ contradiction H3.
++ intros. destruct H2. simpl in H2. simpl in H3. destruct H2.
+++ destruct H3.
++++ subst. simpl. auto.
++++ contradiction H3.
+++ contradiction H2.
- unfold alternating_play. intros. unfold nth_error_from_back in H2. destruct k.
+ simpl in H2. destruct H2. inversion H3.
+ simpl in H2. destruct H2. inversion H3. }
destruct H0.
assert (x (existT
          (fun i : I (P (E (A BOTTOM))) =>
           (unit + N (P (E (A BOTTOM))) i)%type) tt
          (inl tt) :: nil) <> None).
{apply H1. auto. auto. simpl. apply odd_S. apply even_O. }
assert (strategy_induces_play BOTTOM x nil).
{unfold strategy_induces_play. unfold positive. unfold negative.
simpl. split.
+ intros. inversion H5.
+ intros. destruct H6. assert (n = 0). {lia. } subst. inversion H6. }
unfold strategy_preserves_validity in H0. destruct
(x
       (existT
          (fun i : I (P (E (A BOTTOM))) =>
           (unit + N (P (E (A BOTTOM))) i)%type) tt
          (inl tt) :: nil)) eqn:eqn1.
+
assert (valid_play (E (A BOTTOM)) (m :: (existT
            (fun i : I (P (E (A BOTTOM))) =>
             (unit + N (P (E (A BOTTOM))) i)%type) tt
            (inl tt) :: nil))).
{apply H0. auto. }
unfold valid_alternating_play in H6. destruct H6.
assert (m <> existT
             (fun i : I (P (E (A BOTTOM))) =>
              (unit + N (P (E (A BOTTOM))) i)%type) tt
             (inl tt)).
{unfold not. intros. subst. inversion H6. contradiction H10.
simpl. left. auto. }
destruct m. destruct x0. destruct s.
++ destruct u. contradiction H8. auto.
++ destruct n. destruct x0.
+ contradiction H4. auto.
Qed.

Fact conversion_is_sound :
forall (l : sequent) (f : interpretation),
(forall s, well_formed_asynchronousgame (convert (prop_variable s) f)) ->
valid l -> exists (s : Strategy (interpret l f)),
winning _ s /\ innocent _ s /\ uniform _ s.
- intros. assert (True). {auto. } induction H0.
+ subst. simpl. unfold interpret. simpl. unfold game_par.
destruct (f s) eqn:ORIG. rewrite unfold_dual. unfold tensor.
remember ({|
                  A := asynchronous_arena_dual A;
                  X := opposite_group Y;
                  Y := opposite_group X;
                  action := fun (g : G (opposite_group Y))
                              (m : M (P (E (asynchronous_arena_dual A))))
                              (h : G (opposite_group X)) => action h m g |}).
simpl.
assert (well_formed_asynchronousgame a) as a_well_formed.
{admit. }
destruct (positive_or_negative (AsynchronousGames.A a)) eqn:eqn1.
++ simpl.
assert (well_formed_asynchronousgame
 (dual (asynchronous_game_tensor_positive a (lifting (dual a) 1 true)))) as G_well_formed.
{admit. }
remember ((fun x => match x with
                        | existT _ i (inl tt) =>
                         (existT _ i (inr (inr  (existT _ (fst i) (inl tt))   )))
                        | existT _ i (inr (inl m)) =>
                         (existT _ i (inr (inr  (existT _ (fst i) (inr m))   )))
                        | existT _ i (inr (inr (existT _ _ (inl tt) )))  =>
                         (existT _ i (inl tt))
                        | existT _ _ (inr (inr (existT _ j (inr m) ))) =>
                         (existT _ (j,tt) (inr (inl m)))
                    end)
: M (P (E (AsynchronousGames.A (dual (asynchronous_game_tensor_positive a (lifting (dual a) 1 true)))))) ->
M (P (E (AsynchronousGames.A (dual (asynchronous_game_tensor_positive a (lifting (dual a) 1 true))))))
) as copy_move.
assert (forall i m n,
~ (incompatible (E (AsynchronousGames.A (dual (asynchronous_game_tensor_positive a (lifting (dual a) 1 true)))))
 (existT _ i (inr (inr m))) (existT _ i (inr (inr n))) ) ->
~(incompatible (E (AsynchronousGames.A a)) m n)) as INCOMP.
{ intros. unfold not. intros. contradiction H0. simpl.
apply incomp_tensor_right with (index:=i) (m:=m) (m':=n). simpl. destruct i. destruct i0. simpl. auto. auto. auto. }
assert (forall a b, (~incompatible _ a b /\ copy_move a = copy_move b) -> a = b) as copy_injective.
{intros. destruct H0. rewrite Heqcopy_move in H2. destruct a0 eqn:eqna0. destruct x. destruct i0.
destruct b eqn:eqnb. destruct x. destruct i1. destruct s0.
+ destruct u. destruct s1.
++ destruct u. inversion H2. auto.
++ destruct n.
+++ inversion H2.
+++ destruct n.
++++ destruct s0.
+++++ destruct u. inversion H2.
+++++ inversion H2.
+ destruct s1.
++ destruct u. destruct n.
+++ inversion H2.
+++ destruct n.
++++ destruct s0.
+++++ destruct u. inversion H2.
+++++ inversion H2.
++ destruct n.
+++ destruct n0.
++++ inversion H2. subst i. apply inj_pairT2 in H6.
subst n. auto.
++++ destruct n0.
+++++ destruct s0.
++++++ destruct u. inversion H2.
++++++ inversion H2.
+++ destruct n.
++++ destruct n0.
+++++ destruct s0.
++++++ destruct u. inversion H2.
++++++ inversion H2.
+++++ destruct s0.
++++++ destruct u. destruct n. destruct s0.
+++++++ destruct u. inversion H2. subst i.
assert (~ incompatible _
(existT
           (fun i : I (P (E (AsynchronousGames.A (dual a)))) =>
            (unit + N (P (E (AsynchronousGames.A (dual a)))) i)%type)
           x (inl tt))
(existT
           (fun i : I (P (E (AsynchronousGames.A (dual a)))) =>
            (unit + N (P (E (AsynchronousGames.A (dual a)))) i)%type)
           x0 (inl tt))).
{simpl. apply INCOMP with (m:=(existT
           (fun i : I (P (E (AsynchronousGames.A (dual a)))) =>
            (unit + N (P (E (AsynchronousGames.A (dual a)))) i)%type)
           x (inl tt)))
(n:=(existT
           (fun i : I (P (E (AsynchronousGames.A (dual a)))) =>
            (unit + N (P (E (AsynchronousGames.A (dual a)))) i)%type)
           x0 (inl tt))) (i:=(i0,tt)). auto. }
assert (x=x0).
{destruct a_well_formed. destruct H4. destruct H4. destruct H7. destruct H8.
destruct H9. destruct H10. unfold compatible_same_component in H11. apply H11 with
(m:=inl tt) (m':=inl tt). auto. }
subst x. auto.
+++++++ inversion H2.
++++++ destruct n. destruct s0.
+++++++ destruct u. inversion H2.
+++++++ inversion H2. subst x. apply inj_pairT2 in H2. inversion H2. auto. subst n.
assert ((i,tt)=(i0,tt)).
{destruct G_well_formed. destruct H3. destruct H3.
destruct H6. destruct H7. destruct H8. destruct H9. unfold compatible_same_component in H10.
apply H10 with (i:=(i,tt)) (i':=(i0,tt)) (m:=(inr
             (inr
                (existT
                   (fun i : I (P (E (AsynchronousGames.A (dual a)))) =>
                    (unit + N (P (E (AsynchronousGames.A (dual a)))) i)%type) x0
                   (inr n0)))))
(m':= (inr
            (inr
               (existT
                  (fun i : I (P (E (AsynchronousGames.A (dual a)))) =>
                   (unit + N (P (E (AsynchronousGames.A (dual a)))) i)%type) x0
                  (inr n0))))). auto. }
inversion H3. subst i. auto. }
remember ((fun l =>
match l with
| nil => None
| x :: xs => Some (copy_move x)
end) : Strategy (dual (asynchronous_game_tensor_positive a (lifting (dual a) 1 true)))) as copycat.
refine (ex_intro _ copycat _). split.
+++ unfold winning.
assert (strategy_is_total _ copycat).
{ unfold strategy_is_total. split.
+ intros. unfold positive in H0. simpl in H0. inversion H0.
+ intros.
assert (exists k xs, p = k :: xs).
{destruct p.
+ inversion H3.
+ refine (ex_intro _ m _). refine (ex_intro _ p _). auto. }
destruct H4. destruct H4. subst. simpl. destruct x. destruct s0.
++ destruct u. easy.
++ destruct n; easy. }
assert (forall p, strategy_induces_play _ copycat p ->
valid_alternating_play _ p ->
(forall n, (odd n /\ n < length p) -> (exists k,
nth_error_from_back p (n-1) = Some k /\
nth_error_from_back p n = Some (copy_move k)))).
{ remember (fun p => strategy_induces_play _ copycat p ->
valid_alternating_play _ p ->
(forall n, (odd n /\ n < length p) -> (exists k,
nth_error_from_back p (n-1) = Some k /\
nth_error_from_back p n = Some (copy_move k)))) as P.
assert (P nil).
{subst P. intros. destruct H4. simpl in H5. lia. }
assert (forall x y l, P l -> P (x :: y :: l)).
{subst P. intros. unfold nth_error_from_back. simpl. destruct H6.
rewrite <- app_assoc. simpl in H7.
assert (nth_error (rev l ++ (y :: nil) ++ x :: nil) (n - 1) <> None).
{apply nth_error_Some. simpl. rewrite app_length. rewrite rev_length.
simpl. simpl in H7. lia. }
assert (strategy_induces_play _ copycat l).
{apply strategy_closed_under_prefix with (x:=x) (y:=y).
+ auto.
+ auto.
+ auto.
 }
assert (valid_alternating_play _ (y :: l)).
{apply validity_closed_under_prefix with (m:=x). auto. }
assert (valid_alternating_play _ l).
{apply validity_closed_under_prefix with (m:=y). auto. }
assert (forall n : nat,
     odd n /\ n < length l ->
     exists k,
       nth_error_from_back l (n - 1) = Some k /\
       nth_error_from_back l n = Some (copy_move k)).
{apply H3. auto. auto. }
destruct (le_lt_dec (length l) n).
+ assert (n = length l \/ n = length l + 1).
{inversion l0.
+ left. auto.
+ subst n.
assert (forall a b, a < S b -> a <= b).
{intros. lia. }
assert (m <= length l). {apply H14. auto. }
assert (m = length l). {lia. } subst m. right. lia. }
destruct H13.
++ subst n.
assert (strategy_is_total (dual
                 (asynchronous_game_tensor_positive a
                    (lifting (dual a) 1 true))) copycat ->
(forall p, strategy_induces_play (dual
                 (asynchronous_game_tensor_positive a
                    (lifting (dual a) 1 true))) copycat p -> valid_alternating_play _ p ->
((positive (dual
                 (asynchronous_game_tensor_positive a
                    (lifting (dual a) 1 true))) -> odd (length p)) /\ (negative (dual
                 (asynchronous_game_tensor_positive a
                    (lifting (dual a) 1 true))) -> even (length p))))).
{apply induced_play_length. }
assert (even (length l)).
{apply H13.
+ auto.
+ auto.
+ auto.
+ unfold negative. simpl. auto. }
contradiction (not_even_and_odd (length l)).
++ subst n. simpl. assert (length l + 1 - 1 = length l). {lia. }
assert (nth_error (rev l ++ (y :: nil) ++ x :: nil) (length l) =
nth_error ((y :: nil) ++ x :: nil) (length l - length (rev l))).
{apply nth_error_app2. rewrite rev_length. auto. }
rewrite rev_length in H14. assert (length l - length l = 0). {lia. }
rewrite H15 in H14. simpl in H14.
assert (nth_error (rev l ++ (y :: nil) ++ x :: nil) (length l + 1) =
nth_error ((y :: nil) ++ x :: nil) ((length l + 1) - length (rev l))).
{apply nth_error_app2. rewrite rev_length. auto. }
rewrite rev_length in H16. assert (length l + 1 - length l = 1). {lia. }
rewrite H17 in H16. simpl in H16. refine (ex_intro _ y _). split.
+++ rewrite <- H14. auto.
+++ assert (H18:=H4). unfold strategy_induces_play in H18. unfold negative in *.
unfold positive in *. simpl positive_or_negative in *. destruct H18.
unfold lastn in H19. unfold nth_error_from_back in H19. simpl in H19.
rewrite <- app_assoc in H19.
assert (copycat (rev (firstn (length l + 1) (rev l ++ (y :: nil) ++ x :: nil))) =
      nth_error (rev l ++ (y :: nil) ++ x :: nil) (length l + 1)).
{apply H19. auto. split.
+ auto.
+ lia. }
assert (firstn (length l + 1) ((rev l ++ (y :: nil)) ++ x :: nil) =
firstn (length l + 1) (rev l ++ (y :: nil))).
{apply firstn_app. rewrite app_length. rewrite rev_length. simpl. lia. }
rewrite <- app_assoc in H21. rewrite H21 in H20.
assert (firstn (length l + 1) (rev l ++ y :: nil) = (rev l ++ y :: nil)).
{apply firstn_all2. rewrite app_length. rewrite rev_length. simpl. lia. }
rewrite H22 in H20. rewrite rev_unit in H20. rewrite rev_involutive in H20.
rewrite H16.
assert (forall A (a b c : A), a = b /\ b = c -> a = c).
{intros. destruct H23. subst a0. subst b. auto. }
assert (copycat (y :: l)  = Some x).
{apply H23 with (b:=nth_error (rev l ++ (y :: nil) ++ x :: nil) (length l + 1)).
auto. } subst copycat. auto.
+ assert (odd n /\ n < length l). {auto. }
apply H12 in H13. simpl in H13. unfold nth_error_from_back in H13.
destruct H13. refine (ex_intro _ x0 _). destruct H13. split.
++ rewrite <- H13. apply nth_error_app1. rewrite rev_length.
assert (forall a b, a < b -> a - 1 < b). {intros. lia. }
apply H15. auto.
++ rewrite <- H14. apply nth_error_app1. rewrite rev_length. auto. }
assert (forall l, even (length l) -> P l).
{apply even_length_list_induction. auto. }
subst P. intros. apply H4.
assert (strategy_is_total _ copycat ->
(forall p, strategy_induces_play _ copycat p -> valid_alternating_play _ p ->
((positive (dual
                (asynchronous_game_tensor_positive a
                   (lifting (dual a) 1 true))) -> odd (length p)) /\
(negative (dual
                (asynchronous_game_tensor_positive a
                   (lifting (dual a) 1 true))) -> even (length p))))).
{apply induced_play_length. }
apply H8. auto. auto. auto. unfold negative. simpl positive_or_negative.
auto. auto. auto. auto. }
assert (well_formed_asynchronousgame (convert (prop_variable s) f)).
{apply H. } simpl in H3. rewrite ORIG in H3.
unfold well_formed_asynchronousgame in H3. destruct H3.
unfold well_formed_asynchronous_arena in H3. destruct H3.
unfold well_formed_event_structure in H3. destruct H3.
unfold well_formed_partial_order in H3.
assert (forall k, polarity _ k = negb (polarity _ (copy_move k))).
{ intros. destruct k. destruct x. destruct i0.
assert (forall i, initial_move (P (E A))
  (existT (fun i0 : I (P (E A)) => (unit + N (P (E A)) i0)%type) i
     (inl tt))).
{ intros. apply initial_is_unit. auto. refine (ex_intro _ i0 _). auto. }
destruct s0.
+ destruct u. rewrite Heqcopy_move. simpl. subst a. simpl.
rewrite negb_involutive.
rewrite negb_involutive. simpl in eqn1. apply negb_true_iff in eqn1.
assert (initial_move (P (E A))
  (existT (fun i0 : I (P (E A)) => (unit + N (P (E A)) i0)%type) i
     (inl tt))).
{apply H7. }
destruct H5. unfold polarity_first in H5. apply H5 in H8.
destruct H8. destruct H9. destruct H11. unfold positive_iff_player_always_starts in H12.
simpl positive_or_negative in H12. rewrite eqn1 in H12. symmetry. apply H12. auto.
apply initial_is_unit. auto. subst. refine (ex_intro _ i _). auto.
+ destruct n.
++ rewrite Heqcopy_move. simpl. rewrite negb_involutive. auto.
++ rewrite Heqcopy_move. simpl. destruct n.
+++ destruct s0.
++++ destruct u. rewrite negb_involutive. simpl. subst a. simpl.
assert (initial_move _ (existT
        (fun i0 : I (P (E A)) =>
         (unit + N (P (E A)) i0)%type) x
        (inl tt))).
{apply H7. }
destruct H5. unfold polarity_first in H5. apply H5 in H8.
destruct H8. destruct H9. destruct H10. destruct H11. unfold positive_iff_player_always_starts in H11.
simpl positive_or_negative in H11. simpl in eqn1. apply negb_true_iff in eqn1. rewrite eqn1 in H11. apply H11. auto.
apply H7. apply negb_true_iff. destruct H11.
unfold positive_iff_player_always_starts in H11.
simpl positive_or_negative in H11. simpl in eqn1. apply negb_true_iff in eqn1. rewrite eqn1 in H11. apply H11. auto.
apply H7.
++++ auto. }
assert (strategy_preserves_validity (dual (asynchronous_game_tensor_positive a (lifting (dual a) 1 true))) copycat).
{unfold strategy_preserves_validity. intros. destruct H8. destruct H9. unfold valid_alternating_play. split.
- unfold valid_play. split.
+ apply NoDup_cons. unfold not. intros. rewrite Heqcopycat in H10. inversion H10. subst m. destruct H11.
++ destruct k. destruct x. destruct i0. destruct s0.
+++ destruct u. subst copy_move. inversion H11.
+++ destruct n.
++++ subst copy_move. inversion H11.
++++ subst copy_move. destruct n.
+++++ destruct s0.
++++++ destruct u. inversion H11.
++++++ inversion H11.
++ assert (exists n, nth_error p n = Some (copy_move k)).
{apply In_nth_error. auto. }
destruct H12.
assert (x < length p).
{apply nth_error_Some. rewrite H12. unfold not. intros. inversion H13. }
apply nth_error_from_back_formula in H13.
destruct (even_odd_dec x).
+++ assert (even (length p)).
{apply induced_play_length with
(sigma:=copycat). auto. auto. apply validity_closed_under_prefix with (m:=k). auto. unfold negative. subst a.
 simpl. auto. }
assert (x < length p).
{apply nth_error_Some. rewrite H12. unfold not. intros. inversion H15. }
assert (H16:=e). assert (H17:=H14). apply even_equiv in H16. apply even_equiv in H17.
unfold Nat.Even in H16, H17. destruct H16, H17.
assert (x1 - x0 > 0). {lia. }
assert (exists k, x1 - x0 = S k).
{destruct (x1 - x0).
+ lia.
+ refine (ex_intro _ n _). auto. }
destruct H19.
assert (length p - x - 1 = 2 * (x1 - x0) - 1). {lia. }
assert (2 * (x1 - x0) - 1 = 2 * x2 + 1). {lia. }
rewrite H21 in H20. rewrite H20 in H13. rewrite H12 in H13.
assert (odd (2 * x2 + 1)).
{apply odd_equiv. unfold Nat.Odd. refine (ex_intro _ x2 _). auto. }
assert (exists a, nth_error_from_back p ((2 * x2 + 1) - 1) = Some a /\
       nth_error_from_back p (2 * x2 + 1) = Some (copy_move a)).
{apply H2. auto. apply validity_closed_under_prefix with (m:=k). auto. split.
+ auto.
+ lia. }
destruct H23. destruct H23. rewrite <- H13 in H24. inversion H24.
rewrite H19 in H18.
assert (In x3 (rev p)).
{unfold nth_error_from_back in H23. apply nth_error_In with (n:=(2 * x2 + 1 - 1)). auto. }
apply in_rev in H25.
assert (In x3 (k :: p)).
{right. auto. }
assert (k = x3).
{apply copy_injective. split.
+ unfold valid_alternating_play in H9. destruct H9. unfold valid_play in H9. destruct H9. apply H29. split.
++ left. auto.
++ auto.
+ auto. } subst k. unfold valid_alternating_play in H9. destruct H9. unfold valid_play in H9. destruct H9.
inversion H9. subst x4. subst l. contradiction H32.
+++ rewrite H12 in H13.
assert (even (length p)).
{apply induced_play_length with
(sigma:=copycat). auto. auto. apply validity_closed_under_prefix with (m:=k). auto. unfold negative. subst a.
 simpl. auto. }
assert (x < length p).
{apply nth_error_Some. rewrite H12. unfold not. intros. inversion H15. }
apply even_equiv in H14. unfold Nat.Even in H14. destruct H14. apply odd_equiv in o. unfold Nat.Odd in o.
destruct o. subst x. rewrite H14 in H13.
assert (2 * x0 - (2 * x1 + 1) - 1 = 2 * (x0 - x1 - 1)).
{lia. }
rewrite H16 in H13.
assert (exists q, nth_error_from_back p 0 = Some q).
{destruct (nth_error_from_back p 0) eqn:eqn2.
+ refine (ex_intro _ m _). auto.
+ apply nth_error_None in eqn2. rewrite rev_length in eqn2. lia. }
destruct H17.
assert (initial_move _ x).
{apply valid_starting_player with (p:=p).
assert (valid_alternating_play _ p).
{apply validity_closed_under_prefix with (m:=k). auto. }
apply H18. auto. }
assert (H19:=G_well_formed). destruct H19. destruct H19. destruct H21. destruct H22. destruct H23.
unfold positive_iff_player_always_starts in H24. simpl positive_or_negative in H24.
assert (polarity _ x = false).
{apply H24. auto. auto. }
assert ((forall k m n, nth_error_from_back p 0 = Some m ->
nth_error_from_back p (2 * k) = Some n ->
polarity _ m = polarity _ n)).
{apply alternating_polarity.
assert (valid_alternating_play _ p).
{apply validity_closed_under_prefix with (m:=k). auto. }
apply H26. }
assert (polarity _ x = polarity _ (copy_move k)).
{apply H26 with (k:=(x0 - x1 - 1)). auto. auto. }
rewrite H25 in H27. symmetry in H27.
assert ((forall a m n, nth_error_from_back (k::p) 0 = Some m ->
nth_error_from_back (k::p) (2 * a) = Some n ->
polarity _ m = polarity _ n)).
{apply alternating_polarity. apply H9. }
assert (polarity _ x = polarity _ k).
{apply H28 with (a0:=x0).
+ unfold nth_error_from_back. simpl rev. rewrite nth_error_app1.
++ unfold nth_error_from_back in H17. simpl rev in H17. auto.
++ rewrite rev_length.
assert (0 < 2 * x1 + 1). {lia. }
assert (2 * x1 + 1 < length p). {lia. }
assert (forall a b c, a < b /\ b < c -> a < c).
{intros. lia. }
apply H31 with (b:=  2 * x1 + 1). auto.
+ unfold nth_error_from_back. simpl rev.
assert (nth_error (rev p ++ k :: nil) (2 * x0) =
nth_error (k::nil) ((2 * x0) - length (rev p))).
{apply nth_error_app2. rewrite rev_length. lia. }
rewrite rev_length in H29. rewrite H14 in H29.
assert (2 * x0 - 2 * x0 = 0). {lia. }
rewrite H30 in H29. simpl (nth_error (k :: nil) 0) in H29.
auto. }
rewrite H25 in H29. symmetry in H29. rewrite <- H27 in H29.
assert (polarity
        (AsynchronousGames.A
           (dual (asynchronous_game_tensor_positive a (lifting (dual a) 1 true)))) k =
      negb (polarity
        (AsynchronousGames.A
           (dual (asynchronous_game_tensor_positive a (lifting (dual a) 1 true))))
        (copy_move k))).
{apply H7. }
rewrite H29 in H30.
destruct (polarity
        (AsynchronousGames.A
           (dual
              (asynchronous_game_tensor_positive a
                 (lifting (dual a) 1 true)))) (copy_move k)); inversion H30.
++ unfold valid_alternating_play in H9. destruct H9. apply H9.
+ rewrite Heqcopycat in H10. inversion H10. subst m. intros. split.
++ intros. destruct H11.
assert (a0 < length (rev (copy_move k :: k :: p))).
{unfold nth_error_from_back in H11. apply nth_error_Some. rewrite H11. unfold not.
intros. inversion H13. }
simpl in H13. rewrite app_length in H13. rewrite app_length in H13. rewrite rev_length in H13.
simpl in H13.
destruct (le_lt_dec   a0 (length p)).
+++ unfold valid_alternating_play in H9. destruct H9. unfold valid_play in H9.
assert (forall a0 : nat,
       nth_error_from_back (k :: p) a0 = Some n /\
       leq (P (E (AsynchronousGames.A (dual (asynchronous_game_tensor_positive a (lifting (dual a) 1 true)))))) m n /\ m <> n ->
       exists b : nat, nth_error_from_back (k :: p) b = Some m /\ b < a0).
{apply H9. }
unfold nth_error_from_back in H11. simpl rev in H11.
assert (nth_error ((rev p ++ k :: nil) ++ copy_move k :: nil) a0 =
nth_error ((rev p ++ k :: nil)) a0).
{apply nth_error_app1. rewrite app_length. rewrite rev_length. simpl.
assert (forall a b, a <= b -> a < b + 1).
{intros. lia. }
apply H16. auto. }
assert (nth_error (rev p ++ k :: nil) a0 = Some n).
{transitivity (nth_error ((rev p ++ k :: nil) ++ copy_move k :: nil) a0). auto. auto. }
destruct H12.
assert (exists b : nat, nth_error_from_back (k :: p) b = Some m /\ b < a0).
{apply H15. auto. }
destruct H19. destruct H19. refine (ex_intro _ x _). split.
++++ unfold nth_error_from_back. unfold nth_error_from_back in H19. simpl rev in H19. simpl rev.
assert (nth_error ((rev p ++ k :: nil) ++ copy_move k :: nil) x =
nth_error ((rev p ++ k :: nil)) x).
{apply nth_error_app1. rewrite app_length. rewrite rev_length. simpl. lia. }
transitivity (nth_error (rev p ++ k :: nil) x). auto. auto.
++++ auto.
+++ assert (a0 = length p + 1). {
assert (forall a b, a < b + 1 + 1 /\ b < a -> a = b + 1).
{intros. lia. }
apply H14. auto. } subst a0.
unfold nth_error_from_back in H11. simpl rev in H11.
assert (nth_error ((rev p ++ k :: nil) ++ copy_move k :: nil)
        (length p + 1) =
nth_error (copy_move k :: nil)
        (length p + 1 - (length ((rev p ++ k :: nil))))).
{apply nth_error_app2. rewrite app_length. rewrite rev_length. simpl. lia. }
assert (nth_error (copy_move k :: nil)
        (length p + 1 - length (rev p ++ k :: nil)) = Some (copy_move k)).
{assert ((length p + 1 - length (rev p ++ k :: nil)) = 0).
{rewrite app_length. rewrite rev_length. simpl. lia. }
rewrite H15. simpl. auto. }
assert (Some n = Some (copy_move k)).
{transitivity (nth_error ((rev p ++ k :: nil) ++ copy_move k :: nil)
        (length p + 1)). auto.
transitivity (nth_error (copy_move k :: nil)
        (length p + 1 - length (rev p ++ k :: nil))). auto. auto. }
inversion H16. subst n. simpl in H12. destruct H12. (* admit. *)
++++ inversion H12. subst m. destruct k. rewrite Heqcopy_move in H20. destruct s0.
+++++ destruct u. inversion H20. subst x. admit.
+++++ simpl. destruct n.
++++++ inversion H20. subst x. admit.
++++++ destruct n. destruct s0.
+++++++ destruct u. inversion H20. subst x. simpl. rewrite Heqcopy_move in *. admit.
+++++++ inversion H20. subst i. subst j. apply inj_pairT2 in H20. subst m0. rewrite Heqcopy_move in *.

++ admit.
- rewrite Heqcopycat in H10. inversion H10. subst m. unfold alternating_play. intros.
destruct p.
+ unfold nth_error_from_back in H11. simpl in H11. destruct H11. destruct k0.
++ simpl in H11. simpl in H12. inversion H11. inversion H12. subst k.
assert ((polarity
     (AsynchronousGames.A
        (dual
           (asynchronous_game_tensor_positive a (lifting (dual a) 1 true))))
     m) =
negb (polarity
  (AsynchronousGames.A
     (dual (asynchronous_game_tensor_positive a (lifting (dual a) 1 true))))
  (copy_move m))).
{apply H7. } rewrite H13. rewrite negb_involutive. auto.
++ simpl in H12. destruct k0; inversion H12.
+ destruct (le_lt_dec k0 (length (k :: m0 :: p) - 2)).
simpl in l. unfold valid_alternating_play in H9. destruct H9. unfold alternating_play in H12.
unfold nth_error_from_back in H11. simpl rev in H11.
assert (nth_error (((rev p ++ m0 :: nil) ++ k :: nil) ++ copy_move k :: nil) k0 =
nth_error ((rev p ++ m0 :: nil) ++ k :: nil) k0).
{apply nth_error_app1. rewrite app_length. rewrite app_length. rewrite rev_length. simpl. lia. }
destruct H11.
assert (nth_error (((rev p ++ m0 :: nil) ++ k :: nil) ++ copy_move k :: nil) (S k0) =
nth_error ((rev p ++ m0 :: nil) ++ k :: nil) (S k0)).
{apply nth_error_app1. rewrite app_length. rewrite app_length. rewrite rev_length. simpl. lia. }
assert (forall A (a b c : A), a = b /\ b = c -> a = c).
{intros. destruct H16. subst a0. subst b. auto. }
assert (nth_error ((rev p ++ m0 :: nil) ++ k :: nil) (S k0) = Some m').
{apply H16 with (b:=(nth_error (((rev p ++ m0 :: nil) ++ k :: nil) ++ copy_move k :: nil) (S k0) )).
auto. }
assert (nth_error ((rev p ++ m0 :: nil) ++ k :: nil) k0 = Some m).
{apply H16 with (b:=(nth_error
        (((rev p ++ m0 :: nil) ++ k :: nil) ++
         copy_move k :: nil) k0)). auto. }
unfold nth_error_from_back in H12. apply H12 with (k0:=k0). simpl rev. auto.
++ simpl in l. unfold nth_error_from_back in H11. simpl rev in H11. destruct H11.
assert (S k0 < length (((rev p ++ m0 :: nil) ++ k :: nil) ++
         copy_move k :: nil)).
{apply nth_error_Some. unfold not. intros.
assert (forall A (a b c : A), a = b /\ b = c -> a = c).
{intros. destruct H14. subst a0. subst b. auto. }
assert (Some m' = None).
{apply H14 with (b:=nth_error
        (((rev p ++ m0 :: nil) ++ k :: nil) ++
         copy_move k :: nil) (S k0)). auto. }
inversion H15. }
rewrite app_length in H13. rewrite app_length in H13.
rewrite app_length in H13. rewrite rev_length in H13.
simpl in H13.
assert (length p < k0 < S (S (length p))). { split.
+ assert (forall a b, a - 0 < b -> a < b).
{intros. lia. }
apply H14. auto.
+ assert (forall a b, S a < b + 1 + 1 + 1 -> a < S(S b)).
{intros. lia. }
apply H14. auto. }
assert (k0 = S (length p)). {lia. } subst k0.
assert (nth_error
        (((rev p ++ m0 :: nil) ++ k :: nil) ++
         copy_move k :: nil) (S (S (length p))) =
nth_error (copy_move k :: nil)
(S (S (length p)) - (length((rev p ++ m0 :: nil) ++ k :: nil)))).
{apply nth_error_app2. rewrite app_length. rewrite app_length.
rewrite rev_length. simpl. lia. }
rewrite app_length in H15. rewrite app_length in H15.
rewrite rev_length in H15. simpl length in H15.
assert ((S (S (length p)) - (length p + 1 + 1)) = 0). {lia. }
assert (nth_error (copy_move k :: nil)
        (S (S (length p)) - (length p + 1 + 1)) = Some (copy_move k)).
{rewrite H16. simpl. auto. }
assert (forall A (a b c : A), a = b /\ b = c -> a = c).
{intros. destruct H18. subst a0. subst b. auto. }
assert (nth_error
        (((rev p ++ m0 :: nil) ++ k :: nil) ++
         copy_move k :: nil) (S (S (length p))) =
Some (copy_move k)).
{apply H18 with (b:=nth_error (copy_move k :: nil)
        (S (S (length p)) - (length p + 1 + 1))). auto. }
assert (Some m' = Some (copy_move k)).
{apply H18 with (b:=nth_error
        (((rev p ++ m0 :: nil) ++ k :: nil) ++
         copy_move k :: nil) (S (S (length p)))). auto. }
inversion H20. subst m'.
assert (nth_error
        (((rev p ++ m0 :: nil) ++ k :: nil) ++
         copy_move k :: nil) (S (length p)) =
      nth_error
        (((rev p ++ m0 :: nil) ++ k :: nil)) (S (length p))).
{apply nth_error_app1. rewrite app_length. rewrite app_length.
rewrite rev_length. simpl. lia. }
assert (nth_error ((rev p ++ m0 :: nil) ++ k :: nil)
        (S (length p)) =
nth_error (k :: nil)
        (S (length p) - length ( ((rev p ++ m0 :: nil))))).
{apply nth_error_app2. rewrite app_length. rewrite rev_length.
simpl. lia. }
assert (nth_error (k :: nil)
        (S (length p) - length (rev p ++ m0 :: nil)) = Some k).
{assert ((S (length p) - length (rev p ++ m0 :: nil)) = 0).
{rewrite app_length. rewrite rev_length. simpl length. lia. }
rewrite H23. simpl. auto. }
assert (nth_error ((rev p ++ m0 :: nil) ++ k :: nil)
        (S (length p)) = Some k).
{apply H18 with (b:=nth_error (k :: nil)
        (S (length p) - length (rev p ++ m0 :: nil))). auto. }
assert (nth_error
        (((rev p ++ m0 :: nil) ++ k :: nil) ++
         copy_move k :: nil) (S (length p)) = Some k).
{apply H18 with (b:=nth_error ((rev p ++ m0 :: nil) ++ k :: nil)
        (S (length p))). auto. }
assert (Some m = Some k).
{apply H18 with (b:=nth_error
        (((rev p ++ m0 :: nil) ++ k :: nil) ++
         copy_move k :: nil) (S (length p))). auto. }
inversion H26. subst m.
assert (forall a b, a = negb b -> negb a = b).
{intros. subst a0. rewrite negb_involutive. auto. }
apply H27. apply H7. }


Require Import oeuf.Common.

Require Import oeuf.Utopia.
Require Import oeuf.Metadata.
Require Import Program.

Require Import oeuf.HList.
Require Import oeuf.CompilationUnit.
Require Import oeuf.Semantics.
Require Import oeuf.HighestValues.

Require oeuf.Untyped1.
Require oeuf.Untyped2.
Require oeuf.Untyped3.

Module A := Untyped2.
Module B := Untyped3.
Module S := Untyped1.

Definition compile_genv := @id (list S.expr).

Definition compile_cu := @id (list S.expr * list metadata)%type.

Ltac i_ctor := intros; constructor; eauto.
Ltac i_lem H := intros; eapply H; eauto.

Theorem I_sim : forall (AE BE : list S.expr) s s',
    compile_genv AE = BE ->
    A.sstep AE s s' ->
    B.sstep BE s s'.

destruct s as [e l k | v];
intros0 Henv Astep; inv Astep.
all: try solve [i_ctor].

- unfold S.run_elim in *. repeat (break_match; try discriminate). inject_some.
  i_lem B.SEliminate.
Qed.

Lemma compile_cu_eq : forall A Ameta B Bmeta,
    compile_cu (A, Ameta) = (B, Bmeta) ->
    A = B.
simpl. inversion 1. auto.
Qed.

Lemma compile_cu_metas : forall A Ameta B Bmeta,
    compile_cu (A, Ameta) = (B, Bmeta) ->
    Ameta = Bmeta.
simpl. inversion 1. auto.
Qed.

Section Preservation.

    Variable aprog : A.prog_type.
    Variable bprog : B.prog_type.

    Hypothesis Hcomp : compile_cu aprog = bprog.

    Theorem fsim : Semantics.forward_simulation (A.semantics aprog) (B.semantics bprog).
    destruct aprog as [A Ameta], bprog as [B Bmeta].
    fwd eapply compile_cu_eq; eauto.
    fwd eapply compile_cu_metas; eauto.

    eapply Semantics.forward_simulation_step with
        (match_states := @eq S.state)
        (match_values := @eq value).

    - simpl. intros0 Bcall Hf Ha. invc Bcall.
      simpl in *.
      eexists. split; repeat i_ctor.

    - simpl. intros0 II Afinal. invc Afinal.
      eexists. split. i_ctor. i_ctor.

    - simpl. eauto.
    - simpl. intros. tauto.

    - intros0 Astep. intros0 II.
      fwd eapply I_sim; eauto.
      subst s1. eexists. eauto.

    Qed.

End Preservation.


(* Require Import Coq.Strings.String.
Require Import Poulet4.P4defs.
Require Import Poulet4.Typed.
Require Import Poulet4.Syntax.
Require Import Poulet4.Semantics.
Require Import ProD3.core.Coqlib.
Require Import ProD3.core.Hoare.
Require Import ProD3.core.AssertionLang.
Require Import ProD3.core.EvalExpr.
Require Import Hammer.Tactics.Tactics.
Require Import Hammer.Plugin.Hammer.
Import Poulet4.Semantics.
Open Scope string_scope.

Section ExprTests.
Context `{@Target Info (@Expression Info)}.
Notation Val := (@ValueBase bool).
Notation Sval := (@ValueBase (option bool)).
Notation Lval := (ValueLvalue).
Notation Expression := (@Expression Info).

Notation ident := (string).
Notation path := (list ident).

(* a.x + a.y *)
Definition expr1 :=
  (MkExpression NoInfo
    (ExpBinaryOp Plus
         ( (MkExpression NoInfo
                (ExpExpressionMember
                     (MkExpression NoInfo
                          (ExpName
                           (BareName
                            {| stags := NoInfo;
                               str := "a" |})
                           (LInstance ["a"]))
                          (TypTypeName
                           (BareName
                            {| stags := NoInfo;
                               str := "metadata" |}))
                          InOut)
                     {| stags := NoInfo;
                        str := "x" |})
                (TypBit 8%N) Directionless),
           (MkExpression NoInfo
                (ExpExpressionMember
                     (MkExpression NoInfo
                          (ExpName
                           (BareName
                            {| stags := NoInfo;
                               str := "a" |})
                           (LInstance ["a"]))
                          (TypTypeName
                           (BareName
                            {| stags := NoInfo;
                               str := "metadata" |}))
                          InOut)
                     {| stags := NoInfo;
                        str := "y" |})
                (TypBit 8%N) Directionless) ))
    (TypBit 8%N) Directionless).

Variable (ge : genv) (p : path).
Variable (xi yi : Z) (z : Sval).

Definition mem_pre1 : mem_assertion :=
  [(["a"], ValBaseStruct [("x", ValBaseBit (P4Arith.to_loptbool 8%N xi));
                          ("y", ValBaseBit (P4Arith.to_loptbool 8%N yi));
                          ("z", z)])].

Definition pre1 : assertion := fun '(m, es) =>
  mem_denote mem_pre1 m.

Definition mem_assertion_to_mem (a : mem_assertion) : mem :=
  fold_right (fun '(p, sv) m => PathMap.set p sv m) PathMap.empty a.

Definition st1 : state := (mem_assertion_to_mem mem_pre1, PathMap.empty).

(* We should define P4Arith.to_loptbool w x := map Some (P4Arith.to_lbool w x) *)

Lemma Forall2_strict_read_ndetbit : forall w x,
  Forall2 strict_read_ndetbit (P4Arith.to_loptbool w x) (P4Arith.to_lbool w x).
Admitted.

Hint Resolve Forall2_strict_read_ndetbit : eval_expr.

(* Lemma test1 : exists sv, hoare_expr ge p pre1 expr1 sv. *)
Lemma test1 : exists sv, exec_expr ge strict_read_ndetbit p st1 expr1 sv.
Proof.
  econstructor.
  econstructor.
  - econstructor.
    + econstructor; econstructor.
    + econstructor; econstructor.
  - econstructor.
    + econstructor; econstructor.
    + econstructor; econstructor.
  - econstructor. auto with eval_expr.
  - econstructor. auto with eval_expr.
  - econstructor.
  - (* This form is very bad. *)
    (* simpl is not helpful. *)
Admitted.

(* "test1" uses exec_expr as the evaluation scheme. For soundness, we'll need to prove a lemma
  to relate (exec_expr strict_read_ndetbit) with hoare_expr, which seems not hard to do. To
  summarize test1, we find constructing a nice exec_expr is tricky. We can construct by econstructor
  and eauto. The econstructor part can be merged into eauto by Hint Constructors. But the result
  is bad:

  val_to_sval
  (ValBaseInt
     (P4Arith.to_lbool (Z.to_N (Zlength (P4Arith.to_lbool 8 xi)))
        (P4Arith.IntArith.plus_mod ...)))

  I think it can be resolved by using lemmas instead of constructors for Ops.Ops.eval_binary_op.
      *)

(* Let's redefine P4Arith.to_loptbool as (map Some (P4Arith.to_lbool)). *)
(* Still cannot handle force get_member. *)
(* Also we want to handle get_set conversion. *)

Axiom target1 : hoare_expr ge p pre1 expr1 (ValBaseBit (P4Arith.to_loptbool 8%N (xi + yi))).

Variable (a : Sval).

Definition mem_pre2 : mem_assertion :=
  [(["a"], a)].

(* ValBaseStruct [("x", ValBaseInt (P4Arith.to_loptbool 8%N xi));
                          ("y", ValBaseInt (P4Arith.to_loptbool 8%N yi));
                          ("z", z)])]. *)

Definition pre2 : assertion := fun '(m, es) =>
  mem_denote mem_pre2 m.

Axiom target2 :
  get "x" a = ValBaseBit (P4Arith.to_loptbool 8%N xi) ->
  get "y" a = ValBaseBit (P4Arith.to_loptbool 8%N yi) ->
  hoare_expr ge p pre2 expr1 (ValBaseBit (P4Arith.to_loptbool 8%N (xi + yi))).

(* So I think we should build a function that eval to (option Sval),
  but only gives None when used variables are not found in the mem_assertion. *)

Eval simpl in (eval_expr ge p mem_pre1 expr1).

 *)


(* This file is part of the Linear Logic  formalization in Coq: https://github.com/brunofx86/LL *)

(** ** Cut Elimination

Proof of cut-elimination and the consistency of LL as a corollary.

 *)

Require Export CutCases.
Require Export llTactics.
Set Implicit Arguments.

#[local] Hint Resolve Nat.le_max_r Nat.le_max_l : core .

Lemma ap_cut_free B L M1 M2 v :
  0%nat = lexp_weight (v ⁺) ->
  L =mul= M1 ++ M2 ->
  0 |~> 0; B; v ⁻ :: M2 ->
              0 |~> 0; B; v ⁺ :: M1 -> exists m : nat, m |~> 0; B; L.
Proof.
  intros Hw P Hn2 Hn1.
  inversion Hn1; inversion Hn2; subst;
    try simpl_cases0;
    try broken; try solve_cont;
      try simpl_cases2;
      try top_commutes; try simpl_cases0.

  destruct (eq_dec (A0 ⁻) (A1 ⁻)).
  apply atp_eq in e.
  apply atn_eq in e0.
  rewrite e in *;
    rewrite e0 in *.
  simpl in H0.
  do 2 simpl_cases4.
  rewrite union_comm_app in P.
  rewrite H0, H in P.
  eexists.
  refine (sig3_init _ P).
  apply atp_eq in e.
  rewrite e in *.
  simpl in H0.
  solve_cont.
Qed.
Arguments ap_cut_free [B L M1 M2 v].

Lemma zt_cut_free B L M1 M2 :
  0%nat = lexp_weight (⊤) ->
  L =mul= M1 ++ M2 ->
  0 |~> 0; B; 0 :: M2 ->
              0 |~> 0; B; ⊤ :: M1 -> exists m : nat, m |~> 0; B; L.
Proof.
  intros Hw P Hn2 Hn1.
  inversion Hn1; subst.
  apply resolvers in H; firstorder; inversion H.
  apply resolvers2 in H; firstorder; inversion H.
  simpl_cases4.

  inversion Hn2; subst.
  apply resolvers in H0; firstorder; inversion H0.
  apply resolvers2 in H0; firstorder; inversion H0.
  simpl_cases2. top_commutes.
Qed.
Arguments zt_cut_free [B L M1 M2].

Lemma bo_cut_free B L M1 M2 :
  0%nat = lexp_weight (⊥) ->
  L =mul= M1 ++ M2 ->
  0 |~> 0; B; 1 :: M2 ->
              0 |~> 0; B; ⊥ :: M1 -> exists m : nat, m |~> 0; B; L.
Proof.
  intros Hw P Hn2 Hn1.
  inversion Hn1; subst.
  apply resolvers in H; firstorder; inversion H.
  apply resolvers2 in H; firstorder; inversion H.
  simpl_cases2. top_commutes.
Qed.
Arguments bo_cut_free [B L M1 M2].

Theorem cut_aux B L M1 M2 F n1 n2 :
  0%nat = lexp_weight F -> 0%nat = plus n1 n2 -> L =mul= M1 ++ M2 ->
  n1 |~> 0 ; B ; F :: M1 -> n2 |~> 0 ; B ; F° :: M2 ->
                                           exists m, m |~> 0 ; B ; L.
Proof.
  intros Hw Hh P Hn1 Hn2.
  simpl_bases; (* n1 = n2 = 0 *)
    clear Hh.

  destruct F; simpl ((_)°)in *; try inversion Hw.
  -
    refine (ap_cut_free Hw P Hn2 Hn1).
  -
    rewrite union_comm_app in P.
    refine (ap_cut_free Hw P Hn1 Hn2).
  -
    refine (zt_cut_free Hw P Hn2 Hn1).
  -
    refine (bo_cut_free Hw P Hn2 Hn1).
  -
    rewrite union_comm_app in P.
    refine (zt_cut_free Hw P Hn1 Hn2).
  -
    rewrite union_comm_app in P.
    refine (bo_cut_free Hw P Hn1 Hn2).
Qed.
Arguments cut_aux [B L M1 M2 F n1 n2].

Lemma tp_cut_free B L M1 M2 F1 F2 :
  L =mul= M1 ++ M2 ->
  0 |~> 0; B; (F1 ** F2) :: M1 ->
              0 |~> 0; B; (F1° $ F2°) :: M2 -> exists m : nat, m |~> 0; B; L.
Proof.
  intros P Hn1 Hn2.
  inversion Hn1; subst.
  apply resolvers in H; firstorder; inversion H.
  apply resolvers2 in H; firstorder; inversion H.
  simpl_cases2.
  top_commutes.
Qed.
Arguments tp_cut_free [B L M1 M2 F1 F2].

Lemma wp_cut_free B L M1 M2 F1 F2 :
  L =mul= M1 ++ M2 ->
  0 |~> 0; B; (F1 ⊕ F2) :: M1 ->
              0 |~> 0; B; (F1° & F2°) :: M2 -> exists m : nat, m |~> 0; B; L.
Proof.
  intros P Hn1 Hn2.
  inversion Hn1; subst.
  apply resolvers in H; firstorder; inversion H.
  apply resolvers2 in H; firstorder; inversion H.
  simpl_cases2. top_commutes.
Qed.
Arguments wp_cut_free [B L M1 M2 F1 F2].

Lemma bq_cut_free B L M1 M2 F :
  L =mul= M1 ++ M2 ->
  0 |~> 0; B; (! F) :: M1 ->
              0 |~> 0; B; (? F°) :: M2 -> exists m : nat, m |~> 0; B; L.
Proof.
  intros P Hn1 Hn2.
  inversion Hn1; subst.
  apply resolvers in H; firstorder; inversion H.
  apply resolvers2 in H; firstorder; inversion H.
  simpl_cases2. top_commutes.
Qed.
Arguments bq_cut_free [B L M1 M2 F].

Theorem cut_aux' B L M1 M2 F w :
  S w = lexp_weight F -> L =mul= M1 ++ M2 ->
  0 |~> 0 ; B ; F :: M1 -> 0 |~> 0 ; B ; F° :: M2 ->
                                         exists m, m |~> 0 ; B ; L.
Proof.
  intros Hw P Hn1 Hn2.

  destruct F; simpl ((_)°)in *; try inversion Hw.
  -
    refine (tp_cut_free P Hn1 Hn2).
  -
    rewrite union_comm_app in P.
    refine (tp_cut_free P Hn2 _).
    rewrite <- !ng_involutive; auto.
  -
    refine (wp_cut_free P Hn1 Hn2).
  -
    rewrite union_comm_app in P.
    refine (wp_cut_free P Hn2 _).
    rewrite <- !ng_involutive; auto.
  -
    refine (bq_cut_free P Hn1 Hn2).
  -
    rewrite union_comm_app in P.
    refine (bq_cut_free P Hn2 _).
    rewrite <- !ng_involutive; auto.
Qed.
Arguments cut_aux' [B L M1 M2 F w].

Theorem ccut_aux  B L M1 M2 F w :
  S w = lexp_weight (! F) -> L =mul= M1 ++ M2 ->
  0 |~> 0 ; B ; ! F :: M1 -> 0 |~> 0 ; F° :: B ; M2 ->
                                                 exists m, m |~> 0 ; B ; L.
Proof.
  intros Hw P Hn1 Hn2.
  inversion Hn1; subst;
    [ apply resolvers in H; firstorder; inversion H |
      apply resolvers2 in H; firstorder; inversion H |
      simpl_cases2; top_commutes].
Qed.
Arguments ccut_aux [B L M1 M2 F w].

Lemma cut_elimination_base: forall n B L,
    n |~> 1 ; B ; L -> exists m, m |~> 0 ; B ; L.
Proof.
  intros.
  revert dependent B.
  revert dependent L.
  induction n using strongind; intros.
  - inversion H.
  - inversion H0; subst.
    + assert (exists m, m |~> 0; B; M) as Hyp by solve [eapply H; auto].
      destruct Hyp as [t Ht].
      eexists;
        refine (sig3_bot _ Ht); eauto.
    + assert (exists m, m |~> 0; B; F :: G :: M) as Hyp by solve [eapply H; auto].
      destruct Hyp as [t Ht].
      eexists;
        refine (sig3_par _ Ht); resolve_rewrite.
    + apply Nat.eq_add_1 in H2.
      destruct H2; destruct H1; subst.
      assert (exists m, m |~> 0; B; F :: M) as Hyp.
      refine (H _ _ _ _ H4); resolve_max.
      destruct Hyp as [t Ht].
      eexists;
        refine (sig3_tensor _ Ht H5); resolve_rewrite.
      assert (exists m, m |~> 0; B; G :: N) as Hyp.
      refine (H _ _ _ _ H5); resolve_max.
      destruct Hyp as [t Ht].
      eexists;
        refine (sig3_tensor _ H4 Ht); resolve_rewrite.
    + assert (exists m, m |~> 0; B; F :: M) as Hyp by solve [eapply H; auto].
      destruct Hyp as [t Ht].
      eexists;
        refine (sig3_plus1 _ Ht); resolve_rewrite.
    + assert (exists m, m |~> 0; B; G :: M) as Hyp by solve [eapply H; auto].
      destruct Hyp as [t Ht].
      eexists;
        refine (sig3_plus2 _ Ht); resolve_rewrite.
    + apply Nat.eq_add_1 in H2.
      destruct H2; destruct H1; subst.
      assert (exists m, m |~> 0; B; F :: M) as Hyp.
      refine (H _ _ _ _ H4); resolve_max.
      destruct Hyp as [t Ht].
      eexists;
        refine (sig3_with _ Ht H5); resolve_rewrite.
      assert (exists m, m |~> 0; B; G :: M) as Hyp.
      refine (H _ _ _ _ H5); resolve_max.
      destruct Hyp as [t Ht].
      eexists;
        refine (sig3_with _ H4 Ht); resolve_rewrite.
    + rewrite H3 in H4.
      assert (exists m, m |~> 0; B; F:: L) as Hyp by solve [eapply H; auto].
      destruct Hyp as [t Ht].
      eexists;
        refine (sig3_copy _ _ Ht); auto.
    + assert (exists m, m |~> 0; F:: B; M) as Hyp by solve [eapply H; auto].
      destruct Hyp as [t Ht].
      eexists;
        refine (sig3_quest _ Ht); auto.
    + assert (exists m, m |~> 0; B; [F]) as Hyp by solve [eapply H; auto].
      destruct Hyp as [t Ht].
      eexists;
        refine (sig3_bang _ Ht); auto.
    + (* caso CUT *)
      clear H0. clear H.
      revert dependent B.
      revert dependent L.
      revert dependent n.

      dependent induction w using strongind;

        dependent induction h using strongind; intros.

      *
        inversion H3; subst.
        **
          cut_free.
          simpl in H0, H1.
          refine (cut_aux _ _ _ H4 H8); auto.
        **
          cut_free.
          simpl in H1, H0.
          inversion H0.
      *
        inversion H3; subst.
        **

          cut_free.
          simpl in H1.
          rename H1 into Hw, H2 into Hh.
          rename H4 into P, H5 into Hn1, H9 into Hn2.
          rename m into n1, n0 into n2.
          rename M into M1, N into M2.

          destruct F; simpl ((_)°)in *; try inversion Hw.
          refine (aux_CUT_ap _ Hh _ P Hn1 Hn2); eauto.
          rewrite union_comm_app in P.
          rewrite Nat.add_comm in Hh.
          refine (aux_CUT_ap _ Hh _ _ Hn2 Hn1); eauto.
          refine (aux_CUT_tz _ Hh _ Hn1 Hn2); eauto.
          refine (aux_CUT_bo _ Hh _ Hn1 Hn2); eauto.
          rewrite union_comm_app in P.
          rewrite Nat.add_comm in Hh.
          refine (aux_CUT_tz _ Hh _ Hn2 Hn1); eauto.
          rewrite union_comm_app in P.
          rewrite Nat.add_comm in Hh.
          refine (aux_CUT_bo _ Hh _ Hn2 Hn1); eauto.
        **
          cut_free.
          simpl in H1.
          inversion H1.
      *
        inversion H3; subst.
        **
          cut_free.
          simpl in H2.
          cut_free.
          refine (cut_aux' H1 H4 H5 H9).
        **
          cut_free.
          simpl in H2.
          cut_free.
          refine (ccut_aux H1 H4 H5 H9).
      * inversion H3; subst; try cut_free.
        -- (** cut *)
          rename H2 into Hw, H4 into Hh.
          rename H5 into P, H6 into Hn1, H10 into Hn2.
          rename m into n1, n0 into n2.
          rename M into M1, N into M2.
          clear H3.
          destruct F; simpl ((_)°)in *; try inversion Hw.
          refine (aux_CUT_tp _ _ _ _ P Hn1 Hn2); eauto.
          rewrite union_comm_app in P.
          rewrite Nat.add_comm in Hh.
          refine (aux_CUT_tp _ _ _ _ P Hn2 _); eauto.
          rewrite <- !lweight_dual; auto.
          rewrite <- !ng_involutive; auto.
          rewrite union_comm_app in P.
          rewrite Nat.add_comm in Hh.
          refine (aux_CUT_pw _ _ _ _ P Hn2 _); eauto.
          rewrite <- !lweight_dual; auto.
          rewrite <- !ng_involutive; auto.
          refine (aux_CUT_pw _ _ _ _ P Hn1 Hn2); eauto.
          refine (aux_CUT_bq _ _ _ _ P Hn1 Hn2); eauto.
          rewrite union_comm_app in P.
          rewrite Nat.add_comm in Hh.
          refine (aux_CUT_bq _ _ _ _ P Hn2 _); eauto.
          rewrite <- !lweight_dual; auto.
          rewrite <- !ng_involutive; auto.
        --
          rename H2 into Hw, H4 into Hh.
          rename H5 into P, H6 into Hn1, H10 into Hn2.
          rename m into n1, n0 into n2.
          rename M into M1, N into M2.

          inversion Hn1;subst.
          eapply resolvers in H1; intuition; inversion H2.
          eapply resolvers2 in H1; intuition; inversion H2.

          (* Top Commutes *)
          simpl_cases2.
          rewrite H2 in P.
          eexists.
          eapply sig3_top; resolve_rewrite.

          (* Bot Commutes *)
          simpl_cases2.
          assert (exists m, m |~> 0 ; B; x ++ M2) as Hyp.
          rewrite H1 in H2.
          refine (H0 _ _ _ _ _ _);
            [ | change (0%nat) with (plus 0 0);
                refine (sig3_ccut _ _ _ H2 Hn2);
                auto; try resolve_rewrite]; resolve_max.

          destruct Hyp as [t Ht];
            eexists;
            refine (sig3_bot _ Ht); auto; resolve_rewrite.

          (* Par Commutes *)
          simpl_cases2.
          assert (exists m, m |~> 0 ; B; F0 :: G :: (x ++ M2)) as Hyp.
          rewrite H1 in H2;
            rewrite union_rotate_cons in H2.
          refine (H0 _ _ _ _ _ _);
            [ | change (0%nat) with (plus 0 0);
                refine (sig3_ccut _ _ _ H2 Hn2);
                auto; try resolve_rewrite]; resolve_max.

          destruct Hyp as [t Ht];
            eexists;
            refine (sig3_par _ Ht); auto; resolve_rewrite.

          (* Tensor Commutes *)
          simpl_cases2.
          cut_free.
          simpl_cases_tns.

          assert (exists m, m |~> 0 ; B; F0 :: (L1 ++ M2)) as Hyp.
          rewrite HL1 in H4;
            rewrite meq_swap_cons in H4.
          refine (H0 _ _ _ _ _ _);
            [ | change (0%nat) with (plus 0 0);
                refine (sig3_ccut _ _ _ H4 Hn2);
                auto; try resolve_rewrite].
          inversion Hh.  resolve_max.
          destruct Hyp as [t Ht];
            eexists;
            refine (sig3_tensor _ Ht H6); auto; resolve_rewrite.

          assert (exists m, m |~> 0 ; B; G :: (L2 ++ M2)) as Hyp.

          rewrite HL2 in H6;
            rewrite meq_swap_cons in H6.
          refine (H0 _ _ _ _ _ _);
            [ | change (0%nat) with (plus 0 0);
                refine (sig3_ccut _ _ _ H6 Hn2);
                auto; try resolve_rewrite].
          inversion Hh.  resolve_max.
          destruct Hyp as [t Ht];
            eexists;
            refine (sig3_tensor _ H4 Ht); auto; resolve_rewrite.

          (* Plus1 Commutes *)
          simpl_cases2.
          assert (exists m : nat, m |~> 0 ; B; F0 :: x ++ M2) as Hyp.
          rewrite H1 in H2;
            rewrite meq_swap_cons in H2.
          refine (H0 _ _ _ _ _ _);
            [ | change (0%nat) with (plus 0 0);
                refine (sig3_ccut _ _ _ H2 Hn2);
                auto; try resolve_rewrite]; resolve_max.

          destruct Hyp as [t Ht];
            try rewrite union_assoc in Ht;
            eexists;
            refine (sig3_plus1 _ Ht); auto; resolve_rewrite.

          (* Plus2 Commutes *)
          simpl_cases2.
          assert (exists m : nat, m |~> 0 ; B; G :: x ++ M2) as Hyp.
          rewrite H1 in H2;
            rewrite meq_swap_cons in H2.
          refine (H0 _ _ _ _ _ _);
            [ | change (0%nat) with (plus 0 0);
                refine (sig3_ccut _ _ _ H2 Hn2);
                auto; try resolve_rewrite]; resolve_max.

          destruct Hyp as [t Ht];
            try rewrite union_assoc in Ht;
            eexists;
            refine (sig3_plus2 _ Ht); auto; resolve_rewrite.

          (* With Commutes *)
          simpl_cases2.
          cut_free.
          assert (exists m, m |~> 0 ; B; F0 :: (x ++ M2)) as Hyp1.
          rewrite H2 in H4;
            rewrite meq_swap_cons in H4;
            refine (H0 _ _ _ _ _ _);
            [ | change (0%nat) with (plus 0 0);
                refine (sig3_ccut _ _ _ H4 Hn2);
                auto; try resolve_rewrite];resolve_max.
          inversion Hh;  resolve_max.

          assert (exists m, m |~> 0 ; B; G :: (x ++ M2)) as Hyp2.
          rewrite H2 in H6; rewrite meq_swap_cons in H6;
            refine (H0 _ _ _ _ _ _);
            [ | change (0%nat) with (plus 0 0);
                refine (sig3_ccut _ _ _ H6 Hn2);
                auto; try resolve_rewrite];resolve_max.
          inversion Hh;  resolve_max.
          destruct Hyp1 as [t1 Ht1];
            destruct Hyp2 as [t2 Ht2];

            eexists;
            refine (sig3_with _ Ht1 Ht2); resolve_rewrite.

          (* Copy Commutes *)
          assert (exists m, m |~> 0 ; B ; F0 :: L) as Hyp.
          rewrite meq_swap_cons in H2.
          rewrite H2 in H4.
          refine (H0 _ _ _ _ _ _);
            [ | change (0%nat) with (plus 0 0);
                refine (sig3_ccut _ _ _ H4 Hn2);
                auto; try resolve_rewrite];resolve_max.

          destruct Hyp as [t Ht];
            eexists;
            refine (sig3_copy _ _ Ht); auto; resolve_rewrite.

          (* Quest Commutes *)
          simpl_cases2.

          assert (exists m, m |~> 0 ; F0 :: B; x ++ M2) as Hyp.
          rewrite H1 in H2.
          eapply height_preserving_weakning_sig3 with (D:=[F0]) in Hn2.
          rewrite <- app_comm_cons in Hn2.
          rewrite union_comm_app in Hn2.
          refine (H0 _ _ _ _ _ _);
            [ | change (0%nat) with (plus 0 0);
                refine (sig3_ccut _ _ _ H2 Hn2);
                auto; try resolve_rewrite]; resolve_max.
          destruct Hyp as [t Ht];
            eexists;
            refine (sig3_quest _ Ht); auto; resolve_rewrite.

          (* Bang Principal *)
          eapply resolvers2 in H1; intuition.
          rewrite H5 in P, Hn1; clear H5.
          rewrite <- P in *. clear P.
          rewrite bng_eq in H4.
          rewrite <- H4 in *; clear H4.

          inversion Hn2; subst; inversion Hh; try cut_free.
          eexists; eapply sig3_init; eassumption.
          eexists; eapply sig3_one; eassumption.
          eexists; eapply sig3_top; eassumption.
          assert (exists m : nat, m |~> 0; B; M) as Hyp.
          refine (H0 _ _ _ _ _ _);
            [ |
              change (0%nat) with (plus 0 0);
              refine (sig3_ccut _ _ _ Hn1 H4);
              auto]; resolve_max.
          destruct Hyp as [t Ht];
            eexists;
            refine (sig3_bot _ Ht); auto; resolve_rewrite.
          assert (exists m, m |~> 0; B; F1 :: G :: M) as Hyp.
          refine (H0 _ _ _ _ _ _);
            [ |
              change (0%nat) with (plus 0 0);
              refine (sig3_ccut _ _ _ Hn1 H4);
              auto]; resolve_max.
          destruct Hyp as [t Ht];
            eexists;
            refine (sig3_par _ Ht); auto; resolve_rewrite.
          assert (exists m, m |~> 0; B; F1 :: M) as Hyp1.
          refine (H0 _ _ _ _ _ _);
            [ |
              change (0%nat) with (plus 0 0);
              refine (sig3_ccut _ _ _ Hn1 H5);
              auto]; resolve_max.
          assert (exists m, m |~> 0; B; G :: N) as Hyp2.
          refine (H0 _ _ _ _ _ _);
            [ |
              change (0%nat) with (plus 0 0);
              refine (sig3_ccut _ _ _ Hn1 H7);
              auto]; resolve_max.
          destruct Hyp1 as [t1 Ht1];
            destruct Hyp2 as [t2 Ht2];
            eexists;
            refine (sig3_tensor _ Ht1 Ht2); auto; resolve_rewrite.
          assert (exists m, m |~> 0; B; F1 :: M) as Hyp.
          refine (H0 _ _ _ _ _ _);
            [ |
              change (0%nat) with (plus 0 0);
              refine (sig3_ccut _ _ _ Hn1 H4);
              auto]; resolve_max.
          destruct Hyp as [t Ht];
            eexists;
            refine (sig3_plus1 _ Ht); auto; resolve_rewrite.
          assert (exists m, m |~> 0; B; G :: M) as Hyp.
          refine (H0 _ _ _ _ _ _);
            [ |
              change (0%nat) with (plus 0 0);
              refine (sig3_ccut _ _ _ Hn1 H4);
              auto]; resolve_max.
          destruct Hyp as [t Ht];
            eexists;
            refine (sig3_plus2 _ Ht); auto; resolve_rewrite.
          assert (exists m, m |~> 0; B; F1 :: M) as Hyp1.
          refine (H0 _ _ _ _ _ _);
            [ |
              change (0%nat) with (plus 0 0);
              refine (sig3_ccut _ _ _ Hn1 H5);
              auto]; resolve_max.
          assert (exists m, m |~> 0; B; G :: M) as Hyp2.
          refine (H0 _ _ _ _ _ _);
            [ |
              change (0%nat) with (plus 0 0);
              refine (sig3_ccut _ _ _ Hn1 H7);
              auto]; resolve_max.
          destruct Hyp1 as [t1 Ht1];
            destruct Hyp2 as [t2 Ht2];
            eexists;
            refine (sig3_with _ Ht1 Ht2); auto; resolve_rewrite.

          2 : {
            assert (exists m, m |~> 0; F1 :: B; M) as Hyp.
            rewrite meq_swap_cons in H4.
            eapply height_preserving_weakning_sig3 with (D:=[F1]) in Hn1.
            rewrite union_comm_app in Hn1.

            refine (H0 _ _ _ _ _ _);
              [ |
                change (0%nat) with (plus 0 0);
                refine (sig3_ccut _ _ _ Hn1 H4);
                auto]; resolve_max.
            destruct Hyp as [t Ht];
              eexists;
              refine (sig3_quest _ Ht); auto; resolve_rewrite.
          }
          2: {
            assert (exists m, m |~> 0; B; [F1]) as Hyp.
            refine (H0 _ _ _ _ _ _);
              [ |
                change (0%nat) with (plus 0 0);
                refine (sig3_ccut _ _ _ Hn1 H4);
                auto]; resolve_max.
            destruct Hyp as [t Ht];
              eexists;
              refine (sig3_bang _ Ht); auto; resolve_rewrite.
          }

          destruct (eq_dec F1 F0°); subst.
          assert (exists m, m |~> 0; B; F0° :: L) as Hyp.
          rewrite H4 in H5.
          refine (H0 _ _ _ _ _ _);
            [ | change (0%nat) with (plus 0 0);
                refine (sig3_ccut _ _ _ Hn1 H5);
                auto; resolve_rewrite]; resolve_max.

          destruct Hyp as [t Ht].

          refine (H _ _ _ _ _ _ _);
            [ | change (0%nat) with (plus 0 0)].

          2: { refine (sig3_cut _ _ _ H2 Ht); auto. }
          inversion Hw.
          resolve_max.

          simpl_cases2.
          assert (exists m, m |~> 0; B; F1 :: L) as Hyp.
          rewrite H4 in H5.
          refine (H0 _ _ _ _ _ _);
            [ |
              change (0%nat) with (plus 0 0);
              refine (sig3_ccut _ _ _ Hn1 H5);
              auto]; resolve_max.
          destruct Hyp as [t Ht];
            eexists;
            refine (sig3_copy _ _ Ht); auto.
Qed.

Theorem cut_elimination : forall B L n c, n |~> c ; B ; L ->
                                                        exists m, m |~> 0 ; B ; L.
Proof.
  intros.
  dependent induction n generalizing B L using strongind; induction c using strongind.
  + (* Case <0,0> *)
    eexists; eauto.
  + (* Case <0, S c> *)
    inversion H.
  + (* case <Sn, 0> *)
    inversion H0;subst;try (rewrite H2).
    ++ (* BOTTOM*) eexists. refine(sig3_bot _ _);eauto.
    ++ (* PAR *)  eexists. refine(sig3_par _ _);eauto.
    ++ (* TENSOR *) apply Nat.eq_add_0 in H2.
       destruct H2;subst.
       eexists.
       assert(S(Init.Nat.max n0 m) |~> 0 + 0 ; B ; (F ** G) :: (M ++ N)).
       refine(sig3_tensor _ _ _);eauto.
       rewrite H3.
       eauto.
    ++ (* OPLUS F *)  eexists. refine(sig3_plus1 _ _);eauto.
    ++ (* OPLUS G *)  eexists. refine(sig3_plus2 _ _);eauto.
    ++ (* WITH *) apply Nat.eq_add_0 in H2.
       destruct H2;subst.
       assert(S(Init.Nat.max n0 m) |~> 0 + 0 ; B ; (F & G) :: (M )).
       refine(sig3_with _ _ _);eauto.
       eexists.
       rewrite H3.
       eauto.
    ++ (* COPY *) eexists. refine(sig3_copy _ _ _);eauto.
    ++ (* QUEST *) eexists. refine(sig3_quest _ _);eauto.
    ++ (* BANG *) eexists. refine(sig3_bang _ _);eauto.
  + (* Case <Sn, Sc> *)
    rename H1 into IHn.

    inversion H0;subst.
    ++   (* bottom *)
      apply H in H3;auto.  destruct H3.
      eexists.
      rewrite H2.
      refine(sig3_bot _ _);eauto.

    ++   (* PAR *)
      apply H in H3;auto.  destruct H3.
      eexists.
      rewrite H2.
      refine(sig3_par _ _);eauto.

    ++
      (* TENSOR *)
      apply H in H4;auto. destruct H4.
      apply H in H5;auto. destruct H5.

      assert(S(Init.Nat.max x0 x) |~> (plus 0 0); B; (F ** G) :: (M ++ N)).
      refine(sig3_tensor _ _ _ );eauto.

      eexists.
      rewrite H3.
      eauto.
    ++ (* PLUS1 *)
      apply H in H3;auto.  destruct H3.
      eexists.
      rewrite H2.
      refine(sig3_plus1 _ _);eauto.

    ++ (* PLUS2 *)
      apply H in H3;auto.  destruct H3.
      eexists.
      rewrite H2.
      refine(sig3_plus2 _ _);eauto.

    ++ (* WITH *)
      apply H in H4;auto.  destruct H4.
      apply H in H5;auto.  destruct H5.

      assert(S(Init.Nat.max x0 x) |~> 0 + 0 ; B ; (F & G) :: M).
      refine(sig3_with _ _ _);eauto.

      eexists.
      rewrite H3.
      eauto.
    ++ (* copy *)
      apply H in H4;auto.  destruct H4.
      eexists.
      refine(sig3_copy _ _ _);eauto.
    ++  (* quest *)
      apply H in H3;auto.  destruct H3.
      eexists.
      rewrite H2.
      refine(sig3_quest _ _);eauto.
    ++ (* bang *)
      apply H in H3;auto.  destruct H3.
      eexists.
      rewrite H2.
      refine(sig3_bang _ _);eauto.
    ++ (* CUT *)
      destruct H3.
    --
      apply H in H4;auto. destruct H4.
      apply H in H5;auto. destruct H5.

      assert(S(Init.Nat.max x0 x) |~> S(0 + 0) ; B ; L).
      eapply sig3_CUT.
      eapply  sig3_cut;eauto.

      apply cut_elimination_base in H6.
      destruct H6.
      eexists. eauto.
    --
      (* CCUT *)
      apply H in H4;auto. destruct H4.
      apply H in H5;auto. destruct H5.

      assert(S(Init.Nat.max x0 x) |~> S(0 + 0) ; B ; L).
      eapply sig3_CUT.
      eapply  sig3_ccut;eauto.

      apply cut_elimination_base in H6.
      destruct H6.
      eexists; eauto.
Qed.

(** Consistency as a corollary of cut-elimination *)
Theorem weak_consistency : forall n c, ~ sig3 n c [] [0].
Proof.
  intros.
  intro.
  apply cut_elimination in H.
  destruct H.
  inversion H; subst;
    try simpl_cases0.
  eapply DestructMulFalse; eauto.
Qed.

Lemma strong_cons : forall n c, ~ sig3 n c [] [].
Proof.
  intros.
  intro.
  apply cut_elimination in H.
  destruct H.
  inversion H; subst;
    try solve [eapply DestructMulFalse; eauto].
Qed.

Theorem strong_consistency : forall n c, ~ sig3 n c [] [Bot].
Proof.
  intros.
  intro.
  apply cut_elimination in H.
  destruct H.
  inversion H; subst;
    try simpl_cases0.
  rewrite Hm in H1.
  eapply strong_cons; eauto.
  eapply DestructMulFalse; eauto.
Qed.

(** Equality of the systems with/without the cut-rule *)
Theorem sig2h_then_sig3 : forall n B L, n |-- B ; L -> exists m, m |~> 0 ; B ; L.
Proof.
  intros.
  induction H; try destruct IHsig2h; try destruct IHsig2h1; try destruct IHsig2h2.
  eexists.
  eapply sig3_init; eauto.
  eexists.
  eapply sig3_one; eauto.
  eexists.
  eapply sig3_top; eauto.
  eexists.
  eapply sig3_bot; eauto.
  eexists.
  eapply sig3_par; eauto.
  eapply cut_elimination.
  eapply sig3_tensor; eauto.
  eexists.
  eapply sig3_plus1; eauto.
  eexists.
  eapply sig3_plus2; eauto.
  eapply cut_elimination.
  eapply sig3_with; eauto.
  eexists.
  eapply sig3_copy; eauto.
  eexists.
  eapply sig3_quest; eauto.
  eexists.
  eapply sig3_bang; eauto.
Qed.

Theorem sig3_then_sig2h : forall n B L, n |~> 0 ; B ; L -> exists m, m |-- B ; L.
Proof.
  intros.
  revert dependent B.
  revert dependent L.
  induction n using strongind; intros.
  inversion H; subst.
  eexists.
  eapply sig2h_init; eauto.
  eexists.
  eapply sig2h_one; eauto.
  eexists.
  eapply sig2h_top; eauto.
  inversion H0; subst.
  assert (exists m, m |-- B; M) as Hyp by solve [eapply H; eauto].
  destruct Hyp as [t Ht];
    eexists.
  eapply sig2h_bot; eauto.
  assert (exists m, m |-- B; F :: G :: M) as Hyp by solve [eapply H; eauto].
  destruct Hyp as [t Ht];
    eexists.
  eapply sig2h_par; eauto.
  cut_free.
  assert (exists m, m |-- B; F :: M) as Hyp1 by
        solve [apply H with m; auto].
  assert (exists m, m |-- B; G :: N) as Hyp2 by
        solve [apply H with n0; auto].
  destruct Hyp1 as [t1 Ht1];
    destruct Hyp2 as [t2 Ht2];
    eexists.
  eapply sig2h_tensor; eauto.
  assert (exists m, m |-- B; F :: M) as Hyp by solve [eapply H; eauto].
  destruct Hyp as [t Ht];
    eexists.
  eapply sig2h_plus1; eauto.
  assert (exists m, m |-- B; G :: M) as Hyp by solve [eapply H; eauto].
  destruct Hyp as [t Ht];
    eexists.
  eapply sig2h_plus2; eauto.
  cut_free.
  assert (exists m, m |-- B; F :: M) as Hyp1 by
        solve [apply H with m; auto].
  assert (exists m, m |-- B; G :: M) as Hyp2 by
        solve [apply H with n0; auto].
  destruct Hyp1 as [t1 Ht1];
    destruct Hyp2 as [t2 Ht2];
    eexists.
  eapply sig2h_with; eauto.
  assert (exists m, m |-- B; L0) as Hyp by solve [eapply H; eauto].
  destruct Hyp as [t Ht];
    eexists.
  eapply sig2h_copy; eauto.
  assert (exists m, m |--  F :: B; M) as Hyp by solve [eapply H; eauto].
  destruct Hyp as [t Ht];
    eexists.
  eapply sig2h_quest; eauto.
  assert (exists m, m |--  B; [F]) as Hyp by solve [eapply H; eauto].
  destruct Hyp as [t Ht];
    eexists.
  eapply sig2h_bang; eauto.
Qed.

Theorem sig3_then_sig2h' : forall B L, (exists n, n |~> 0 ; B ; L) -> exists m, m |-- B ; L.
Proof.
  intros.
  destruct H.
  eapply sig3_then_sig2h.
  eauto.
Qed.

Lemma exists_com : forall (A:Type) (P:A -> A -> Prop), (exists a b, P a b) <-> exists b a, P a b.
Proof.
  split; intros;
    do 2 destruct H;
    do 2 eexists; eauto.
Qed.

Theorem sig2h_then_sig2hc : forall n B L, n |-- B ; L -> exists m, m |-c B ; L.
Proof.
  intros.
  apply sig2h_then_sig3 in H.
  apply sig2hc_iff_sig2hcc.
  apply sig3_iff_sig2hcc.
  apply exists_com.
  eexists 0%nat.
  auto.
Qed.

Theorem sig2hc_then_sig2h : forall n B L, n |-c B ; L -> exists m, m |-- B ; L.
Proof.
  intros.
  apply sig2hc_then_sig2hcc in H.
  apply sig2hcc_then_sig3 in H.
  destruct H.
  apply cut_elimination in H.
  apply sig3_then_sig2h'. auto.
Qed.


Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Op.
Require Import NeedDomain.
Require Import RTL.

(** Neededness analysis for PowerPC operators *)

Definition op1 (nv: nval) := nv :: nil.
Definition op2 (nv: nval) := nv :: nv :: nil.

Definition needs_of_condition (cond: condition): list nval :=
  match cond with
  | Cmaskzero n | Cmasknotzero n => op1 (maskzero n)
  | _ => nil
  end.

Definition needs_of_operation (op: operation) (nv: nval): list nval :=
  match op with
  | Omove => op1 nv
  | Ointconst n => nil
  | Ofloatconst n => nil
  | Osingleconst n => nil
  | Oaddrsymbol id ofs => nil
  | Oaddrstack ofs => nil
  | Ocast8signed => op1 (sign_ext 8 nv)
  | Ocast16signed => op1 (sign_ext 16 nv)
  | Oadd => op2 (modarith nv)
  | Oaddimm n => op1 (modarith nv)
  | Oaddsymbol id ofs => op1 (modarith nv)
  | Osub => op2 (default nv)
  | Osubimm n => op1 (default nv)
  | Omul => op2 (modarith nv)
  | Omulimm n => op1 (modarith nv)
  | Omulhs | Omulhu | Odiv | Odivu => op2 (default nv)
  | Oand => op2 (bitwise nv)
  | Oandimm n => op1 (andimm nv n)
  | Oor => op2 (bitwise nv)
  | Oorimm n => op1 (orimm nv n)
  | Oxor => op2 (bitwise nv)
  | Oxorimm n => op1 (bitwise nv)
  | Onot => op1 (bitwise nv)
  | Onand | Onor | Onxor | Oandc | Oorc => op2 (bitwise nv)
  | Oshl | Oshr | Oshru => op2 (default nv)
  | Oshrimm n => op1 (shrimm nv n)
  | Oshrximm n => op1 (default nv)
  | Orolm amount mask => op1 (rolm nv amount mask)
  | Oroli amount mask => op1 (default nv)
  | Olongconst n => nil
  | Ocast32signed | Ocast32unsigned | Onegl | Onotl => op1 (default nv)
  | Oaddl | Osubl | Omull | Omullhs | Omullhu | Odivl | Odivlu | Oandl | Oorl | Oxorl | Oshll | Oshrl | Oshrlu => op2 (default nv)
  | Oaddlimm _ | Oandlimm _ | Oorlimm _ | Oxorlimm _ | Oshrlimm _ | Oshrxlimm _=> op1 (default nv)
  | Orolml _ _ | Olongoffloat | Ofloatoflong => op1 (default nv)
  | Onegf | Oabsf => op1 (default nv)
  | Oaddf | Osubf | Omulf | Odivf => op2 (default nv)
  | Onegfs | Oabsfs => op1 (default nv)
  | Oaddfs | Osubfs | Omulfs | Odivfs => op2 (default nv)
  | Osingleoffloat | Ofloatofsingle => op1 (default nv)
  | Ointoffloat => op1 (default nv)
  | Ofloatofwords | Omakelong => op2 (default nv)
  | Olowlong | Ohighlong => op1 (default nv)
  | Ocmp c => needs_of_condition c
  | Osel c ty => nv :: nv :: needs_of_condition c
  end.

Definition operation_is_redundant (op: operation) (nv: nval): bool :=
  match op with
  | Ocast8signed => sign_ext_redundant 8 nv
  | Ocast16signed => sign_ext_redundant 16 nv
  | Oandimm n => andimm_redundant nv n
  | Oorimm n => orimm_redundant nv n
  | Orolm amount mask => rolm_redundant nv amount mask
  | _ => false
  end.

Ltac InvAgree :=
  match goal with
  | [H: vagree_list nil _ _ |- _ ] => inv H; InvAgree
  | [H: vagree_list (_::_) _ _ |- _ ] => inv H; InvAgree
  | _ => idtac
  end.

Ltac TrivialExists :=
  match goal with
  | [ |- exists v, Some ?x = Some v /\ _ ] => exists x; split; auto
  | _ => idtac
  end.

Section SOUNDNESS.

Variable ge: genv.
Variable sp: block.
Variables m m': mem.
Hypothesis PERM: forall b ofs k p, Mem.perm m b ofs k p -> Mem.perm m' b ofs k p.

Lemma needs_of_condition_sound:
  forall cond args b args',
  eval_condition cond args m = Some b ->
  vagree_list args args' (needs_of_condition cond) ->
  eval_condition cond args' m' = Some b.
Proof.
  intros. destruct cond; simpl in H;
  try (eapply default_needs_of_condition_sound; eauto; fail);
  simpl in *; FuncInv; InvAgree.
- eapply maskzero_sound; eauto.
- destruct (Val.maskzero_bool v i) as [b'|] eqn:MZ; try discriminate.
  erewrite maskzero_sound; eauto.
Qed.

Lemma needs_of_operation_sound:
  forall op args v nv args',
  eval_operation ge (Vptr sp Ptrofs.zero) op args m = Some v ->
  vagree_list args args' (needs_of_operation op nv) ->
  nv <> Nothing ->
  exists v',
     eval_operation ge (Vptr sp Ptrofs.zero) op args' m' = Some v'
  /\ vagree v v' nv.
Proof.
  unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail);
  simpl in *; FuncInv; InvAgree; TrivialExists.
- apply sign_ext_sound; auto. compute; auto.
- apply sign_ext_sound; auto. compute; auto.
- apply add_sound; auto.
- apply add_sound; auto with na.
- apply add_sound; auto with na.
- apply mul_sound; auto.
- apply mul_sound; auto with na.
- apply and_sound; auto.
- apply andimm_sound; auto.
- apply or_sound; auto.
- apply orimm_sound; auto.
- apply xor_sound; auto.
- apply xor_sound; auto with na.
- apply notint_sound; auto.
- apply notint_sound. apply and_sound; rewrite bitwise_idem; auto.
- apply notint_sound. apply or_sound; rewrite bitwise_idem; auto.
- apply notint_sound. apply xor_sound; rewrite bitwise_idem; auto.
- apply and_sound; auto. apply notint_sound; rewrite bitwise_idem; auto.
- apply or_sound; auto. apply notint_sound; rewrite bitwise_idem; auto.
- apply shrimm_sound; auto.
- apply rolm_sound; auto.
- destruct (eval_condition c args m) as [b|] eqn:EC; simpl in H2.
  erewrite needs_of_condition_sound by eauto.
  subst v; simpl. auto with na.
  subst v; auto with na.
- destruct (eval_condition c args m) as [b|] eqn:EC.
  erewrite needs_of_condition_sound by eauto.
  apply select_sound; auto.
  simpl; auto with na.
Qed.

Lemma operation_is_redundant_sound:
  forall op nv arg1 args v arg1' args',
  operation_is_redundant op nv = true ->
  eval_operation ge (Vptr sp Ptrofs.zero) op (arg1 :: args) m = Some v ->
  vagree_list (arg1 :: args) (arg1' :: args') (needs_of_operation op nv) ->
  vagree v arg1' nv.
Proof.
  intros. destruct op; simpl in *; try discriminate; inv H1; FuncInv; subst.
- apply sign_ext_redundant_sound; auto. lia.
- apply sign_ext_redundant_sound; auto. lia.
- apply andimm_redundant_sound; auto.
- apply orimm_redundant_sound; auto.
- apply rolm_redundant_sound; auto.
Qed.

End SOUNDNESS.


(** * An x86 Machine *)
Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.Decidable.
Require Export Crypto.BoundedArithmetic.Interface.
Require Export Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.Linearize.
Require Import Crypto.Reflection.Inline.
Require Export Crypto.Reflection.Reify.
Require Export Crypto.Util.Notations.

Open Scope Z_scope.
Local Notation eta x := (fst x, snd x).
Local Notation eta3 x := (eta (fst x), snd x).
Local Notation eta3' x := (fst x, eta (snd x)).

(** ** Reflective Assembly Syntax *)
Section reflection.
  Context {n} (ops : x86.instructions n).
  Local Set Boolean Equality Schemes.
  Local Set Decidable Equality Schemes.
  Inductive base_type := TZ | Tbool | TW.
  Global Instance dec_base_type : DecidableRel (@eq base_type)
    := base_type_eq_dec.
  Definition interp_base_type (v : base_type) : Type :=
    match v with
    | TZ => Z
    | Tbool => bool
    | TW => x86.W
    end.
  Local Notation tZ := (Tbase TZ).
  Local Notation tbool := (Tbase Tbool).
  Local Notation tW := (Tbase TW).
  Local Open Scope ctype_scope.
  Inductive op : flat_type base_type -> flat_type base_type -> Type :=
  | OPldi     : op tZ tW
  | OPshrd    : op (tW * tW * tZ) (tbool * tW)
  | OPshl     : op (tW * tZ) (tbool * tW)
  | OPshr     : op (tW * tZ) (tbool * tW)
  | OPadc     : op (tW * tW * tbool) (tbool * tW)
  | OPsubc    : op (tW * tW * tbool) (tbool * tW)
  | OPmuldw   : op (tW * tW) (tbool * (tW * tW))
  | OPselc    : op (tbool * tW * tW) tW
  | OPor      : op (tW * tW) (tbool * tW).

  Definition interp_op src dst (f : op src dst)
    : interp_flat_type_gen interp_base_type src -> interp_flat_type_gen interp_base_type dst
    := match f in op s d return interp_flat_type_gen _ s -> interp_flat_type_gen _ d with
       | OPldi     => ldi
       | OPshrd    => fun xyz => let '(x, y, z) := eta3 xyz in shrdf x y z
       | OPshl     => fun xy => let '(x, y) := eta xy in shlf x y
       | OPshr     => fun xy => let '(x, y) := eta xy in shrf x y
       | OPadc     => fun xyz => let '(x, y, z) := eta3 xyz in adc x y z
       | OPsubc    => fun xyz => let '(x, y, z) := eta3 xyz in subc x y z
       | OPmuldw   => fun xy => let '(x, y) := eta xy in muldwf x y
       | OPselc    => fun xyz => let '(x, y, z) := eta3 xyz in selc x y z
       | OPor      => fun xy => let '(x, y) := eta xy in orf x y
       end.

  Definition Inline {t} e := @InlineConst base_type interp_base_type op t e.
End reflection.

Ltac base_reify_op op op_head ::=
     lazymatch op_head with
     | @Interface.ldi => constr:(reify_op op op_head 1 OPldi)
     | @Interface.shrdf => constr:(reify_op op op_head 3 OPshrd)
     | @Interface.shlf => constr:(reify_op op op_head 2 OPshl)
     | @Interface.shrf => constr:(reify_op op op_head 2 OPshr)
     | @Interface.adc => constr:(reify_op op op_head 3 OPadc)
     | @Interface.subc => constr:(reify_op op op_head 3 OPsubc)
     | @Interface.muldwf => constr:(reify_op op op_head 2 OPmuldw)
     | @Interface.selc => constr:(reify_op op op_head 3 OPselc)
     | @Interface.orf => constr:(reify_op op op_head 3 OPor)
     end.
Ltac base_reify_type T ::=
     match T with
     | Z => TZ
     | bool => Tbool
     | x86.W => TW
     end.

Ltac Reify' e := Reify.Reify' base_type (interp_base_type _) op e.
Ltac Reify e :=
  let v := Reify.Reify base_type (interp_base_type _) op e in
  constr:(Inline _ ((*CSE _*) (InlineConst (Linearize v)))).
(*Ltac Reify_rhs := Reify.Reify_rhs base_type (interp_base_type _) op (interp_op _).*)


From iris.algebra Require Import list.
From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Export invariants.
From mwp.mwp_modalities Require Import mwp_step_fupd.
From mwp.mwp_modalities.ni_logrel Require Import mwp_left mwp_right ni_logrel_lemmas.
From logrel_ifc.lambda_sec Require Export lattice fundamental_binary notation.

Local Instance tpSecurityLattice : SecurityLattice tplabel := { ζ := L }.
Notation H := (LLabel H).
Notation L := (LLabel L).

(* This example is inspired by [value_dependent_pack_no_ref.v] but instead of a
   boolean to determine the sensitivity level we use a predicate (n < 42) on a
   value to determine the sensitivity level. *)
Definition get : val :=
  λ: if: (Proj1 $0) < 42 then InjL (Proj2 $0) else InjR (Proj2 $0).

Definition make_dep : expr :=
  λ: pack: ($0, (# get)).

(* (αᴸ →ᴴ (Natᴴ + Natᴸ)ᴸ)ᴸ *)
Definition get_typ : sectype :=
  (($0 @ L) →[H] (((TNat @ H) + (TNat @ L)) @ L)) @ L.

(* ∃ α,
     (αᴸ ×
     (αᴸ →ᴴ (NatH + Natᴸ)ᴸ)ᴸ)ᴸ
 *)
Definition make_dep_typ : type :=
  ∃: ((($0 @ L) * get_typ) @ L).

(************************ Proofs ************************)

Section un_defs.
  Context `{secG_un Σ}.

  (* unary semantic interpretations *)
  Definition is_dep_pair_un  : val -d> iPropO Σ := λ v,
    (∃ n d, ⌜v = (n, d)%V⌝ ∗ ⌊ TNat ⌋ [] [] n ∗ ⌊ TNat ⌋ [] [] d)%I.

  Definition is_get_un `{secG_un Σ} Δ ρ (v : val) :=
    (⌊ get_typ ⌋ₛ (is_dep_pair_un :: Δ) ρ v)%I.

  Lemma get_is_get_un Δ ρ :
    env_Persistent Δ →
    ⊢ is_get_un Δ ρ get.
  Proof.
    rewrite /is_get_un /get_typ interp_un_sec_def interp_un_arrow_def /get.
    iIntros (Hpers) "!> %v #Hpair %Hflow". utvars.
    iDestruct "Hpair" as (b d) "[-> [Hn Hd]]". unats.
    iDestruct "Hn" as (n) "->".
    iApply mwp_step_fupd_pure_step; [done|].
    iModIntro. asimpl.
    iApply (mwp_step_fupd_bind _ (fill [BinOpLCtx _ _; IfCtx _ _])).
    rewrite nat_to_val pair_to_val.
    iApply mwp_step_fupd_pure_step; [done|]. rewrite -/of_val. iModIntro.
    iApply mwp_value; umods. iModIntro.
    iApply (mwp_step_fupd_bind _ (fill [IfCtx _ _])).
    iApply mwp_step_fupd_pure_step; [done|]. rewrite -/of_val. iModIntro.
    iApply mwp_value; umods. iModIntro.
    case_bool_decide.
    - iApply mwp_step_fupd_pure_step; [done|]. iModIntro.
      iApply (mwp_step_fupd_bind _ (fill [InjLCtx])).
      iApply mwp_step_fupd_pure_step; [done|]. iModIntro.
      iApply mwp_value; umods. iModIntro.
      iApply (mwp_value (mwpd_step_fupd _)); umods. iModIntro.
      rewrite interp_un_sum_def; auto.
    - iApply mwp_step_fupd_pure_step; [done|]. iModIntro.
      iApply (mwp_step_fupd_bind _ (fill [InjRCtx])).
      iApply mwp_step_fupd_pure_step; [done|]. iModIntro.
      iApply mwp_value; umods. iModIntro.
      iApply (mwp_value (mwpd_step_fupd _)); umods. iModIntro.
      rewrite interp_un_sum_def; auto.
  Qed.

End un_defs.

Notation is_dep_pair_left := (@is_dep_pair_un _ secG_un_left).
Notation is_dep_pair_right := (@is_dep_pair_un _ secG_un_right).

Section bi_defs.
  Context `{!secG Σ}.

  (* binary semantic interpretations *)
  Definition is_dep_pair : val * val -d> iPropO Σ := λ vv,
    (∃ (n : nat) d1 d2, ⌜vv.1 = (n, d1)%V⌝ ∗ ⌜vv.2 = (n, d2)%V⌝
        ∗ ⟦ TNat @ (if bool_decide (n < 42) then H else L) ⟧ₛ [] [] (d1, d2))%I.

  Definition is_get Θ ρ (vv : val * val) :=
    (⟦ get_typ ⟧ₛ ((is_dep_pair, (is_dep_pair_left, is_dep_pair_right)) :: Θ) ρ vv)%I.

  Definition is_dep Θ ρ : val * val -d> iPropO Σ := λ vv,
    (∃ p getp, ⌜vv.1 = (p.1, getp.1)%V⌝ ∗ ⌜vv.2 = (p.2, getp.2)%V⌝ ∗
         is_dep_pair p ∗ is_get Θ ρ getp )%I.

  (* functions satisfy their binary interpretations *)
  Lemma get_is_get Θ ρ :
    envs_Persistent Θ →
    ⊢ is_get Θ ρ (get, get).
  Proof.
    intros ?. rewrite /is_get /get_typ interp_sec_def interp_arrow_def.
    rewrite bool_decide_eq_true_2 //.
    iSplit; last first.
    { iSplit; iApply get_is_get_un. }
    iIntros "!>" ([w1 w2]) "Hpair".
    rewrite interp_sec_def interp_tvar_def /is_dep_pair /=.
    rewrite bool_decide_eq_true_2 //.
    iDestruct "Hpair" as (n d1 d2) "(-> & -> & Hinv)".
    iApply mwp_left_pure_step; [done|].
    iApply mwp_left_pure_step_index; [done|].
    asimpl. iModIntro.
    iApply (mwp_left_strong_bind _ _ (fill [BinOpLCtx _ _; IfCtx _ _]) (fill [BinOpLCtx _ _; IfCtx _ _])).
    rewrite !nat_to_val.
    iApply mwp_left_pure_step; [done|].
    iApply mwp_left_pure_step_index; [done|].
    iApply mwp_value; umods.
    iApply (mwp_value (mwpd_right _)); umods. do 2 iModIntro.
    iApply (mwp_left_strong_bind _ _ (fill [IfCtx _ _]) (fill [IfCtx _ _])).
    rewrite !nat_to_val.
    iApply mwp_left_pure_step; [done|].
    iApply mwp_left_pure_step_index; [done|]. cbn.
    rewrite !bool_to_val. iModIntro.
    iApply (mwp_value mwp_binary); umods.
    iApply (mwp_value (mwpd_right _)); umods. iModIntro.
    case_bool_decide.
    - iApply mwp_left_pure_step; [done|].
      iApply mwp_left_pure_step_index; [done|]. cbn. iModIntro.
      iApply (mwp_left_strong_bind _ _ (fill [InjLCtx]) (fill [InjLCtx])).
      rewrite !nat_to_val.
      iApply mwp_left_pure_step; [done|].
      iApply mwp_left_pure_step_index; [done|]. cbn.
      iApply (mwp_value mwp_binary); umods.
      iApply (mwp_value (mwpd_right _)); umods. do 2 iModIntro.
      iApply (mwp_value mwp_binary); umods.
      iApply (mwp_value (mwpd_right _)); umods. iModIntro.
      rewrite [⟦ _ + _ @ L ⟧ₛ _ _ _]interp_sec_def interp_sum_def.
      rewrite bool_decide_eq_true_2 //. eauto.
    - iApply mwp_left_pure_step; [done|].
      iApply mwp_left_pure_step_index; [done|]. cbn. iModIntro.
      iApply (mwp_left_strong_bind _ _ (fill [InjRCtx]) (fill [InjRCtx])).
      rewrite !nat_to_val.
      iApply mwp_left_pure_step; [done|].
      iApply mwp_left_pure_step_index; [done|]. cbn.
      iApply (mwp_value mwp_binary); umods.
      iApply (mwp_value (mwpd_right _)); umods. do 2 iModIntro.
      iApply (mwp_value mwp_binary); umods.
      iApply (mwp_value (mwpd_right _)); umods. iModIntro.
      rewrite [⟦ _ + _ @ L ⟧ₛ _ _ _]interp_sec_def interp_sum_def.
      rewrite bool_decide_eq_true_2 //. eauto.
   Qed.

  Lemma is_dep_pair_coh :
    ⊢ <pers> (∀ vv : val * val, is_dep_pair vv → (is_dep_pair_left vv.1) ∧ (is_dep_pair_right vv.2)).
  Proof.
    iIntros "!>" ([v1 v2]) "Hdep /=".
    rewrite /is_dep_pair /is_dep_pair_un /=.
    iDestruct "Hdep" as (n d1 d2) "(-> & -> & Hdep)".
    case_bool_decide; cbn.
    - iDestruct (secbin_subsumes_secun with "[$Hdep]") as "[??] /=".
      { rewrite /env_coherent //. }
      rewrite interp_un_sec_def.
      iSplit.
      + iExists _,_. iSplit; [done|].
        rewrite !interp_un_nat_def; eauto.
      + iExists _,_. iSplit; [done|].
        rewrite !interp_un_nat_def; eauto.
    - iDestruct (secbin_subsumes_secun with "[$Hdep]") as "[??] /=".
      { rewrite /env_coherent //. }
      rewrite interp_un_sec_def.
      iSplit.
      + iExists _,_. iSplit; [done|].
        rewrite !interp_un_nat_def; eauto.
      + iExists _,_. iSplit; [done|].
        rewrite !interp_un_nat_def; eauto.
  Qed.

  Lemma make_dep_spec (n d1 d2 : nat) :
    (¬ n < 42 → d1 = d2) → (* input should satisfy the security policy *)
    [] ⊨ make_dep (n, d1)%E  ≤ₗ make_dep (n, d2)%E : make_dep_typ @ L.
  Proof.
    iIntros (Hleq Θ ρ vvs Hpers) "[#Hcoh _]".
    rewrite /make_dep_typ.
    rewrite !nat_to_val !pair_to_val.
    iApply mwp_left_pure_step; [done|].
    iApply mwp_left_pure_step_index; [done|].
    cbn. iModIntro. asimpl.
    iApply (mwp_value mwp_binary); umods.
    iApply (mwp_value mwp_right); umods.
    rewrite interp_sec_def bool_decide_eq_true_2 //.
    rewrite interp_exist_def.
    do 2 iModIntro.
    iExists is_dep_pair, is_dep_pair_left, is_dep_pair_right.
    rewrite -/get.
    repeat (iSplit; [iPureIntro; apply _|]).
    iSplit; [iApply is_dep_pair_coh|].
    iExists (_, _). cbn. do 2 (iSplit; [done|]).
    rewrite [⟦ _ * _ @ L ⟧ₛ _ _ _]interp_sec_def !interp_prod_def.
    rewrite bool_decide_eq_true_2 //.
    iExists (_,_)%V,_,(_,_)%V,_. do 2 (iSplit; [done|]).
    iSplit; last iApply get_is_get.
    rewrite /is_dep_pair.
    rewrite [⟦ $0 @ L ⟧ₛ _ _ _]interp_sec_def interp_tvar_def.
    rewrite bool_decide_eq_true_2 //=.
    iExists _,_,_.
    do 2 (iSplit; [done|]).
    case_bool_decide as Heq; rewrite  interp_sec_def interp_nat_def.
    - rewrite bool_decide_eq_false_2 //.
      rewrite !interp_un_sec_def !interp_un_nat_def //=. eauto.
    - rewrite bool_decide_eq_true_2 // (Hleq Heq). eauto.
  Qed.

End bi_defs.


From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.
From BitBlasting Require Import QFBV CNF BBCommon.
From ssrlib Require Import ZAriths Tactics.
From nbits Require Import NBits.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* ===== bit_blast_conj ===== *)

Definition bit_blast_conj g (a1 a2 : literal) : generator * cnf * literal :=
  let (g', r) := gen g in
  let cs := [:: [:: neg_lit r; a1]; [:: neg_lit r; a2]; [:: r; neg_lit a1; neg_lit a2]] in
  (g', cs, r).

Definition mk_env_conj E g (a1 a2 : literal) : env * generator * cnf * literal :=
  let (g', r) := gen g in
  let E' := env_upd E (var_of_lit r) (interp_lit E a1 && interp_lit E a2) in
  let cs := [:: [:: neg_lit r; a1]; [:: neg_lit r; a2]; [:: r; neg_lit a1; neg_lit a2]] in
  (E', g', cs, r).

Lemma bit_blast_conj_correct :
  forall g (b1 b2 : bool) E g' (l1 l2 : literal) cs lr,
    bit_blast_conj g l1 l2 = (g', cs, lr) ->
    enc_bit E l1 b1 -> enc_bit E l2 b2 ->
    interp_cnf E (add_prelude cs) ->
    enc_bit E lr (b1 && b2).
Proof.
  move=> g b1 b2 E g' l1 l2 cs lr. rewrite /bit_blast_conj.
  case=> _ <- <- Henc1 Henc2. rewrite /enc_bit /=.
  rewrite add_prelude_cons !add_prelude_singleton !interp_clause_cons.
  rewrite add_prelude_cons !add_prelude_singleton !interp_clause_cons.
  rewrite !interp_lit_neg_lit /=.
  rewrite (eqP Henc1) (eqP Henc2) => {Henc1 Henc2}.
  move=> Hand. split_andb_hyps.
  move: H2 H3 H4.
  by case: (E g); case: b1; case: b2.
Qed.

Lemma mk_env_conj_is_bit_blast_conj :
  forall E g (l1 l2 : literal) E' g' cs lr,
    mk_env_conj E g l1 l2 = (E', g', cs, lr) ->
    bit_blast_conj g l1 l2 = (g', cs, lr).
Proof.
  rewrite /mk_env_conj /bit_blast_conj /=; intros; dcase_hyps; subst; reflexivity.
Qed.

Lemma mk_env_conj_newer_gen :
  forall E g (l1 l2 : literal) E' g' cs lr,
    mk_env_conj E g l1 l2 = (E', g', cs, lr) ->
    (g <=? g')%positive.
Proof.
  move=> E g l1 l2 E' g' cs lr. case=> _ <- _ _. t_auto_newer.
Qed.

Lemma mk_env_conj_newer_res :
  forall E g (l1 l2 : literal) E' g' cs lr,
    mk_env_conj E g l1 l2 = (E', g', cs, lr) ->
    newer_than_lit g' lr.
Proof.
  move=> E g l1 l2 E' g' cs lr. case=> _ <- _ <-.
  t_auto_newer.
Qed.

Lemma mk_env_conj_newer_cnf :
  forall E g (l1 l2 : literal) E' g' cs lr,
    mk_env_conj E g l1 l2 = (E', g', cs, lr) ->
    newer_than_lit g l1 -> newer_than_lit g l2 ->
    newer_than_cnf g' cs.
Proof.
  move=> E g l1 l2 E' g' cs lr. case=> _ <- <- _ Hnew_l1 Hnew_l2 /=.
  split_andb_goal; t_auto_newer.
Qed.

Lemma mk_env_conj_preserve :
  forall E g (l1 l2 : literal) E' g' cs lr,
    mk_env_conj E g l1 l2 = (E', g', cs, lr) ->
    env_preserve E E' g.
Proof.
  move=> E g l1 l2 E' g' cs lr. case=> <- _ _ _.
  t_auto_preserve.
Qed.

Lemma mk_env_conj_sat :
  forall E g (l1 l2 : literal) E' g' cs lr,
    mk_env_conj E g l1 l2 = (E', g', cs, lr) ->
    newer_than_lit g l1 -> newer_than_lit g l2 ->
    interp_cnf E' cs.
Proof.
  move=> E g l1 l2 E' g' cs lr. case=> <- _ <- Hlr /= Hnew1 Hnew2.
  rewrite !interp_lit_neg_lit. rewrite env_upd_eq.
  rewrite (interp_lit_env_upd_neq _ _ (newer_than_lit_neq Hnew1)).
  rewrite (interp_lit_env_upd_neq _ _ (newer_than_lit_neq Hnew2)).
  by case: (interp_lit E l1); case: (interp_lit E l2).
Qed.

Lemma mk_env_conj_env_equal E1 E2 g l1 l2 E1' E2' g1' g2' cs1 cs2 lr1 lr2 :
  env_equal E1 E2 ->
  mk_env_conj E1 g l1 l2 = (E1', g1', cs1, lr1) ->
  mk_env_conj E2 g l1 l2 = (E2', g2', cs2, lr2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lr1 = lr2.
Proof.
  rewrite /mk_env_conj => Heq. dcase (gen g) => [[g' r'] Hg'].
  rewrite !(env_equal_interp_lit _ Heq). case=> ? ? ? ?; case=> ? ? ? ?; subst.
  repeat split. apply: env_equal_upd. assumption.
Qed.


From MetaCoq.Lob.Template.QuoteGround Require Export Coq.Init.
From MetaCoq.Template.utils Require Import ReflectEq.

#[export] Instance quote_reflectProp {A:Prop} {qA : quotation_of A} {quoteA : ground_quotable A} {quote_negA : ground_quotable (~A)} {b} : ground_quotable (@reflectProp A b).
Proof.
  destruct b; adjust_ground_quotable_by_econstructor_inversion ().
Defined.