Require Import Containers.Maps MapInterface MapFacts.
Require Import BaseTactics ILogic ILEmbed.

Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.

  Record find_res (A : Type) := mkf {
    find_types : Tlist;
    find_closure : arrows find_types A
  }.

	Definition find_res_unop {A B : Type} (op : A -> B) (a : option (find_res A)) :
  	option (find_res B) :=
  	match a with
  		| Some a => Some (mkf (arrows_unop op (find_closure a)))
  		| None => None
  	end.

  Definition find_res_binop {A B C : Type} (op : A -> B -> C) (a : option (find_res A))
  	(b: option (find_res B)) : option (find_res C) :=
  	match a, b with
  	  | Some a, Some b => Some (mkf (arrows_binop_merge op (find_closure a) (find_closure b)))
  	  | _,      _      => None
  	end.

  	Definition find_res_create {A : Type} (a : option A) : option (find_res A) :=
  	match a with
  		| Some a => Some (@mkf A Tnil a)
  		| None   => None
  	end.

	Definition find_res_bind {A T : Type} {H : Inhabited T} (f : T -> A) :=
	@mkf A (Tcons T Tnil) f.

 	Fixpoint find_res_eval_exists_aux {A : Type} {ILA : ILogicOps A} (Ts : Tlist)
		: arrows Ts A -> A :=
		match Ts with
		  | Tnil => fun p => p
		  | Tcons T Ts => fun p => Exists x : T, find_res_eval_exists_aux (p x)
	    end.

	Definition find_res_eval_exists {A : Type} {ILA : ILogicOps A} (p : find_res A) :=
		find_res_eval_exists_aux (find_closure p).

Fixpoint pull_exists_r {A : Type} {ILA : ILogicOps A}
(t : @deep_op A ILA) (de_env : env A) (tac_env : env (find_res A)) : option (find_res A) :=
match t with
	| t_and t1 t2   => find_res_binop land (pull_exists_r t1 de_env tac_env) (pull_exists_r t2 de_env tac_env)
	| t_or  t1 t2   => find_res_binop lor (pull_exists_r t1 de_env tac_env) (pull_exists_r t2 de_env tac_env)
	| t_exists T f  => Some (@mkf A (Tcons T Tnil) f)
	| t_and_inj B _ _ _ _ _ _ a b => find_res_binop lembedand (pull_exists_r a (env_empty B) (env_empty (find_res B)))
	                         (pull_exists_r b de_env tac_env)
	| t_and_prop _ _ a b => find_res_binop lembedand (pull_exists_r a (env_empty Prop) (env_empty (find_res Prop)))
	                         (pull_exists_r b de_env tac_env)
    | t_unop n p =>
    	match ((fst tac_env) [n]) with
    		| Some f => unop_option f (pull_exists_r p de_env tac_env)
    		| None => None
    	end
	| t_binop n p q =>
		match ((snd tac_env) [n]) with
			| Some f => binop_option f (pull_exists_r p de_env tac_env) (pull_exists_r q de_env tac_env)
			| None => None
		end
    | _ => match deep_op_eval de_env t with
    	     | Some t => Some (@mkf A Tnil t)
    	     | None   => None
    	   end
end.

Section PullExistsRight.

	Lemma find_res_unop_sound_er {Ts : Tlist} {A B : Type} {ILA : ILogicOps A} `{ILB : ILogic B}
	        (f : arrows Ts A) (op : A -> B)
	        (Hop : forall T (f : T -> A), Exists x, op (f x) |-- op (Exists x, f x)) :
	      find_res_eval_exists_aux(arrows_unop op f) |-- op (find_res_eval_exists_aux f).
	Proof.
		induction Ts.
		simpl. reflexivity.
		simpl in *. rewrite <- Hop.
		apply lexistsL; intro x. apply lexistsR with x.
		rewrite IHTs; firstorder.
	Qed.

 Lemma find_res_binop_sound_er {Ts Us : Tlist} {A B C : Type} {ILA : ILogicOps A} {ILB : ILogicOps B} `{ILC : ILogic C}
        (f : arrows Ts A) (g : arrows Us B) (op : A -> B -> C)
        (Hop1 : forall T (f : T -> A) g, Exists x, op (f x) g |-- op (Exists x, f x) g)
        (Hop2 : forall T f (g : T -> B), Exists x, op f (g x) |-- op f (Exists x, g x)) :
      find_res_eval_exists_aux (arrows_binop_merge op f g) |-- op (find_res_eval_exists_aux f) (find_res_eval_exists_aux g).
Proof.
	induction Ts; simpl in *.
	+ apply find_res_unop_sound_er.
	  intros. apply Hop2.
	+ rewrite <- Hop1.
      apply lexistsL; intro x; apply lexistsR with x.
	  rewrite <- IHTs; try tauto; reflexivity.
Qed.

  Lemma binop_sound_er {A B C : Type} {ILA : ILogicOps A} {ILB : ILogicOps B} `{ILC : ILogic C}
                        (de_env1 : env A) (tac_env1 : env (find_res A))
                       (de_env2 : env B) (tac_env2 : env (find_res B))
                       (p : @deep_op A ILA) (q : @deep_op B ILB) (op : A -> B -> C)
                       {H : Proper (lentails ==> lentails ==> lentails) op}
      (Hp : match deep_op_eval de_env1 p, pull_exists_r p de_env1 tac_env1 with
	    | None, None => True
	    | Some p, Some q => find_res_eval_exists q |-- p
	    | _, _ => True
	  end)
      (Hq : match deep_op_eval de_env2 q, pull_exists_r q de_env2 tac_env2 with
	    | None, None => True
	    | Some p, Some q => find_res_eval_exists q |-- p
	    | _, _ => True
	  end)
        (Hop1 : forall T (f : T -> A) g, Exists x, op (f x) g |-- op (Exists x, f x) g)
        (Hop2 : forall T f (g : T -> B), Exists x, op f (g x) |-- op f (Exists x, g x)) :
match binop_option op (deep_op_eval de_env1 p) (deep_op_eval de_env2 q),
      find_res_binop op (pull_exists_r p de_env1 tac_env1) (pull_exists_r q de_env2 tac_env2) with
  | None, None     => True
  | Some p, Some q => find_res_eval_exists q |-- p
  | _, _           => True
end.
Proof.
	remember (deep_op_eval de_env1 p) as o1.
	remember (deep_op_eval de_env2 q) as o2.
	remember (pull_exists_r p de_env1 tac_env1) as o3.
	remember (pull_exists_r q de_env2 tac_env2) as o4.
	destruct o1, o2, o3, o4; simpl in *; try intuition congruence.
	etransitivity; [|apply H; [apply Hp | apply Hq]].
	destruct f; destruct f0.
	apply find_res_binop_sound_er; assumption.
Qed.

  	Lemma env_sound_aux_er {A : Type} `{ILA : ILogic A}
  	(de_env : env A) (tac_env : env (find_res A))
    (t : @deep_op A _) (H : env_sound_lr de_env tac_env find_res_eval_exists) :
    match deep_op_eval de_env t, pull_exists_r t de_env tac_env with
      | None, None     => True
      | Some p, Some q => find_res_eval_exists q |-- p
      | _, _           => True
    end.
    Proof.
    	induction t.
    	+ simpl; reflexivity.
    	+ simpl; reflexivity.
    	+ simpl; reflexivity.
        + apply binop_sound_er; [apply IHt1; assumption | apply IHt2; assumption | |].
          intros. apply landexistsDR.
          intros. rewrite landC, <- landexistsDR. setoid_rewrite landC at 1. reflexivity.
        + apply binop_sound_er; [apply IHt1; assumption | apply IHt2; assumption | |].
          intros. apply lorexistsDR.
          intros. rewrite lorC, <- lorexistsDR. setoid_rewrite lorC at 1; reflexivity.
        + simpl; remember (deep_op_eval de_env t1) as o1.
	      remember (deep_op_eval de_env t2) as o2.
	      destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + simpl.
          specialize (IHt ILA de_env tac_env H).
          remember (fst de_env) [n] as o1.
          remember (fst tac_env) [n] as o2.
          remember (deep_op_eval de_env t) as o3.
          remember (pull_exists_r t de_env tac_env) as o4.
          destruct o1, o2, o3, o4; simpl in *; try intuition congruence.
          symmetry in Heqo2;
          destruct H as [H _]; specialize (H f n Heqo2); destruct H as [g [H3 [H4 H5]]];
          rewrite <- Heqo1 in H3; inversion H3; subst.
          rewrite H5. apply H4. apply IHt.
        + simpl.
          specialize (IHt1 ILA de_env tac_env H); specialize (IHt2 ILA de_env tac_env H).
          remember (snd de_env) [n] as o1.
          remember (snd tac_env) [n] as o2.
          remember (deep_op_eval de_env t1) as o3.
          remember (deep_op_eval de_env t2) as o4.
          remember (pull_exists_r t1 de_env tac_env) as o5.
          remember (pull_exists_r t2 de_env tac_env) as o6.
          destruct o1, o2, o3, o4, o5, o6; simpl in *; try intuition congruence.
          symmetry in Heqo2;
          destruct H as [_ H]; specialize (H f n Heqo2); destruct H as [g [H3 [H4 H5]]];
          rewrite <- Heqo1 in H3; inversion H3; subst.
          rewrite H5. apply H4; [apply IHt1 | apply IHt2].
	    + simpl. reflexivity.
        + simpl. reflexivity.
        + apply binop_sound_er.
          apply IHt1. assumption. apply env_sound_lr_empty.
          apply IHt2. assumption. assumption.
          intros. unfold lembedand. rewrite <- embedlexists, landexistsDR. reflexivity.
          intros. unfold lembedand. rewrite landC, <- landexistsDR. setoid_rewrite landC at 1. reflexivity.
        + simpl. remember (deep_op_eval (env_empty B) t1) as o1.
          remember (deep_op_eval de_env t2) as o2.
          destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + apply binop_sound_er.
          apply IHt1. apply _. apply env_sound_lr_empty.
          apply IHt2; assumption.
          intros. unfold lembedand. rewrite <- embedlexists, landexistsDR. reflexivity.
          intros. unfold lembedand. rewrite landC, <- landexistsDR. setoid_rewrite landC at 1. reflexivity.
        + simpl. remember (deep_op_eval (env_empty Prop) t1) as o1.
          remember (deep_op_eval de_env t2) as o2.
          destruct o1, o2; simpl; (try intuition congruence); reflexivity.
    Qed.

    Implicit Arguments env_sound_aux_er [[A] [ILOps] [ILA]].

  	Lemma env_sound_er {A : Type} `{ILA : ILogic A}
  		               (de_env : env A) (tac_env : env (find_res A))
    (t : @deep_op A _) (H : env_sound_lr de_env tac_env find_res_eval_exists) (P : A) :
    match deep_op_eval de_env t, pull_exists_r t de_env tac_env with
      | None, None     => True
      | Some p, Some q => P |-- find_res_eval_exists q -> P |-- p
      | _, _           => True
    end.
    Proof.
    	pose proof (env_sound_aux_er de_env tac_env t H).
    	remember (deep_op_eval de_env t) as o1.
    	remember (pull_exists_r t de_env tac_env) as o2.
    	destruct o1, o2; simpl in *; try intuition congruence.
    	intros. rewrite <- H0; assumption.
    Qed.

End PullExistsRight.

Implicit Arguments env_sound_er [[A] [ILOps] [ILA]].

Ltac lexistsR_aux :=
  match goal with
    | |- ?P |-- ?Q =>
      let A := type of Q in
      let t := quote_term Q in
       apply (env_sound_er (env_empty A) (env_empty (find_res A)) t (env_sound_lr_empty (env_empty A) find_res_eval_exists) P);
        simpl; cbv [find_res_eval_exists find_res_eval_exists_aux]; simpl
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Ltac lexistsR2 :=
	repeat (
		repeat (
			let x := fresh "x" in
			simple eapply lexistsR
		);
  		lexistsR_aux
  	).

Tactic Notation "lexistsR" := lexistsR2.
Tactic Notation "lexistsR" constr(x1) :=
	first [simple apply lexistsR with x1 | lexistsR_aux; simple apply lexistsR with x1].
Tactic Notation "lexistsR" constr(x1) constr(x2) :=
	first [simple apply lexistsR with x1 | lexistsR_aux; simple apply lexistsR with x1]; lexistsR x2.
Tactic Notation "lexistsR" constr(x1) constr(x2) constr(x3) :=
	first [simple apply lexistsR with x1 | lexistsR_aux; simple apply lexistsR with x1]; lexistsR x2 x3.
Tactic Notation "lexistsR" constr(x1) constr(x2) constr(x3) constr(x4) :=
	first [simple apply lexistsR with x1 | lexistsR_aux; simple apply lexistsR with x1]; lexistsR x2 x3 x4.

Local Existing Instance EmbedOpId.
Local Existing Instance EmbedId.

Lemma test_er {A B : Type} `{H : Embed B A} {HBPO: EmbedOp Prop B} {HPB : Embed Prop B} {HO : EmbedOp Prop A} {HE: Embed Prop A} {HA : ILogic A} {HB : ILogic B}
    (P Q R : A) (S : B) (T : Prop) (f : nat -> A) (g : nat -> B) (h : nat -> Prop) :
  lfalse |-- (S //\\ Exists y, g y) /\\ (P //\\ (Exists y, f y) \\// R //\\ (T //\\ Exists y, h y) /\\ Exists x, f x).
Proof.
	lexistsR 3 4 5 6.
	apply lfalseL.
Qed.

Section PullExistsLeft.

Fixpoint pull_exists_l {A : Type} {ILA : ILogicOps A}
(t : @deep_op A ILA) (de_env : env A) (tac_env : env (find_res A)) : option (find_res A) :=
match t with
	| t_and t1 t2   => find_res_binop land (pull_exists_l t1 de_env tac_env) (pull_exists_l t2 de_env tac_env)
	| t_exists T f  => Some (@mkf A (Tcons T Tnil) f)
	| t_and_inj B _ _ _ _ _ _ a b => find_res_binop lembedand (pull_exists_l a (env_empty B) (env_empty (find_res B)))
	                         (pull_exists_l b de_env tac_env)
	| t_and_prop _ _ a b => find_res_binop lembedand (pull_exists_l a (env_empty Prop) (env_empty (find_res Prop)))
	                         (pull_exists_l b de_env tac_env)
    | t_unop n p =>
    	match ((fst tac_env) [n]) with
    		| Some f => unop_option f (pull_exists_l p de_env tac_env)
    		| None => None
    	end
	| t_binop n p q =>
		match ((snd tac_env) [n]) with
			| Some f => binop_option f (pull_exists_l p de_env tac_env) (pull_exists_l q de_env tac_env)
			| None => None
		end
    | _ => match deep_op_eval de_env t with
    	     | Some t => Some (@mkf A Tnil t)
    	     | None   => None
    	   end
end.

	Lemma find_res_unop_sound_el {Ts : Tlist} {A B : Type} {ILA : ILogicOps A} `{ILB : ILogic B}
	         (f : arrows Ts A) (op : A -> B)
	        (Hop : forall T (f : T -> A) , op (Exists x, f x) |-- Exists x, op (f x)) :
	      op (find_res_eval_exists_aux f) |--
	      find_res_eval_exists_aux(arrows_unop op f).
	Proof.
		induction Ts.
		simpl. reflexivity.
		simpl in *. rewrite Hop.
		apply lexistsL; intro x; apply lexistsR with x.
		apply IHTs; tauto.
	Qed.

 Lemma find_res_binop_sound_el {Ts Us : Tlist} {A B C : Type} {ILA : ILogicOps A} {ILB : ILogicOps B} `{ILC : ILogic C}
        (f : arrows Ts A) (g : arrows Us B) (op : A -> B -> C)
        (Hop1 : forall T (f : T -> A) g, op (Exists x, f x) g |-- Exists x, (op (f x) g))
        (Hop2 : forall T f (g : T -> B), op f (Exists x, g x) |-- Exists x, (op f (g x))) :
      op (find_res_eval_exists_aux f) (find_res_eval_exists_aux g) |--
      find_res_eval_exists_aux (arrows_binop_merge op f g).
Proof.
	induction Ts; simpl in *.
	+ apply find_res_unop_sound_el.
	  intros. apply Hop2.
	+ rewrite Hop1.
      apply lexistsL; intro x; apply lexistsR with x.
	  rewrite <- IHTs; try tauto; reflexivity.
Qed.

  Lemma binop_sound_el {A B C : Type} {ILA : ILogicOps A} {ILB : ILogicOps B} `{ILC : ILogic C}
                    (de_env1 : env A) (tac_env1 : env (find_res A))
                    (de_env2 : env B) (tac_env2 : env (find_res B))
                    (p : @deep_op A _) (q : @deep_op B _) (op : A -> B -> C)
                  {H : Proper (lentails ==> lentails ==> lentails) op}
      (Hp : match deep_op_eval de_env1 p, pull_exists_l p de_env1 tac_env1 with
	    | None, None => True
	    | Some p, Some q => p |-- find_res_eval_exists q
	    | _, _ => True
	  end)
      (Hq : match deep_op_eval de_env2 q, pull_exists_l q de_env2 tac_env2 with
	    | None, None => True
	    | Some p, Some q => p |-- find_res_eval_exists q
	    | _, _ => True
	  end)
        (Hop1 : forall T (f : T -> A) g, op (Exists x, f x) g |-- Exists x, (op (f x) g))
        (Hop2 : forall T f (g : T -> B), op f (Exists x, g x) |-- Exists x, (op f (g x))) :
match binop_option op (deep_op_eval de_env1 p) (deep_op_eval de_env2 q),
      find_res_binop op (pull_exists_l p de_env1 tac_env1) (pull_exists_l q de_env2 tac_env2) with
  | None, None     => True
  | Some p, Some q => p |-- find_res_eval_exists q
  | _, _           => True
end.
Proof.
	remember (deep_op_eval de_env1 p) as o1.
	remember (deep_op_eval de_env2 q) as o2.
	remember (pull_exists_l p de_env1 tac_env1) as o3.
	remember (pull_exists_l q de_env2 tac_env2) as o4.
	destruct o1, o2, o3, o4; simpl in *; try intuition congruence.
	etransitivity.
	apply H.
	apply Hp.
	apply Hq.
	destruct f; destruct f0.
	apply find_res_binop_sound_el; assumption.
Qed.

  	Lemma env_sound_aux_el {A : Type} `{ILA : ILogic A}
  	                       (de_env : env A) (tac_env : env (find_res A))
    (t : @deep_op A _) (H : env_sound_rl de_env tac_env find_res_eval_exists) :
    match deep_op_eval de_env t, pull_exists_l t de_env tac_env with
      | None, None     => True
      | Some p, Some q => p |-- find_res_eval_exists q
      | _, _           => True
    end.
    Proof.
    	induction t.
    	+ simpl; reflexivity.
    	+ simpl; reflexivity.
    	+ simpl; reflexivity.
        + apply binop_sound_el; [apply IHt1; assumption | apply IHt2; assumption | |].
          intros. apply landexistsDL.
          intros. rewrite landC, landexistsDL. setoid_rewrite landC at 1. reflexivity.
        + simpl; remember (deep_op_eval de_env t1) as o1.
	      remember (deep_op_eval de_env t2) as o2.
	      destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + simpl; remember (deep_op_eval de_env t1) as o1.
	      remember (deep_op_eval de_env t2) as o2.
	      destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + simpl.
          specialize (IHt ILA de_env tac_env H).
          remember (fst de_env) [n] as o1.
          remember (fst tac_env) [n] as o2.
          remember (deep_op_eval de_env t) as o3.
          remember (pull_exists_l t de_env tac_env) as o4.
          destruct o1, o2, o3, o4; simpl in *; try intuition congruence.
          symmetry in Heqo2;
          destruct H as [H _]; specialize (H f n Heqo2); destruct H as [g [H3 [H4 H5]]];
          rewrite <- Heqo1 in H3; inversion H3; subst.
          rewrite <- H5. apply H4. apply IHt.
        + simpl.
          specialize (IHt1 ILA de_env tac_env H); specialize (IHt2 ILA de_env tac_env H).
          remember (snd de_env) [n] as o1.
          remember (snd tac_env) [n] as o2.
          remember (deep_op_eval de_env t1) as o3.
          remember (deep_op_eval de_env t2) as o4.
          remember (pull_exists_l t1 de_env tac_env) as o5.
          remember (pull_exists_l t2 de_env tac_env) as o6.
          destruct o1, o2, o3, o4, o5, o6; simpl in *; try intuition congruence.
          symmetry in Heqo2;
          destruct H as [_ H]; specialize (H f n Heqo2); destruct H as [g [H3 [H4 H5]]];
          rewrite <- Heqo1 in H3; inversion H3; subst.
          rewrite <- H5. apply H4; [apply IHt1 | apply IHt2].
        + simpl. reflexivity.
        + simpl. reflexivity.
        + apply binop_sound_el.
          apply IHt1. assumption. apply env_sound_rl_empty.
          apply IHt2; assumption.
          intros. unfold lembedand. rewrite <- embedlexists, landexistsDL. reflexivity.
          intros. unfold lembedand. rewrite landC, landexistsDL. setoid_rewrite landC at 1. reflexivity.
        + simpl. remember (deep_op_eval (env_empty B) t1) as o1.
          remember (deep_op_eval de_env t2) as o2.
          destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + apply binop_sound_el.
          apply IHt1. apply _. apply (env_sound_rl_empty).
          apply IHt2; assumption.
          intros. unfold lembedand. rewrite <- embedlexists, landexistsDL. reflexivity.
          intros. unfold lembedand. rewrite landC, landexistsDL. setoid_rewrite landC at 1. reflexivity.
        + simpl. remember (deep_op_eval (env_empty Prop) t1) as o1.
          remember (deep_op_eval de_env t2) as o2.
          destruct o1, o2; simpl; (try intuition congruence); reflexivity.
    Qed.

    Implicit Arguments env_sound_aux_el [[A] [ILOps] [ILA]].

  	Lemma env_sound_el {A : Type} `{ILA : ILogic A} (de_env : env A) (tac_env : env (find_res A))
    (t : @deep_op A _) (H : env_sound_rl de_env tac_env find_res_eval_exists) (P : A) :
    match deep_op_eval de_env t, pull_exists_l t de_env tac_env with
      | None, None     => True
      | Some p, Some q => find_res_eval_exists q |-- P -> p |-- P
      | _, _           => True
    end.
    Proof.
    	pose proof (env_sound_aux_el de_env tac_env t H).
    	remember (deep_op_eval de_env t) as o1.
    	remember (pull_exists_l t de_env tac_env) as o2.
    	destruct o1, o2; simpl in *; try intuition congruence.
    	intros. rewrite H0; assumption.
    Qed.

End PullExistsLeft.

Implicit Arguments env_sound_el [[A] [ILOps] [ILA]].

Ltac lexistsL_aux :=
  match goal with
    | |- ?P |-- ?Q =>
      let A := type of P in
      let t := quote_term P in
       apply (env_sound_el (env_empty A) (env_empty (find_res A)) t (env_sound_rl_empty (env_empty A) find_res_eval_exists) Q);
        simpl; cbv [find_res_eval_exists find_res_eval_exists_aux]; simpl
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Ltac lexistsL2 :=
	repeat (
		repeat (
			let x := fresh "x" in
			simple apply lexistsL; intro x
		);
  		lexistsL_aux
  	).

Tactic Notation "lexistsL" := lexistsL2.
Tactic Notation "lexistsL" simple_intropattern(x1) :=
	first [simple apply lexistsL; intro x1 | lexistsL_aux; simple apply lexistsL; intro x1].
Tactic Notation "lexistsL" simple_intropattern(x1) simple_intropattern(x2) :=
	first [simple apply lexistsL; intro x1 | lexistsL_aux; simple apply lexistsL; intro x1]; lexistsL x2.
Tactic Notation "lexistsL" simple_intropattern(x1) simple_intropattern(x2) simple_intropattern(x3) :=
	first [simple apply lexistsL; intro x1 | lexistsL_aux; simple apply lexistsL; intro x1]; lexistsL x2 x3.
Tactic Notation "lexistsL" simple_intropattern(x1) simple_intropattern(x2) simple_intropattern(x3) simple_intropattern(x4) :=
	first [simple apply lexistsL; intro x1 | lexistsL_aux; simple apply lexistsL; intro x1]; lexistsL x2 x3 x4.

Lemma test_el {A B : Type} `{H : Embed B A} {HBPO: EmbedOp Prop B} {HPB : Embed Prop B} {HO : EmbedOp Prop A} {HE: Embed Prop A} {HA : ILogic A} {HB : ILogic B}
    (P Q R : A) (S : B) (T : Prop) (f : nat -> A) (g : nat -> B) (h : nat -> Prop) :
  (S //\\ Exists y, g y) /\\ (P //\\ (Exists y, f y) //\\ R //\\ (T //\\ Exists y, h y) /\\ Exists x, f x) |-- ltrue.
Proof.
  lexistsL a b c d.
  lexistsL. apply ltrueR.
Qed.

 	Fixpoint find_res_eval_forall_aux {A : Type} {ILA : ILogicOps A} (Ts : Tlist)
		: arrows Ts A -> A :=
		match Ts with
		  | Tnil => fun p => p
		  | Tcons T Ts => fun p => Forall x : T, find_res_eval_forall_aux (p x)
	    end.

	Definition find_res_eval_forall {A : Type} {ILA : ILogicOps A} (p : find_res A) :=
		find_res_eval_forall_aux (find_closure p).

(* Extracting universal quantifiers of the right of an entailment is currently next to useless.
   Forall does not propagate over any connective, especially not conjunction unless the type
   that is being quantified over is inhabitted. Until we fix a Gallina function that checks
   for wether types are inhabitted or not, this method is not useful. *)

Fixpoint pull_forall_r {A : Type} {ILA : ILogicOps A}
(t : @deep_op A _) (de_env : env A) (tac_env : env (find_res A)) : option (find_res A) :=
match t with
	| t_forall T f  => Some (@mkf A (Tcons T Tnil) f)
    | t_unop n p =>
    	match ((fst tac_env) [n]) with
    		| Some f => unop_option f (pull_forall_r p de_env tac_env)
    		| None => None
    	end
	| t_binop n p q =>
		match ((snd tac_env) [n]) with
			| Some f => binop_option f (pull_forall_r p de_env tac_env) (pull_forall_r q de_env tac_env)
			| None => None
		end
    | _ => match deep_op_eval de_env t with
    	     | Some t => Some (@mkf A Tnil t)
    	     | None   => None
    	   end
end.

Section PullForallRight.

	Lemma find_res_unop_sound_ar {Ts : Tlist} {A B : Type} {ILA : ILogicOps A} `{ILB : ILogic B}
	        (f : arrows Ts A) (op : A -> B)
	        (Hop : forall T (f : T -> A), Forall x, op (f x) |-- op (Forall x, f x)) :
	      find_res_eval_forall_aux(arrows_unop op f) |-- op (find_res_eval_forall_aux f).
	Proof.
		induction Ts.
		simpl. reflexivity.
		simpl in *. rewrite <- Hop.
		apply lforallR; intro x. apply lforallL with x.
		rewrite IHTs; firstorder.
	Qed.

 Lemma find_res_binop_sound_ar {Ts Us : Tlist} {A B C : Type} {ILA : ILogicOps A} {ILB : ILogicOps B} `{ILC : ILogic C}
        (f : arrows Ts A) (g : arrows Us B) (op : A -> B -> C)
        (Hop1 : forall T (f : T -> A) g, Forall x, op (f x) g |-- op (Forall x, f x) g)
        (Hop2 : forall T f (g : T -> B), Forall x, op f (g x) |-- op f (Forall x, g x)) :
      find_res_eval_forall_aux (arrows_binop_merge op f g) |-- op (find_res_eval_forall_aux f) (find_res_eval_forall_aux g).
Proof.
	induction Ts; simpl in *.
	+ apply find_res_unop_sound_ar.
	  intros. apply Hop2.
	+ rewrite <- Hop1.
      apply lforallR; intro x; apply lforallL with x.
	  rewrite <- IHTs; try tauto; reflexivity.
Qed.

  Lemma binop_sound_ar {A B C : Type} {ILA : ILogicOps A} {ILB : ILogicOps B} `{ILC : ILogic C}
                       (de_env1 : env A) (tac_env1 : env (find_res A))
                       (de_env2 : env B) (tac_env2 : env (find_res B))
                       (p : @deep_op A _) (q : @deep_op B _) (op : A -> B -> C)
                       {H : Proper (lentails ==> lentails ==> lentails) op}
      (Hp : match deep_op_eval de_env1 p, pull_forall_r p de_env1 tac_env1 with
	    | None, None => True
	    | Some p, Some q => find_res_eval_forall q |-- p
	    | _, _ => True
	  end)
      (Hq : match deep_op_eval de_env2 q, pull_forall_r q de_env2 tac_env2 with
	    | None, None => True
	    | Some p, Some q => find_res_eval_forall q |-- p
	    | _, _ => True
	  end)
        (Hop1 : forall T (f : T -> A) g, Forall x, op (f x) g |-- op (Forall x, f x) g)
        (Hop2 : forall T f (g : T -> B), Forall x, op f (g x) |-- op f (Forall x, g x)) :
match binop_option op (deep_op_eval de_env1 p) (deep_op_eval de_env2 q),
      find_res_binop op (pull_forall_r p de_env1 tac_env1) (pull_forall_r q de_env2 tac_env2) with
  | None, None     => True
  | Some p, Some q => find_res_eval_forall q |-- p
  | _, _           => True
end.
Proof.
	remember (deep_op_eval de_env1 p) as o1.
	remember (deep_op_eval de_env2 q) as o2.
	remember (pull_forall_r p de_env1 tac_env1) as o3.
	remember (pull_forall_r q de_env2 tac_env2) as o4.
	destruct o1, o2, o3, o4; simpl in *; try intuition congruence.
	etransitivity; [|apply H; [apply Hp | apply Hq]].
	destruct f; destruct f0.
	apply find_res_binop_sound_ar; assumption.
Qed.

  	Lemma env_sound_aux_ar {A : Type} `{ILA : ILogic A}
  	(de_env : env A) (tac_env : env (find_res A))
    (t : @deep_op A _) (H : env_sound_lr de_env tac_env find_res_eval_forall) :
    match deep_op_eval de_env t, pull_forall_r t de_env tac_env with
      | None, None     => True
      | Some p, Some q => find_res_eval_forall q |-- p
      | _, _           => True
    end.
    Proof.
    	induction t.
    	+ simpl; reflexivity.
    	+ simpl; reflexivity.
    	+ simpl; reflexivity.
        + simpl; remember (deep_op_eval de_env t1) as o1.
	      remember (deep_op_eval de_env t2) as o2.
	      destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + simpl; remember (deep_op_eval de_env t1) as o1.
	      remember (deep_op_eval de_env t2) as o2.
	      destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + simpl; remember (deep_op_eval de_env t1) as o1.
	      remember (deep_op_eval de_env t2) as o2.
	      destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + simpl.
          specialize (IHt ILA de_env tac_env H).
          remember (fst de_env) [n] as o1.
          remember (fst tac_env) [n] as o2.
          remember (deep_op_eval de_env t) as o3.
          remember (pull_forall_r t de_env tac_env) as o4.
          destruct o1, o2, o3, o4; simpl in *; try intuition congruence.
          symmetry in Heqo2;
          destruct H as [H _]; specialize (H f n Heqo2); destruct H as [g [H3 [H4 H5]]];
          rewrite <- Heqo1 in H3; inversion H3; subst.
          rewrite H5. apply H4. apply IHt.
        + simpl.
          specialize (IHt1 ILA de_env tac_env H); specialize (IHt2 ILA de_env tac_env H).
          remember (snd de_env) [n] as o1.
          remember (snd tac_env) [n] as o2.
          remember (deep_op_eval de_env t1) as o3.
          remember (deep_op_eval de_env t2) as o4.
          remember (pull_forall_r t1 de_env tac_env) as o5.
          remember (pull_forall_r t2 de_env tac_env) as o6.
          destruct o1, o2, o3, o4, o5, o6; simpl in *; try intuition congruence.
          symmetry in Heqo2;
          destruct H as [_ H]; specialize (H f n Heqo2); destruct H as [g [H3 [H4 H5]]];
          rewrite <- Heqo1 in H3; inversion H3; subst.
          rewrite H5. apply H4; [apply IHt1 | apply IHt2].
        + simpl. reflexivity.
        + simpl. reflexivity.
        + simpl. remember (deep_op_eval (env_empty B) t1) as o1.
          remember (deep_op_eval de_env t2) as o2.
          destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + simpl. remember (deep_op_eval (env_empty B) t1) as o1.
          remember (deep_op_eval de_env t2) as o2.
          destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + simpl. remember (deep_op_eval (env_empty Prop) t1) as o1.
          remember (deep_op_eval de_env t2) as o2.
          destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + simpl. remember (deep_op_eval (env_empty Prop) t1) as o1.
          remember (deep_op_eval de_env t2) as o2.
          destruct o1, o2; simpl; (try intuition congruence); reflexivity.
    Qed.

    Implicit Arguments env_sound_aux_ar [[A] [ILOps] [ILA]].

  	Lemma env_sound_ar {A : Type} `{ILA : ILogic A}
  	 (de_env : env A) (tac_env : env (find_res A))
    (t : @deep_op A _) (H : env_sound_lr de_env tac_env find_res_eval_forall) (P : A) :
    match deep_op_eval de_env t, pull_forall_r t de_env tac_env with
      | None, None     => True
      | Some p, Some q => P |-- find_res_eval_forall q -> P |-- p
      | _, _           => True
    end.
    Proof.
    	pose proof (env_sound_aux_ar de_env tac_env t).
    	remember (deep_op_eval de_env t) as o1.
    	remember (pull_forall_r t de_env tac_env) as o2.
    	destruct o1, o2; simpl in *; try intuition congruence.
    	intros. rewrite <- H0; assumption.
    Qed.

    Implicit Arguments env_sound_ar [[A] [ILOps] [ILA]].

End PullForallRight.

Ltac lforallR_aux :=
  match goal with
    | |- ?P |-- ?Q =>
      let A := type of Q in
      let t := quote_term Q in
       apply (env_sound_ar (env_empty A) (env_empty (find_res A)) t
              (env_sound_lr_empty (env_empty A) find_res_eval_forall) P);
        simpl; cbv [find_res_eval_forall find_res_eval_forall_aux]; simpl
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Ltac lforallR2 :=
	repeat (
		repeat (
			let x := fresh "x" in
			simple apply lforallR; intro x
		);
  		lforallR_aux
  	).

Tactic Notation "lforallR" := lforallR2.
Tactic Notation "lforallR" simple_intropattern(x1) :=
	first [simple apply lforallR; intro x1 | lforallR_aux; simple apply lforallR; intro x1].
Tactic Notation "lforallR" simple_intropattern(x1) simple_intropattern(x2) :=
	first [simple apply lforallR; intro x1 | lforallR_aux; simple apply lforallR; intro x1]; lforallR x2.
Tactic Notation "lforallR" simple_intropattern(x1) simple_intropattern(x2) simple_intropattern(x3) :=
	first [simple apply lforallR; intro x1 | lforallR_aux; simple apply lforallR; intro x1]; lforallR x2 x3.
Tactic Notation "lforallR" simple_intropattern(x1) simple_intropattern(x2) simple_intropattern(x3)  simple_intropattern(x4) :=
	first [simple apply lforallR; intro x1 | lforallR_aux; simple apply lforallR; intro x1]; lforallR x2 x3 x4.

(* This example wont work until we have a means for hanlding type inhabitation. *)

(*
Lemma test_ar {A B : Type} `{H : Embed B A} {HBPO: EmbedOp Prop B} {HPB : Embed Prop B} {HO : EmbedOp Prop A} {HE: Embed Prop A} {HA : ILogic A} {HB : ILogic B}
    (P Q R : A) (S : B) (T : Prop) (f : nat -> A) (g : nat -> B) (h : nat -> Prop) :
  lfalse |-- (S //\\ Forall y, g y) /\\ (P //\\ (Forall y, f y) //\\ R //\\ (T //\\ Forall y, h y) /\\ Forall x, f x).
Proof.
	lforallR a b c d.
	apply lfalseL.
Qed.
*)

Section PullForallLeft.

Fixpoint pull_forall_l {A : Type} {ILA : ILogicOps A}
(t : @deep_op A _) (de_env : env A) (tac_env : env (find_res A)) : option (find_res A) :=
match t with
	| t_and t1 t2   => find_res_binop land (pull_forall_l t1 de_env tac_env) (pull_forall_l t2 de_env tac_env)
	| t_or  t1 t2   => find_res_binop lor (pull_forall_l t1 de_env tac_env) (pull_forall_l t2 de_env tac_env)
	| t_forall T f  => Some (@mkf A (Tcons T Tnil) f)
	| t_and_inj B _ _ _ _ _ _ a b => find_res_binop lembedand (pull_forall_l a (env_empty B) (env_empty (find_res B)))
	                         (pull_forall_l b de_env tac_env)
	| t_and_prop _ _ a b => find_res_binop lembedand (pull_forall_l a (env_empty Prop) (env_empty (find_res Prop)))
	                         (pull_forall_l b de_env tac_env)
    | t_unop n p =>
    	match ((fst tac_env) [n]) with
    		| Some f => unop_option f (pull_forall_l p de_env tac_env)
    		| None => None
    	end
	| t_binop n p q =>
		match ((snd tac_env) [n]) with
			| Some f => binop_option f (pull_forall_l p de_env tac_env) (pull_forall_l q de_env tac_env)
			| None => None
		end
    | _ => match deep_op_eval de_env t with
    	     | Some t => Some (@mkf A Tnil t)
    	     | None   => None
    	   end
end.

	Lemma find_res_unop_sound_al {Ts : Tlist} {A B : Type} {ILA : ILogicOps A} `{ILB : ILogic B}
	        (f : arrows Ts A) (op : A -> B)
	        (Hop : forall T (f : T -> A) , op (Forall x, f x) |-- Forall x, op (f x)) :
	      op (find_res_eval_forall_aux f) |--
	      find_res_eval_forall_aux(arrows_unop op f).
	Proof.
		induction Ts.
		simpl. reflexivity.
		simpl in *. rewrite Hop.
		apply lforallR; intro x; apply lforallL with x.
		apply IHTs; tauto.
	Qed.

 Lemma find_res_binop_sound_al {Ts Us : Tlist} {A B C : Type} {ILA : ILogicOps A} {ILB : ILogicOps B} `{ILC : ILogic C}
        (f : arrows Ts A) (g : arrows Us B) (op : A -> B -> C)
        (Hop1 : forall T (f : T -> A) g, op (Forall x, f x) g |-- Forall x, (op (f x) g))
        (Hop2 : forall T f (g : T -> B), op f (Forall x, g x) |-- Forall x, (op f (g x))) :
      op (find_res_eval_forall_aux f) (find_res_eval_forall_aux g) |--
      find_res_eval_forall_aux (arrows_binop_merge op f g).
Proof.
	induction Ts; simpl in *.
	+ apply find_res_unop_sound_al.
	  intros. apply Hop2.
	+ rewrite Hop1.
      apply lforallR; intro x; apply lforallL with x.
	  rewrite <- IHTs; try tauto; reflexivity.
Qed.

  Lemma binop_sound_al {A B C : Type} {ILA : ILogicOps A} {ILB : ILogicOps B} `{ILC : ILogic C}
                   (de_env1 : env A) (tac_env1 : env (find_res A))
                    (de_env2 : env B) (tac_env2 : env (find_res B))
                    (p : @deep_op A _) (q : @deep_op B _) (op : A -> B -> C)
                  {H : Proper (lentails ==> lentails ==> lentails) op}
      (Hp : match deep_op_eval de_env1 p, pull_forall_l p de_env1 tac_env1 with
	    | None, None => True
	    | Some p, Some q => p |-- find_res_eval_forall q
	    | _, _ => True
	  end)
      (Hq : match deep_op_eval de_env2 q, pull_forall_l q de_env2 tac_env2 with
	    | None, None => True
	    | Some p, Some q => p |-- find_res_eval_forall q
	    | _, _ => True
	  end)
        (Hop1 : forall T (f : T -> A) g, op (Forall x, f x) g |-- Forall x, (op (f x) g))
        (Hop2 : forall T f (g : T -> B), op f (Forall x, g x) |-- Forall x, (op f (g x))) :
match binop_option op (deep_op_eval de_env1 p) (deep_op_eval de_env2 q),
      find_res_binop op (pull_forall_l p de_env1 tac_env1) (pull_forall_l q de_env2 tac_env2) with
  | None, None     => True
  | Some p, Some q => p |-- find_res_eval_forall q
  | _, _           => True
end.
Proof.
	remember (deep_op_eval de_env1 p) as o1.
	remember (deep_op_eval de_env2 q) as o2.
	remember (pull_forall_l p de_env1 tac_env1) as o3.
	remember (pull_forall_l q de_env2 tac_env2) as o4.
	destruct o1, o2, o3, o4; simpl in *; try intuition congruence.
	etransitivity.
	apply H.
	apply Hp.
	apply Hq.
	destruct f; destruct f0.
	apply find_res_binop_sound_al; assumption.
Qed.

  	Lemma env_sound_aux_al {A : Type} `{ILA : ILogic A}
  		 (de_env : env A) (tac_env : env (find_res A))
    (t : @deep_op A _) (H : env_sound_rl de_env tac_env find_res_eval_forall) :
    match deep_op_eval de_env t, pull_forall_l t de_env tac_env with
      | None, None     => True
      | Some p, Some q => p |-- find_res_eval_forall q
      | _, _           => True
    end.
    Proof.
    	induction t.
    	+ simpl; reflexivity.
    	+ simpl; reflexivity.
    	+ simpl; reflexivity.
        + apply binop_sound_al; [apply IHt1; assumption | apply IHt2; assumption | |].
          intros. apply landforallDL.
          intros. rewrite landC, landforallDL. setoid_rewrite landC at 1. reflexivity.
        + apply binop_sound_al; [apply IHt1; assumption | apply IHt2; assumption | |].
          intros. apply lorforallDL.
          intros. rewrite lorC, lorforallDL. setoid_rewrite lorC at 1. reflexivity.
        + simpl; remember (deep_op_eval de_env t1) as o1.
	      remember (deep_op_eval de_env t2) as o2.
	      destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + simpl.
          specialize (IHt ILA de_env tac_env H).
          remember (fst de_env) [n] as o1.
          remember (fst tac_env) [n] as o2.
          remember (deep_op_eval de_env t) as o3.
          remember (pull_forall_l t de_env tac_env) as o4.
          destruct o1, o2, o3, o4; simpl in *; try intuition congruence.
          symmetry in Heqo2;
          destruct H as [H _]; specialize (H f n Heqo2); destruct H as [g [H3 [H4 H5]]];
          rewrite <- Heqo1 in H3; inversion H3; subst.
          rewrite <- H5. apply H4. apply IHt.
        + simpl.
          specialize (IHt1 ILA de_env tac_env H); specialize (IHt2 ILA de_env tac_env H).
          remember (snd de_env) [n] as o1.
          remember (snd tac_env) [n] as o2.
          remember (deep_op_eval de_env t1) as o3.
          remember (deep_op_eval de_env t2) as o4.
          remember (pull_forall_l t1 de_env tac_env) as o5.
          remember (pull_forall_l t2 de_env tac_env) as o6.
          destruct o1, o2, o3, o4, o5, o6; simpl in *; try intuition congruence.
          symmetry in Heqo2;
          destruct H as [_ H]; specialize (H f n Heqo2); destruct H as [g [H3 [H4 H5]]];
          rewrite <- Heqo1 in H3; inversion H3; subst.
          rewrite <- H5. apply H4; [apply IHt1 | apply IHt2].
        + simpl. reflexivity.
        + simpl. reflexivity.
        + apply binop_sound_al.
          apply IHt1. assumption. apply env_sound_rl_empty.
          apply IHt2; assumption.
          intros. unfold lembedand. rewrite <- embedlforall, landforallDL. reflexivity.
          intros. unfold lembedand. rewrite landC, landforallDL. setoid_rewrite landC at 1. reflexivity.
        + simpl. remember (deep_op_eval (env_empty B) t1) as o1.
          remember (deep_op_eval de_env t2) as o2.
          destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + apply binop_sound_al.
          apply IHt1. apply _. apply env_sound_rl_empty.
          apply IHt2; assumption.
          intros. unfold lembedand. rewrite <- embedlforall, landforallDL. reflexivity.
          intros. unfold lembedand. rewrite landC, landforallDL. setoid_rewrite landC at 1. reflexivity.
        + simpl. remember (deep_op_eval (env_empty Prop) t1) as o1.
          remember (deep_op_eval de_env t2) as o2.
          destruct o1, o2; simpl; (try intuition congruence); reflexivity.
    Qed.

    Implicit Arguments env_sound_aux_al [[A] [ILOps] [ILA]].

  	Lemma env_sound_al' {A : Type} `{ILA : ILogic A}
  	(de_env : env A) (tac_env : env (find_res A))
    (t : @deep_op A _) (H : env_sound_rl de_env tac_env find_res_eval_forall) (P : A) :
    match deep_op_eval de_env t, pull_forall_l t de_env tac_env with
      | None, None     => True
      | Some p, Some q => find_res_eval_forall q |-- P -> p |-- P
      | _, _           => True
    end.
    Proof.
    	pose proof (env_sound_aux_al de_env tac_env t).
    	remember (deep_op_eval de_env t) as o1.
    	remember (pull_forall_l t de_env tac_env) as o2.
    	destruct o1, o2; simpl in *; try intuition congruence.
    	intros. rewrite H0; assumption.
    Qed.

  	Lemma env_sound_al {A : Type} `{ILA : ILogic A}
  	(de_env : env A) (tac_env : env (find_res A))
    (t : @deep_op A _) (H : env_sound_rl de_env tac_env find_res_eval_forall) (P : A) (Q : find_res A)
    (H1 : deep_op_eval de_env t = Some P) (H2 :  pull_forall_l t de_env tac_env = Some Q) :
    P |-- find_res_eval_forall Q.
    Proof.
    	pose proof (@env_sound_al' A _ _ de_env tac_env t H (find_res_eval_forall Q)).
    	rewrite H1, H2 in H0. apply H0. reflexivity.
    Qed.

End PullForallLeft.

Implicit Arguments env_sound_al [[A] [ILOps] [ILA]].

Ltac lforallL_aux :=
  match goal with
    | |- ?P |-- ?Q =>
      let A := type of P in
      let t := quote_term P in
      etransitivity; [eapply (env_sound_al (env_empty A) (env_empty (find_res A)) t
      	(env_sound_rl_empty (env_empty A) find_res_eval_forall)); [reflexivity | simpl; reflexivity] |
      	cbv [find_res_eval_forall find_res_eval_forall_aux]; simpl]
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Ltac lforallL2 :=
	repeat (
		repeat (
			let x := fresh "x" in
			simple eapply lforallL
		);
  		lforallL_aux
  	).

Tactic Notation "lforallL" := lforallL2.
Tactic Notation "lforallL" constr(x1) :=
	first [simple apply lforallL with x1 | lforallL_aux; simple apply lforallL with x1].
Tactic Notation "lforallL" constr(x1) constr(x2) :=
	first [simple apply lforallL with x1 | lforallL_aux; simple apply lforallL with x1]; lforallL x2.
Tactic Notation "lforallL" constr(x1) constr(x2) constr(x3) :=
	first [simple apply lforallL with x1 | lforallL_aux; simple apply lforallL with x1]; lforallL x2 x3.
Tactic Notation "lforallL" constr(x1) constr(x2) constr(x3) constr(x4) :=
	first [simple apply lforallL with x1 | lforallL_aux; simple apply lforallL with x1]; lforallL x2 x3 x4.

Lemma test_al {A B : Type} `{H : Embed B A} {HBPO: EmbedOp Prop B} {HPB : Embed Prop B} {HO : EmbedOp Prop A} {HE: Embed Prop A} {HA : ILogic A} {HB : ILogic B}
    (P Q R : A) (S : B) (T : Prop) (f : nat -> A) (g : nat -> B) (h : nat -> Prop) :
  (S //\\ Forall y, g y) /\\ (P //\\ (Forall y, f y) //\\ R //\\ (T //\\ Forall y, h y) /\\ Forall x, f x) |-- ltrue.
Proof.
	Check deep_op_eval (env_empty A).
  lforallL 2 3 4 5.
  apply ltrueR.
Qed.


From discprob.basic Require Import base sval order monad bigop_ext nify.
From mathcomp Require Import ssrfun ssreflect eqtype ssrbool seq fintype choice.
From discprob.prob Require Import prob countable finite stochastic_order rearrange.
Require Import Reals Psatz.
From discprob.idxval Require Import ival ival_dist.

Record ival_couplingP {A1 A2} (Is1: ival A1) (Is2: ival A2) (P: A1 → A2 → Prop) : Type :=
  mkICoupling { ic_witness :> ival {xy: A1 * A2 | P (fst xy) (snd xy)};
     ic_proj1: eq_ival Is1 (x ← ic_witness; mret (fst (sval x)));
     ic_proj2: eq_ival Is2 (x ← ic_witness; mret (snd (sval x)));
     }.

Record idist_couplingP {A1 A2} (Is1: ivdist A1) (Is2: ivdist A2) (P: A1 → A2 → Prop) : Type :=
  mkIdCoupling { idc_witness :> ivdist {xy: A1 * A2 | P (fst xy) (snd xy)};
     idc_proj1: eq_ivd Is1 (x ← idc_witness; mret (fst (sval x)));
     idc_proj2: eq_ivd Is2 (x ← idc_witness; mret (snd (sval x)));
     }.
From mathcomp Require Import bigop.

Lemma ic_coupling_to_id {A1 A2} (I1: ivdist A1) (I2: ivdist A2) P:
  ival_couplingP I1 I2 P →
  idist_couplingP I1 I2 P.
Proof.
  intros [Ic Hproj1 Hproj2].
  assert (Hsum1: is_series (countable_sum (ival.val Ic)) 1%R).
  {
    replace 1%R with R1 by auto.
    eapply (eq_ival_series _ _) in Hproj1; last eapply val_sum1.
    unshelve (eapply (countable_series_rearrange_covering_match _ _); last eassumption).
    { intros ic. rewrite //=. exists (existT (sval ic) tt).
      { abstract (rewrite Rmult_1_r => //=; destruct ic => //=). }
    }
    - apply val_nonneg.
    - apply val_nonneg.
    - intros (n1&?) (n2&?) Heq. apply sval_inj_pred => //=.
      inversion Heq. auto.
    - intros ((n1&[])&Hpf) => //=.
      unshelve (eexists).
      { exists n1.  rewrite //= Rmult_1_r // in Hpf. }
      apply sval_inj_pred => //=.
    - intros (n1&Hpf) => //=. nra.
  }
  exists {| ivd_ival := Ic; val_sum1 := Hsum1 |}; auto.
Qed.

Local Open Scope R_scope.
Record ival_coupling_nondepP {A1 A2} (Is1: ival A1) (Is2: ival A2) (P: A1 → A2 → Prop) : Type :=
  mkNonDepICoupling { ic_nondep_witness :> ival (A1 * A2);
               ic_nondep_support :
                 ∀ xy, (∃ i, ind ic_nondep_witness i = xy
                            ∧ val ic_nondep_witness i > 0) → P (fst xy) (snd xy);
     ic_nondep_proj1: eq_ival Is1 (x ← ic_nondep_witness; mret (fst x));
     ic_nondep_proj2: eq_ival Is2 (x ← ic_nondep_witness; mret (snd x));
     }.

Lemma ival_coupling_nondep_suffice {A1 A2} Is1 Is2 (P: A1 → A2 → Prop):
      ival_coupling_nondepP Is1 Is2 P →
      ival_couplingP Is1 Is2 P.
Proof.
  intros [Ic Isupp Hp1 Hp2].
  exists (ival_equip Ic _ Isupp).
  - setoid_rewrite Hp1.
    setoid_rewrite (ival_bind_P Ic).
    eapply ival_bind_congr; first reflexivity.
    intros (a1&a2) => //=; reflexivity.
  - setoid_rewrite Hp2.
    setoid_rewrite (ival_bind_P Ic).
    eapply ival_bind_congr; first reflexivity.
    intros (a1&a2) => //=; reflexivity.
Qed.

Lemma ival_coupling_refl {A} (I: ival A) : ival_couplingP I I (λ x y, x = y).
Proof.
  unshelve (eexists).
  { refine (x ← I; mret (exist _ (x, x) _)).
    done. }
  - setoid_rewrite ival_bind_mret_mret. setoid_rewrite ival_right_id. reflexivity.
  - setoid_rewrite ival_bind_mret_mret. setoid_rewrite ival_right_id. reflexivity.
Qed.

Lemma ival_coupling_sym {A1 A2} (Is1: ival A1) (Is2: ival A2) P
      (Ic: ival_couplingP Is1 Is2 P): ival_couplingP Is2 Is1 (λ x y, P y x).
Proof.
  destruct Ic as [Ic Hp1 Hp2].
  unshelve (eexists).
  { refine (mbind _ Ic). intros ((x&y)&HP).
    refine (mret (exist _ (y, x) _)); auto. }
  * setoid_rewrite Hp2. setoid_rewrite ival_assoc. apply ival_bind_congr; first by reflexivity.
    intros ((x&y)&Hpf). setoid_rewrite ival_left_id => //=. reflexivity.
  * setoid_rewrite Hp1. setoid_rewrite ival_assoc; apply ival_bind_congr; first by reflexivity.
    intros ((x&y)&Hpf). setoid_rewrite ival_left_id => //=. reflexivity.
Qed.

Lemma ival_coupling_eq {A} (Is1 Is2: ival A)
      (Ic: ival_couplingP Is1 Is2 (λ x y, x = y)): eq_ival Is1 Is2.
Proof.
  destruct Ic as [Ic Hp1 Hp2].
  setoid_rewrite Hp1. setoid_rewrite Hp2.
  apply ival_bind_congr; first by reflexivity.
  intros ((x&y)&Heq) => //=. rewrite //= in Heq; subst; reflexivity.
Qed.

Lemma ival_coupling_bind {A1 A2 B1 B2} (f1: A1 → ival B1) (f2: A2 → ival B2)
      Is1 Is2 P Q (Ic: ival_couplingP Is1 Is2 P):
  (∀ x y, P x y → ival_couplingP (f1 x) (f2 y) Q) →
  ival_couplingP (mbind f1 Is1) (mbind f2 Is2) Q.
Proof.
  intros Hfc.
  destruct Ic as [Ic Hp1 Hp2].
  unshelve (eexists).
  { refine (xy ← Ic; _). destruct xy as ((x&y)&HP).
    exact (Hfc _ _ HP).
  }
  - setoid_rewrite Hp1; setoid_rewrite ival_assoc;
      apply ival_bind_congr; first by reflexivity.
    intros ((x&y)&HP). setoid_rewrite ival_left_id => //=.
    destruct (Hfc x y); auto.
  - setoid_rewrite Hp2; setoid_rewrite ival_assoc;
      apply ival_bind_congr; first by reflexivity.
    intros ((x&y)&HP). setoid_rewrite ival_left_id => //=.
    destruct (Hfc x y); auto.
Qed.

Lemma ival_coupling_mret {A1 A2} x y (P: A1 → A2 → Prop):
  P x y →
  ival_couplingP (mret x) (mret y) P.
Proof.
  intros HP. exists (mret (exist _ (x, y) HP)); setoid_rewrite ival_left_id => //=; reflexivity.
Qed.

Lemma ival_coupling_conseq {A1 A2} (P1 P2: A1 → A2 → Prop) (I1: ival A1) (I2: ival A2):
  (∀ x y, P1 x y → P2 x y) →
  ival_couplingP I1 I2 P1 →
  ival_couplingP I1 I2 P2.
Proof.
  intros HP [Ic Hp1 Hp2].
  unshelve (eexists).
  { refine (x ← Ic; mret _).
    destruct x as (x&P).
    exists x. auto. }
  - setoid_rewrite Hp1.
    setoid_rewrite ival_assoc.
    eapply ival_bind_congr; first reflexivity; intros (?&?).
    setoid_rewrite ival_left_id; reflexivity.
  - setoid_rewrite Hp2.
    setoid_rewrite ival_assoc.
    eapply ival_bind_congr; first reflexivity; intros (?&?).
    setoid_rewrite ival_left_id; reflexivity.
Qed.

Lemma ival_coupling_plus' {A1 A2} p
      (P : A1 → A2 → Prop) (I1 I1': ival A1) (I2 I2': ival A2) :
  ival_couplingP I1 I2 P →
  ival_couplingP I1' I2' P →
  ival_couplingP (iplus (iscale p I1) (iscale (1 - p) I1'))
    (iplus (iscale p I2) (iscale (1 - p) I2')) P.
Proof.
  intros [Ic Hp1 Hp2] [Ic' Hp1' Hp2'].
  exists (ival.iplus (ival.iscale p Ic) (ival.iscale (1 - p) Ic')).
  - setoid_rewrite ival.ival_plus_bind.
    setoid_rewrite ival.ival_scale_bind.
    setoid_rewrite Hp1.
    setoid_rewrite Hp1'.
    reflexivity.
  - setoid_rewrite ival.ival_plus_bind.
    setoid_rewrite ival.ival_scale_bind.
    setoid_rewrite Hp2.
    setoid_rewrite Hp2'.
    reflexivity.
Qed.

Lemma ival_coupling_plus {A1 A2} p Hpf Hpf'
      (P : A1 → A2 → Prop) (I1 I1': ivdist A1) (I2 I2': ivdist A2) :
  ival_couplingP I1 I2 P →
  ival_couplingP I1' I2' P →
  ival_couplingP (ivdplus p Hpf I1 I1') (ivdplus p Hpf' I2 I2') P.
Proof.
  rewrite //=. apply ival_coupling_plus'.
Qed.

Lemma ival_coupling_idxOf {A1 A2} I1 I2 (P: A1 → A2 → Prop):
  ival_couplingP I1 I2 P →
  { Q :  {Q: idx I1 → idx I2 → Prop | (∀ i1 i1' i2, Q i1 i2 → Q i1' i2 → i1 = i1')} &
  ival_couplingP (idxOf I1) (idxOf I2) (λ i1 i2, P (ind I1 i1) (ind I2 i2) ∧
                                                 val I1 i1 > 0 ∧ val I2 i2 > 0 ∧
                                                 (sval Q) i1 i2  )}.
Proof.
  intros [Ic Hp1 Hp2].
  symmetry in Hp1. symmetry in Hp2.
  apply ClassicalEpsilon.constructive_indefinite_description in Hp1.
  destruct Hp1 as (h1&Hp1).
  apply ClassicalEpsilon.constructive_indefinite_description in Hp1.
  destruct Hp1 as (h1'&Hp1).
  apply ClassicalEpsilon.constructive_indefinite_description in Hp2.
  destruct Hp2 as (h2&Hp2).
  apply ClassicalEpsilon.constructive_indefinite_description in Hp2.
  destruct Hp2 as (h2'&Hp2).
  assert (Hgt_coerce: ∀ xy : support (val Ic),
             Rgt_dec (val Ic (projT1 (@existT _ (λ _, unit) (sval xy) tt)) * 1) 0).
  { abstract (intros (?&?); rewrite Rmult_1_r => //=; destruct Rgt_dec; auto). }
  unshelve (eexists).
  exists (λ i1 i2, ∃ ic1 ic2, sval (h1 ic1) = i1 ∧ sval (h2 ic2) = i2 ∧ sval ic1 = sval ic2).
  {
    abstract (intros i1 i1' i2 (ic1&ic2&Heq1&Heq2&Hcoh) (ic1'&ic2'&Heq1'&Heq2'&Hcoh');
    assert (ic2' = ic2);
    first ( abstract (destruct Hp2 as (Hbij2&?);
      rewrite -(Hbij2 ic2');
      rewrite -(Hbij2 ic2);
      f_equal; apply sval_inj_pred; congruence));
    abstract (subst; do 2 f_equal; apply sval_inj_pred; auto; congruence)). }
  unshelve (eexists).
  - refine (xy ← supp_idxOf Ic; mret _).
    unshelve (refine (exist _ ((sval (h1 _)), sval (h2 _)) _)).
      * exact (exist _ (existT (sval xy) tt) (Hgt_coerce xy)).
      * exact (exist _ (existT (sval xy) tt) (Hgt_coerce xy)).
      *
        abstract(
        split; [ by
        (abstract  (rewrite //=;
                   destruct Hp1 as (?&?&->&?) => //=;
                   destruct Hp2 as (?&?&->&?) => //=;
                   destruct (ind Ic (sval xy)) => //=)) |];
        split; [ by
        (abstract (rewrite //=; try destruct (h1 _); try destruct (h2 _); rewrite //=;
                   destruct Rgt_dec => //=)) |];
        split; [ by
        (abstract (rewrite //=; try destruct (h1 _); try destruct (h2 _); rewrite //=;
                   destruct Rgt_dec => //=)) |];
        abstract (
        rewrite //=;
        exists ((exist _ (existT (sval xy) tt) (Hgt_coerce xy)));
        exists ((exist _ (existT (sval xy) tt) (Hgt_coerce xy))); done)
        ).
  - setoid_rewrite ival_bind_mret_mret.
    symmetry.
    unshelve (eexists).
    {
      simpl. intros ((ic&?)&Hgt).
      simpl in h1.
      rewrite Rmult_1_r in Hgt.
      destruct ic as (ic&Hgtc).
      apply h1.
      exists (existT ic tt).
      simpl in *. rewrite Rmult_1_r. done.
    }
    unshelve (eexists).
    { simpl. intros ix.
      destruct (h1' ix) as ((i1&?)&Hgt).
      simpl in Hgt.
      unshelve (eexists).
      { unshelve (refine (existT _ tt)).
        exists i1. rewrite Rmult_1_r in Hgt. done.
      }
      rewrite //=.
    }
    rewrite //=.
    repeat split.
    *  intros (((a&Hgt)&[])&?). destruct Hp1 as (Hinv1&Hinv1'&?).
      rewrite //=. destruct (Rmult_1_r _). rewrite /eq_rect_r //=.
      rewrite Hinv1 => //=.
      apply sval_inj_pred => //=.
      f_equal.
      apply sval_inj_pred => //=.
    * rewrite //= => a. destruct Hp1 as (Hinv1&Hinv1'&?).
      specialize (Hinv1' a).
      destruct (h1' a) as ((?&[])&?).
      rewrite //=.
      rewrite -Hinv1'. destruct (Rmult_1_r (val Ic x)) => //=.
    * rewrite //=. intros (((a&Hgt)&[])&?). destruct Hp1 as (Hinv1&Hinv1'&?).
      rewrite //=. destruct (Rmult_1_r _). rewrite /eq_rect_r //=.
      f_equal. f_equal.
      apply sval_inj_pred => //=.
    * rewrite //=. intros (((a&Hgt)&[])&?). destruct Hp1 as (Hinv1&Hinv1'&?&Hval).
      rewrite //=. destruct (Rmult_1_r _). rewrite /eq_rect_r //=.
      rewrite Hval //= !Rmult_1_r //.
  -  setoid_rewrite ival_bind_mret_mret.
    symmetry.
    unshelve (eexists).
    {
      simpl. intros ((ic&?)&Hgt).
      simpl in h1.
      rewrite Rmult_1_r in Hgt.
      destruct ic as (ic&Hgtc).
      apply h2.
      exists (existT ic tt).
      simpl in *. rewrite Rmult_1_r. done.
    }
    unshelve (eexists).
    { simpl. intros ix.
      destruct (h2' ix) as ((i1&?)&Hgt).
      simpl in Hgt.
      unshelve (eexists).
      { unshelve (refine (existT _ tt)).
        exists i1. rewrite Rmult_1_r in Hgt. done.
      }
      rewrite //=.
    }
    rewrite //=.
    repeat split.
    * rewrite //=. intros (((a&Hgt)&[])&?). destruct Hp2 as (Hinv1&Hinv1'&?).
      rewrite //=. destruct (Rmult_1_r _). rewrite /eq_rect_r //=.
      rewrite Hinv1 => //=.
      apply sval_inj_pred => //=.
      f_equal.
      apply sval_inj_pred => //=.
    * rewrite //= => a. destruct Hp2 as (Hinv1&Hinv1'&?).
      specialize (Hinv1' a).
      destruct (h2' a) as ((?&[])&?).
      rewrite //=.
      rewrite -Hinv1'. destruct (Rmult_1_r (val Ic x)) => //=.
    * rewrite //=. intros (((a&Hgt)&[])&?). destruct Hp1 as (Hinv1&Hinv1'&?).
      rewrite //=. destruct (Rmult_1_r _). rewrite /eq_rect_r //=.
      f_equal. f_equal.
      apply sval_inj_pred => //=.
    * rewrite //=. intros (((a&Hgt)&[])&?). destruct Hp2 as (Hinv1&Hinv1'&?&Hval).
      rewrite //=. destruct (Rmult_1_r _). rewrite /eq_rect_r //=.
      rewrite Hval //= !Rmult_1_r //.
Qed.

Lemma ival_coupling_equip {X} I1 (P: X → Prop) Hpf:
  ival_couplingP I1 (ival_equip I1 P Hpf) (λ x y, x = (sval y)).
Proof.
  unshelve eexists.
  refine ((x ← ival_equip I1 P Hpf; mret (exist _ (sval x, x) _))); auto.
  - setoid_rewrite ival_bind_mret_mret.
    rewrite /sval.
    etransitivity; first (symmetry; apply ival_right_id).
    apply ival_bind_P.
  - setoid_rewrite ival_bind_mret_mret.
    rewrite /sval.
    etransitivity; first (symmetry; apply ival_right_id).
    eapply ival_bind_congr; first reflexivity.
    intros (?&?) => //=. reflexivity.
Qed.

Lemma ival_idist_wit_sum1 {X Y} (I1 : ivdist X) (I2: ivdist Y) (P: X → Y → Prop) Hwit:
  eq_ival I1 (Hwit ≫= (λ x : {xy : X * Y | P xy.1 xy.2}, mret (sval x).1)) →
  is_series (countable_sum (val Hwit)) 1.
Proof.
  intros Hproj1.
    eapply eq_ival_series in Hproj1; last apply (val_sum1).
    rewrite //= in Hproj1.
    setoid_rewrite Rmult_1_r in Hproj1.
    unshelve (eapply countable_series_rearrange_covering_match; last eapply Hproj1).
    { intros x. exists (existT (proj1_sig x) tt). exact (proj2_sig x). }
    { intros x; apply val_nonneg. }
    { intros x; apply val_nonneg. }
    { rewrite //=. intros (?&?) (?&?). inversion 1; subst. apply sval_inj_pi => //=. }
    { intros ((n&[])&Hpf). exists (exist _ n Hpf). apply sval_inj_pi => //=. }
    { intros (n&Hpf) => //=. }
Qed.

Lemma ival_idist_couplingP {X Y} (I1 : ivdist X) (I2: ivdist Y) (P: X → Y → Prop):
  ival_couplingP I1 I2 P →
  idist_couplingP I1 I2 P.
Proof.
  intros [Hwit Hproj1 Hproj2].
  unshelve (econstructor).
  { exists Hwit. eapply ival_idist_wit_sum1; eauto. }
  - rewrite /eq_ivd //=.
  - rewrite /eq_ivd //=.
Qed.

Lemma ival_coupling_support {X Y} I1 I2 (P: X → Y → Prop)
  (Ic: ival_couplingP I1 I2 P) :
  ival_couplingP I1 I2 (λ x y, ∃ Hpf: P x y,  In_isupport x I1 ∧ In_isupport y I2 ∧
                        In_isupport (exist _ (x, y) Hpf) Ic).
Proof.
  destruct Ic as [Ic Hp1 Hp2].
  cut (ival_couplingP I1 I2 (λ x y, ∃ (Hpf: P x y), In_isupport (exist _ (x, y) Hpf) Ic)).
  { intros. eapply ival_coupling_conseq; last eauto.
    intros x y (Hpf&Hin).
    destruct Hin as (ic&Hind&Hval).
    exists Hpf.
    repeat split; auto.
      - rewrite //=. symmetry in Hp1.
        destruct Hp1 as (h1&?&?&?&Hind1&Hval1).
        unshelve (eexists).
        { refine (sval (h1 _ )).
          exists (existT ic tt). rewrite //= Rmult_1_r. destruct Rgt_dec => //=.  }
        split; rewrite //=.
        * rewrite Hind1 //= Hind //=.
        * rewrite Hval1 //= Rmult_1_r //.
      - rewrite //=. symmetry in Hp2.
        destruct Hp2 as (h1&?&?&?&Hind1&Hval1).
        unshelve eexists.
        { refine (sval (h1 _)).
          exists (existT ic tt). rewrite //= Rmult_1_r. destruct Rgt_dec => //=.  }
        split; rewrite //=.
        * rewrite Hind1 //= Hind //=.
        * rewrite Hval1 //= Rmult_1_r //.
      - rewrite //=. exists ic; split => //=.
  }
  unshelve (eexists).
  refine (z ← ival_equip Ic (λ xy, In_isupport xy Ic) _; mret _).
  { destruct z as ((xy&HP)&Hin).  exists xy. abstract (exists HP; destruct xy; eauto). }
  { auto. }
  - setoid_rewrite Hp1.
    setoid_rewrite ival_bind_mret_mret.
    eapply ival_coupling_eq.
    eapply ival_coupling_bind; first eapply ival_coupling_equip.
    intros (xy&HP) ((xy'&HP')&Hin).
    rewrite //=.
    inversion 1; subst; auto. apply ival_coupling_refl.
  - setoid_rewrite Hp2.
    setoid_rewrite ival_bind_mret_mret.
    eapply ival_coupling_eq.
    eapply ival_coupling_bind; first eapply ival_coupling_equip.
    intros (xy&HP) ((xy'&HP')&Hin).
    rewrite //=.
    inversion 1; subst; auto. apply ival_coupling_refl.
Qed.

Lemma ival_coupling_support_wit {X Y} (I1: ivdist X) (I2: ivdist Y) (P: X → Y → Prop)
      (Ic: ival_couplingP I1 I2 P):
       { xy : X * Y | ∃ Hpf : P (fst xy) (snd xy),
           In_isupport (fst xy) I1 ∧ In_isupport (snd xy) I2 ∧ In_isupport (exist _ xy Hpf) Ic}.
Proof.
  specialize (ival_coupling_support I1 I2 P Ic) => Ic'.
  specialize (ival_idist_couplingP I1 I2 _ Ic') => Ic''.
  destruct Ic'' as [Ic'' ? ?].
  destruct (ivd_support_idx Ic'') as (i&?).
  destruct (ind Ic'' i) as ((x&y)&?); eauto.
Qed.

Lemma ival_coupling_proper {X Y} I1 I1' I2 I2' (P: X → Y → Prop) :
  eq_ival I1 I1' →
  eq_ival I2 I2' →
  ival_couplingP I1 I2 P →
  ival_couplingP I1' I2' P.
Proof.
  intros Heq1 Heq2 [Ic Hp1 Hp2].
  exists Ic; etransitivity; eauto; by symmetry.
Qed.


Require Export Iron.Language.SystemF2Data.Type.
Require Export Iron.Language.SystemF2Data.Exp.Lit.
Require Export Iron.Language.SystemF2Data.Exp.Prim.

(********************************************************************)
(* Expressions *)
Inductive exp : Type :=
 (* Variables *)
 | XVar   : nat -> exp

 (* Type abstraction *)
 | XLAM   : exp -> exp

 (* Type application. *)
 | XAPP   : exp -> ty  -> exp

 (* Function abstraction. *)
 | XLam   : ty  -> exp -> exp

 (* Function application. *)
 | XApp   : exp -> exp -> exp

 (* Saturated data constructors. *)
 | XCon   : datacon  -> list ty  -> list exp -> exp

 (* Case expressions. *)
 | XCase  : exp      -> list alt -> exp

 (* Saturated primitive operators. *)
 | XPrim  : prim     -> list exp -> exp

 (* Primitive literals. *)
 | XLit   : lit      -> exp

 (* Alternatives *)
with alt     : Type :=
 | AAlt   : datacon -> exp -> alt.

Hint Constructors exp.
Hint Constructors alt.

(********************************************************************)
(* Mutual induction principle for expressions.
   As expressions are indirectly mutually recursive with lists,
   Coq's Combined scheme command won't make us a strong enough
   induction principle, so we need to write it out by hand. *)
Theorem exp_mutind
 : forall
    (PX : exp -> Prop)
    (PA : alt -> Prop)
 ,  (forall n,                                PX (XVar n))
 -> (forall x1,      PX x1                 -> PX (XLAM x1))
 -> (forall x1 t2,   PX x1                 -> PX (XAPP x1 t2))
 -> (forall t  x1,   PX x1                 -> PX (XLam t x1))
 -> (forall x1 x2,   PX x1 -> PX x2        -> PX (XApp x1 x2))
 -> (forall dc ts xs,         Forall PX xs -> PX (XCon dc ts xs))
 -> (forall x  aa,   PX x  -> Forall PA aa -> PX (XCase x aa))
 -> (forall p xs,    Forall PX xs          -> PX (XPrim p xs))
 -> (forall l,                                PX (XLit  l))
 -> (forall dc x,    PX x                  -> PA (AAlt dc x))
 ->  forall x, PX x.
Proof.
 intros PX PA.
 intros var tlam tapp lam app con case prim lit alt.
 refine (fix  IHX x : PX x := _
         with IHA a : PA a := _
         for  IHX).

 - case x; intros.
   + apply var.
   + apply tlam. apply IHX.
   + apply tapp. apply IHX.
   + apply lam.  apply IHX.
   + apply app.  apply IHX. apply IHX.
   + apply con.  induction l0; intuition.
   + apply case. apply IHX. induction l; intuition.
   + apply prim. induction l;  intuition.
   + apply lit.

 - case a; intros.
   + apply alt.  apply IHX.
Qed.


(** ** revert

intro H は 証明対象の命題から前提に移すものですが、
逆に、前提から証明対象の命題に移すのは revert H を使います。

*)

Section Revert.

Variable P : Prop.

Goal P -> P.
Proof.
  Show Proof.
(**
<<
?Goal
>>
先ほどのセクションの説明と同じく、P -> P の証明ですが、
最初に Show Proof とすると、?Goal と表示され、
証明項はまったくできていないことがわかります。
*)
  intro H.
  Show Proof.
(**
<<
(fun H : P => ?Goal)
>>
intro H で、H : P を前提に移したところで
Show Proof とすると、(fun H : P => ?Goal) となり、
引数Hを受け取る関数抽象が構築されることがわかります。
*)
  revert H.
  Show Proof.
(**
<<
(fun H : P => ?Goal H)
>>
ここで revert H として、H : P を証明対象に戻したところで Show Proof とすると、
(fun H : P => ?Goal H) と表示されます。
まずわかることは「戻す」というのは証明項が元に戻るわけではないことです。
実際には ?Goal が ?Goal H に変化する、つまり、戻したものを引数とする関数呼び出しが構築され、
関数部分が新しいゴールとなります。
*)
  intro H.
  revert H.
  intro H.
  revert H.
  Show Proof.
(**
<<
(fun H : P => (fun H0 : P => (fun H1 : P => ?Goal H1) H0) H)
>>
意味もなく intro H と revert H を繰り返してみると、証明項は
(fun H : P => (fun H0 : P => (fun H1 : P => ?Goal H1) H0) H)
となります。関数抽象と関数呼び出しが増えていることが分かります。
Coq が表示する前提と証明する命題は変わりませんが、
内部では証明項が（意味もなく）膨らんでいるわけです。

ここで、?Goal の外側には H, H0, H1 の束縛がありますが、
前提にこれらは表示されていません。
これは、Coq がすべての束縛を前提に表示するわけではなく、
revert は指定した前提を前提から表示しないようにするためです。

ここまでで確認したように、revert は証明項の関数適用とその引数部分を構築しますが、
引数部分にできるものはすでに存在する前提に限られます。
引数部分に任意の証明項を構築したい場合は他の tactic が必要になります。

revert の動作は確認できたので証明を終りましょう。
ここでは Abort で証明を中断する、つまり証明項を完成させずに終ることにします。
*)
Abort.

End Revert.


Require Import List.
Import ListNotations.
Require Import PeanoNat.
Require Import Coq.omega.Omega.
Require Import Coq.Numbers.NatInt.NZOrder.

From Verbatim Require Import ltac.
From Verbatim Require Import state.
From Verbatim Require Import lexer.impl_pref.

Module LemmasFn (Import ST : state.T).

  Import ST.Defs.
  Import ST.Ty.
  Module IMPL := impl_pref.ImplFn ST.
  Import IMPL.
  Import MatchSpec.

  Lemma nil_is_prefix : forall(xs : String),
      [] ++_= xs.
  Proof.
    intros xs. apply pref_def. exists xs. reflexivity.
  Qed.

  Lemma app_head_prefix : forall(xs ys : String),
      xs ++_= xs ++ ys.
  Proof.
    intros xs ys. apply pref_def. exists ys. reflexivity.
  Qed.

  Lemma cons_prefix : forall(x y : Sigma) (xs ys : String),
      x :: xs ++_= y :: ys <-> x = y /\ xs ++_= ys.
  Proof.
    intros x y xs ys. split; intros H.
    {
      inv H. destruct H1.
      injection H. intros I1 I2. split; subst.
      - reflexivity.
      - apply app_head_prefix.
    }
    {
      destruct H. inv H0. destruct H1.
      apply pref_def. exists x. rewrite <- H. reflexivity.
    }
  Qed.

  Lemma self_prefix : forall(p : String), p ++_= p.
  Proof.
    intros p. apply pref_def. exists []. apply nil_right.
  Qed.

  Lemma eq_len_eq_pref : forall(x s p : String),
      length p = length s
      -> s ++_= x
      -> p ++_= x
      -> s = p.
  Proof.
    induction x; intros s p Heq Hs Hp .
    - inv Hs. inv Hp. destruct H0. destruct H1.
      apply app_eq_nil in H. destruct H.
      apply app_eq_nil in H0. destruct H0.
      subst. reflexivity.
    - destruct s; destruct p.
      + reflexivity.
      + simpl in Heq. discriminate.
      + simpl in Heq. discriminate.
      + apply cons_prefix in Hs. apply cons_prefix in Hp.
        destruct Hs. destruct Hp. subst.
        assert (length p = length s0).
        { simpl in Heq. omega. }
        apply IHx in H.
        * rewrite H. reflexivity.
        * apply H0.
        * apply H2.
  Qed.

  Lemma max_pref_fn_splits : forall code prefix suffix (fsm : State) i i',
      Some (prefix, suffix, i') = max_pref_fn code i fsm -> code = prefix ++ suffix.
  Proof.
    induction code as [| a s']; intros; simpl in H;
      repeat dm; repeat inj_all; auto; try(discriminate).
    symmetry in E. apply IHs' in E. rewrite E. auto.
  Qed.

  Lemma proper_suffix_shorter : forall code prefix suffix (fsm : State) i i',
      prefix <> []
      -> Some (prefix, suffix, i') = max_pref_fn code i fsm
      -> length suffix < length code.
  Proof.
    intros code prefix suffix fsm i i'. intros Hneq Heq.
    apply max_pref_fn_splits in Heq. rewrite Heq.
    replace (length (prefix ++ suffix)) with ((length prefix) + (length suffix)).
    - apply Nat.lt_add_pos_l. destruct prefix.
      + contradiction.
      + simpl. omega.
    - symmetry. apply app_length.
  Qed.

  Lemma max_first_or_rest : forall ys x y,
      x = max_of_prefs (y :: ys) -> x = y \/ x = max_of_prefs ys.
  Proof.
    intros. simpl in H. unfold longer_pref in H. repeat dm.
  Qed.

  Lemma transition_list_hop : forall bs a fsm,
      transition a (transition_list bs fsm)
      = transition_list (bs ++ [a]) fsm.
  Proof.
    induction bs; intros; auto.
    - sis. rewrite transition_list_cons. repeat rewrite transition_list_nil. auto.
    - sis. rewrite transition_list_cons. rewrite IHbs. sis. rewrite transition_list_cons. auto.
  Qed.

  Lemma deriv_list_hop : forall bs a fsm,
      derivative a (derivative_list bs fsm)
      = derivative_list (bs ++ [a]) fsm.
  Proof.
    induction bs; intros; auto.
    simpl. apply IHbs.
  Qed.

  Lemma mpref_cons : forall code px sx fsm a i i',
      max_pref_fn code i (transition a fsm) = Some (px, sx, i')
      <-> max_pref_fn (a :: code) (incr i) fsm = Some (a :: px, sx, i').
  Proof.
    intros. simpl.
    repeat dm; split; intros;
      try( rewrite decr_inv_incr in *; rewrite E in *; repeat inj_all; auto; discriminate ).
    destruct code; sis; repeat dm; discriminate.
  Qed.

  Lemma accepting_dt : forall b e,
      accepting (transition b (init_state e)) =
      accepting (init_state (derivative b e)).
  Proof.
    intros. destruct (accepting (transition b (init_state e))) eqn:E.
    - rewrite accepts_nil in E. rewrite accepts_transition in E.
      symmetry in E. rewrite accepts_matches in E. apply der_match in E.
      rewrite <- accepts_matches in E. rewrite <- accepts_nil in E. auto.
    - symmetry. rewrite false_not_true in *. intros C. destruct E.
      rewrite accepts_nil. rewrite accepts_transition.
      symmetry. rewrite accepts_matches. apply der_match.
      rewrite <- accepts_matches. rewrite <- accepts_nil. auto.
  Qed.

  Lemma dbl_trans_lst : forall a b e,
    transition a (transition b (init_state e))
    = transition_list [b; a] (init_state e).
  Proof.
    intros. repeat rewrite transition_list_cons. rewrite transition_list_nil. auto.
  Qed.

  Lemma dbl_deriv_lst : forall s0 a0 e,
      derivative s0 (derivative a0 e)
      = derivative_list [a0; s0] e.
  Proof. auto. Qed.

  (* ow *)
  Lemma mpref_dt_list : forall code bs e a i,
      max_pref_fn code i (transition a (init_state e))
      = max_pref_fn code i (init_state (derivative a e))
      /\
      max_pref_fn code i (transition_list bs (init_state e)) =
      max_pref_fn code i (init_state (derivative_list bs e)).
  Proof.
    induction code; induction bs; intros.
    - split; auto; simpl; repeat dm.
      + rewrite accepting_dt in *. rewrite E in E0. discriminate.
      + rewrite accepting_dt in *. rewrite E in E0. discriminate.
      + rewrite transition_list_nil in *. rewrite E in E0. discriminate.
      + rewrite transition_list_nil in *. rewrite E in E0. discriminate.
    - split.
      + simpl. repeat dm.
        * rewrite accepting_dt in *. rewrite E in E0. discriminate.
        * rewrite accepting_dt in *. rewrite E in E0. discriminate.
      + simpl. repeat dm.
        * rewrite transition_list_cons in E.
          rewrite <- derivative_list_cons in *.
          rewrite <- accepting_dt_list in *. rewrite transition_list_cons in *.
          rewrite E in *. discriminate.
        * rewrite transition_list_cons in E.
          rewrite <- derivative_list_cons in *.
          rewrite <- accepting_dt_list in *. rewrite transition_list_cons in *.
          rewrite E in *. discriminate.
    - assert(IHcode0 : forall (e : regex) (a : Sigma) i,
           max_pref_fn code i (transition a (init_state e)) =
           max_pref_fn code i (init_state (derivative a e))).
      { intros. specialize (IHcode []). apply IHcode. }
      assert(IHcode1 : forall (bs : list Sigma) (e : regex) i,
           max_pref_fn code i (transition_list bs (init_state e)) =
           max_pref_fn code i (init_state (derivative_list bs e))).
      { intros. specialize (IHcode bs e0 a). apply IHcode. }
      clear IHcode.
      split.
      + destruct (max_pref_fn (a :: code) i (transition a0 (init_state e))) eqn:E.
        * destruct p. symmetry.
          destruct p.
          simpl in *.
          repeat dm; try(discriminate); repeat inj_all;
            try( rewrite IHcode0 in *;
                 rewrite dbl_trans_lst in *;
                 rewrite dbl_deriv_lst in *;
                 rewrite IHcode1 in *);
                 try(rewrite E3 in *; repeat inj_all; auto; discriminate);
                 try(rewrite E0 in *; repeat inj_all; auto; discriminate);
                 try(rewrite accepting_dt in *; rewrite accepting_dt_list in *; sis; auto);
                 try(rewrite E1 in *; discriminate).
                 rewrite E2 in *. discriminate.
        * simpl in *. repeat dm; try(discriminate).
          -- clear E. rewrite IHcode0 in E3.
             rewrite dbl_trans_lst in E0.
             rewrite dbl_deriv_lst in E3.
             rewrite IHcode1 in *. rewrite E3 in *. discriminate.
          -- rewrite accepting_dt in E4.
             rewrite dbl_trans_lst in *.
             rewrite dbl_deriv_lst in *.
             rewrite accepting_dt_list in *.
             rewrite E4 in *. discriminate.
          -- rewrite accepting_dt in *. rewrite E5 in *. discriminate.
      + rewrite transition_list_nil. unfold derivative_list. auto.
    - assert(IHcode0 : forall (e : regex) (a : Sigma) i,
           max_pref_fn code i (transition a (init_state e)) =
           max_pref_fn code i (init_state (derivative a e))).
      { intros. specialize (IHcode []). apply IHcode. }
      assert(IHcode1 : forall (bs : list Sigma) (e : regex) i,
           max_pref_fn code i (transition_list bs (init_state e)) =
           max_pref_fn code i (init_state (derivative_list bs e))).
      { intros. specialize (IHcode bs0 e0 a). apply IHcode. }
      clear IHcode.
      assert(IHbs0 : forall (e : regex) (a0 : Sigma) i,
         max_pref_fn (a :: code) i (transition a0 (init_state e)) =
         max_pref_fn (a :: code) i (init_state (derivative a0 e))).
      { intros. apply IHbs. }
      assert(IHbs1 : forall (e : regex) (a0 : Sigma) i,
         max_pref_fn (a :: code) i (transition_list bs (init_state e)) =
         max_pref_fn (a :: code) i (init_state (derivative_list bs e))).
      { intros. apply IHbs. apply a. }
      clear IHbs.
      split.
      + auto.
      + destruct (max_pref_fn (a :: code) i (transition_list (a0 :: bs) (init_state e))) eqn:E.
        * destruct p. destruct p.
          simpl in E. simpl. repeat dm; try(discriminate);
          try(rewrite IHcode0 in *;
             rewrite transition_list_cons in *;
             rewrite <- derivative_list_cons in *;
             rewrite transition_list_hop in *;
             rewrite deriv_list_hop in *;
             rewrite <- IHcode1 in *; rewrite <- transition_list_cons in *; sis;
             rewrite E3 in *; repeat inj_all; auto; discriminate);
            try(rewrite IHcode0 in *; rewrite <- derivative_list_cons in *;
             rewrite deriv_list_hop in *; rewrite <- IHcode1 in *;
             rewrite transition_list_hop in *; rewrite E0 in *; discriminate);
          try(rewrite accepting_dt in *; rewrite <- derivative_list_cons in *;
             rewrite deriv_list_hop in *; rewrite <- accepting_dt_list in *;
             rewrite transition_list_hop in *; rewrite E1 in *; discriminate).
          rewrite accepting_dt_list in *. sis. rewrite E2 in *. discriminate.
        * simpl in E. simpl. repeat dm; try(discriminate).
          -- rewrite IHcode0 in E3.
             rewrite transition_list_hop in *.
             rewrite deriv_list_hop in *.
             subst. inv E. rewrite IHcode1 in *. sis. rewrite E0 in *. inv E3.
          -- rewrite accepting_dt in *. rewrite transition_list_hop in *.
             rewrite accepting_dt_list in *. rewrite <- app_comm_cons in *.
             rewrite deriv_list_hop in *. sis. rewrite E1 in *. discriminate.
          -- rewrite accepting_dt in *. rewrite transition_list_hop in *.
             rewrite accepting_dt_list in *. rewrite <- app_comm_cons in *.
             rewrite deriv_list_hop in *. sis. rewrite E2 in *. discriminate.
  Qed.

  Lemma mpref_dt : forall code a e i,
      max_pref_fn code i (transition a (init_state e))
      = max_pref_fn code i (init_state (derivative a e)).
  Proof.
    assert(L := mpref_dt_list).
    intros. specialize(L code [] e a i). destruct L. auto.
  Qed.

  Lemma index_incr_cons : forall (code : String) a,
      init_index (length (a :: code)) = incr (init_index (length code)).
  Proof.
    intros. sis. apply incr_is_S.
  Qed.

  Lemma max_pref_matches : forall(code p x : String) (e : regex) i,
      Some (p, x, i) = max_pref_fn code (init_index (length code)) (init_state e)
      -> exp_match p e.
  Proof.
    induction code; intros.
    - simpl in H. dm; try(discriminate).
      injection H; intros; subst.
      rewrite accepts_nil in E. symmetry in E. rewrite accepts_matches in E. auto.
    - symmetry in H. destruct p.
      + simpl in H. repeat dm.
        * destruct p. injection H; intros; discriminate.
        * injection H; intros; discriminate.
        * rewrite accepts_nil in E1. symmetry in E1. rewrite accepts_matches in E1. auto.
        * discriminate.
      + destruct (Sigma_dec a s).
        * subst. rewrite index_incr_cons in *. apply mpref_cons in H.
          symmetry in H. rewrite mpref_dt in H. apply IHcode in H.
          apply der_match. auto.
        * symmetry in H. apply max_pref_fn_splits in H. injection H. intros. contradiction.
  Qed.

   Theorem re_max_pref_correct__None : forall(code : String) (e : regex),
      re_no_max_pref code e
      <-> None = max_pref_fn code (init_index (length code)) (init_state e).
   Proof.

     induction code.
     {
       split; intros.
       - simpl. inv H. dm. specialize (H1 []). destruct H1.
         + apply self_prefix.
         + rewrite accepts_nil in E. symmetry in E. rewrite accepts_matches in E. auto.
       - simpl in H. dm; try(discriminate).
         + apply re_MP0. intros. intros C. apply false_not_true in E.
           destruct E.
           symmetry. rewrite accepts_nil. apply accepts_matches.
           destruct cand; auto.
           inv H0. destruct H1. discriminate.
     }
     {
       split; intros.
       - simpl. repeat dm.
         + rewrite mpref_cons in E.
           symmetry in E.
           assert(E2 := E).
           apply max_pref_fn_splits in E. injection E. intros. clear E.
           rewrite incr_inv_decr in *. apply max_pref_matches in E2.
           inv H. specialize (H1 (a :: p1)). destruct H1; auto.
           apply pref_def. exists s. auto.
         + clear H. symmetry in E. rewrite mpref_dt in E.
           rewrite decr_inv_S in *. apply IHcode in E.
           inv E. specialize (H1 []). destruct H1. apply nil_is_prefix.
           rewrite accepts_nil in E0. rewrite accepts_transition in E0.
           symmetry in E0. apply accepts_matches in E0. apply der_match. auto.
         + symmetry in E. rewrite mpref_dt in E.
           rewrite decr_inv_S in *. apply IHcode in E.
           inv E. specialize (H1 []). destruct H1. apply nil_is_prefix.
           inv H. specialize (H1 []). destruct H1.
           * apply nil_is_prefix.
           * rewrite accepts_nil in E1. symmetry in E1. apply accepts_matches in E1.
             auto.
       - simpl in H. repeat dm; try(discriminate).
         clear H. rewrite mpref_dt in E. symmetry in E.
         rewrite decr_inv_S in *. apply IHcode in E.
         inv E. apply re_MP0. intros. intros C. inv H. destruct H0.
         destruct cand.
         + rewrite false_not_true in E1. destruct E1.
           rewrite accepts_nil. symmetry. rewrite accepts_matches. auto.
         + injection H. intros. rewrite H2 in *. clear H H2.
           specialize (H1 cand). destruct H1.
           * apply pref_def. eexists. eauto.
           * apply der_match. auto.
     }
   Qed.

   Theorem index_closure_gen : forall code p q qi r,
       Some (p, q, qi)
       = max_pref_fn code (init_index (length code)) r
       ->  qi = (init_index (length q)).
   Proof.
     induction code; intros.
     - sis. repeat dm.
       + repeat inj_all. sis. auto.
       + discriminate.
     - sis. repeat dm.
       + rewrite decr_inv_S in *. symmetry in E. apply IHcode in E.
         repeat inj_all. auto.
       + repeat inj_all. apply decr_inv_S.
       + repeat inj_all. sis. auto.
       + discriminate.
   Qed.

   Theorem index_closure : forall code p q qi e,
       Some (p, q, qi)
       = max_pref_fn code (init_index (length code)) (init_state e)
       ->  qi = (init_index (length q)).
   Proof.
     induction code; intros.
     - sis. repeat dm.
       + repeat inj_all. sis. auto.
       + discriminate.
     - sis. repeat dm.
       + rewrite decr_inv_S in *. symmetry in E. rewrite mpref_dt in *. apply IHcode in E.
         repeat inj_all. auto.
       + repeat inj_all. apply decr_inv_S.
       + repeat inj_all. sis. auto.
       + discriminate.
   Qed.

  Theorem re_max_pref_correct__Some : forall(code p : String) (e : regex),
      re_max_pref code e p
      <-> exists(q : String), Some (p, q, (init_index (length q)))
                       = max_pref_fn code (init_index (length code)) (init_state e).
  Proof.
    induction code.
    {
      intros p e. split; intros H.
      - exists []. simpl. assert (A0 : p = []).
        {
          inv H. inv H1. destruct H0. destruct x.
          - rewrite nil_right in H. apply H.
          - destruct p.
            + reflexivity.
            + discriminate.
        }
        dm.
        + rewrite A0. reflexivity.
        + inv H. rewrite accepts_nil in E. apply accepts_matches in H2.
          rewrite E in H2. discriminate.
      - destruct H. apply re_MP1.
        + apply max_pref_fn_splits in H. symmetry in H.
          apply pref_def. exists x. apply H.
        + apply max_pref_matches in H. apply H.
        + intros cand H0. inv H0. destruct H1.
          assert (A0 : cand = []).
          {
            destruct cand.
            - reflexivity.
            - discriminate.
          }
          assert (A1 : p = []).
          {
            simpl in H. dm.
            - injection H. intros. auto.
            - discriminate.
          }
          rewrite A0. rewrite A1. left. omega.
    }
    {
      intros p e. split; intros H.
      - destruct p.
        + exists (a :: code). inv H. simpl.
          dm.
          * destruct p. destruct p. symmetry in E.
            rewrite mpref_dt in E.
            rewrite decr_inv_S in *.
            assert( i = init_index (length s)).
            { eapply index_closure in E. auto. }
            rewrite H in *. clear H.
            assert (Ae : exists q, Some (p, q, init_index (length q))
                              = max_pref_fn code (init_index (length code))
                                            (init_state (derivative a e))).
            { exists s. apply E. }
            apply IHcode in Ae. inv Ae.
            assert (Ap : a :: p ++_= a :: code).
            { apply cons_prefix. split. reflexivity. apply H0. }
            apply H3 in Ap. destruct Ap.
            -- simpl in H. omega.
            -- exfalso. destruct H. apply der_match. auto.
          * assert (A0 : accepting (transition a (init_state e)) = false).
            {
              destruct code.
              - simpl in E. dm.
                + discriminate.
              - simpl in E. dm.
                + destruct p. dm. discriminate.
                + dm.
                  * discriminate.
                  * dm.
                    -- discriminate.
            }
            rewrite A0. apply accepts_matches in H2. rewrite <- accepts_nil in H2.
            rewrite <- H2. reflexivity.
        + inv H. inv H1. destruct H0. injection H.
          intros I1 I2. clear H. exists x. subst s.
          assert (Ap : p ++_= code).
          { apply pref_def. exists x. apply I1. }
          simpl. dm; symmetry in E.
          * destruct p0. destruct p0.
            rewrite decr_inv_S in *.
            assert(i = init_index (length s)). symmetry in E. rewrite mpref_cons in E.
            { symmetry in E. erewrite <- index_incr_cons in *. apply index_closure in E. auto. }
            rewrite H in *. clear H.
            assert (Ae : exists q, Some (p0, q, init_index (length q))
                              = max_pref_fn code (init_index (length code))
                                           (init_state (derivative a e))).
            { exists s. symmetry in E. rewrite mpref_dt in E. auto. }
            apply IHcode in Ae. inv Ae. inv H1. destruct H5. apply max_pref_fn_splits in E.
            (* Want to show p = p0 *)
            assert (A0 : p ++_= p ++ x).
            { apply pref_def. exists x. reflexivity. }
            assert (A1 : a :: p0 ++_= a :: p ++ x).
            { apply pref_def. exists x0. rewrite <- H. reflexivity. }
            apply H3 in A1. apply H4 in A0.
            (* should follow that p and p0 are prefixes of the same length and thus equal *)
            assert (A0' : length p <= length p0).
            {
              destruct A0.
              - apply H1.
              - exfalso. destruct H1. apply der_match. auto.
            }
            assert (A1' : length p0 <= length p).
            {
              destruct A1.
              - simpl in H1. omega.
              - exfalso. destruct H1. apply der_match; auto.
            }
            assert (A : length p = length p0).
            { omega. }
            assert (As : p0 ++_= p ++ x).
            { apply pref_def. exists x0. apply H. }
            apply eq_len_eq_pref with (x := p ++ x) in A.
            -- rewrite A. rewrite A in E. apply app_inv_head in E. rewrite E. reflexivity.
            -- apply As.
            -- apply Ap.
          * rewrite mpref_dt in E. rewrite decr_inv_S in *.
            apply re_max_pref_correct__None in E. inv E.
            assert (A0 : p = []).
            {
              assert (A1 : p ++_= p ++ x).
              { apply pref_def. exists x. reflexivity. }
              apply H1 in A1. destruct A1. apply der_match. auto.
            }
            assert (A1 : accepting (transition a (init_state e)) = true).
            {
              rewrite A0 in H2. symmetry. rewrite accepts_nil. rewrite accepts_transition.
              apply accepts_matches. auto.
            }
            rewrite A1. rewrite A0. reflexivity.
      - destruct H. apply re_MP1.
        + apply max_pref_fn_splits in H. apply pref_def. exists x. symmetry. apply H.
        + apply max_pref_matches in H. apply H.
        + intros cand Hpref. destruct p.
          * simpl in H.
            dm.
            -- destruct p. destruct p. discriminate.
            -- dm.
               ++ discriminate.
               ++ dm.
                  ** symmetry in E. rewrite mpref_dt in E. rewrite decr_inv_S in *.
                     apply re_max_pref_correct__None in E. inv E. destruct cand.
                     { left. omega. }
                     {
                       right. inv Hpref. destruct H0. injection H0. intros I1 I2.
                       unfold not. intros C. assert (A : cand ++_= code).
                       { apply pref_def. exists x0. apply I1. }

                       apply H1 in A. destruct A. subst.
                       apply der_match; auto.
                     }
                  ** discriminate.
          * simpl in H.
            dmh; symmetry in E.
            -- destruct p0. destruct p0. injection H. intros I1 I2 I3 I4.
               rewrite decr_inv_S in *. rewrite mpref_dt in E.
               assert(i = init_index (length s0)).
               { repeat inj_all. auto. }
               rewrite H0 in *. clear H0.
               assert (Ae : exists q, Some (p0, q, init_index (length q))
                                 = max_pref_fn code (init_index (length code))
                                               (init_state (derivative a e))).
               { exists s0. apply E. }
               apply IHcode in Ae. inv Ae. destruct cand.
               ++ left. simpl. omega.
               ++ inv Hpref. destruct H0. injection H0. intros. subst s.
                  assert (Apref : cand ++_= code).
                  { apply pref_def. exists x. auto. }
                  apply H3 in Apref. destruct Apref.
                  ** left. simpl. omega.
                  ** right. intros C. destruct H5. apply der_match. auto.
            -- rewrite mpref_dt in E. rewrite decr_inv_S in *.
               apply re_max_pref_correct__None in E. inv E.
               assert (A0 : accepting (transition a (init_state e)) = true).
               {
                 repeat dm;
                   try(reflexivity); try(discriminate).
               }
               assert (A1 : [] ++_= code).
               { apply nil_is_prefix. }
               apply H1 in A1. destruct A1. apply accepts_matches. rewrite <- accepts_nil.
               symmetry. rewrite accepts_nil in *. rewrite accepts_transition in A0.
               symmetry in A0. symmetry.
               rewrite accepts_matches in *.
               apply der_match. apply A0.
    }
  Qed.

  Lemma pref_not_no_pref : forall code p r,
      re_max_pref code r p
      -> ~(re_no_max_pref code r).
  Proof.
    intros code p r H C. inv H. inv C.
    apply H0 in H1. contradiction.
  Qed.

  Lemma max_pref_fn_Some_or_None : forall code e,
      (exists p q, Some (p, q, init_index (length q))
      = max_pref_fn code (init_index (length code)) (init_state e))
      \/ None = max_pref_fn code (init_index (length code)) (init_state e).
  Proof.
    intros code e.
    destruct (max_pref_fn code (init_index (length code)) (init_state e)) eqn:E.
    - left. destruct p. destruct p. exists p. exists s. symmetry in E. apply index_closure in E.
      subst. reflexivity.
    - right. reflexivity.
  Qed.

  Lemma re_pref_or_no_pref : forall code r,
      (exists p, re_max_pref code r p) \/ re_no_max_pref code r.
  Proof.
    intros code r.
    assert(L := max_pref_fn_Some_or_None).
    specialize (L code). specialize (L r). destruct L.
    - left. destruct H as [p]. apply re_max_pref_correct__Some in H.
      eexists; eauto.
    - right. apply re_max_pref_correct__None in H. auto.
  Qed.

  Lemma part_around_in : forall (T : Type) (xs : list T) (x : T),
      In x xs -> exists xs1 xs2, xs = xs1 ++ (x :: xs2).
  Proof.
    intros T. induction xs; intros x Hin. contradiction.
    simpl in Hin. destruct Hin.
    - exists []. exists xs. rewrite H. reflexivity.
    - apply IHxs in H. destruct H as (xs1 & xs2 & H).
      rewrite H. exists (a :: xs1). exists xs2. reflexivity.
  Qed.

  Lemma at_index_In : forall rus ru,
      (exists n, at_index ru n rus) <-> In ru rus.
  Proof.
    induction rus; intros ru; split; intros H.
    - inv H. inv H0.
    - contradiction.
    - inv H.
      simpl. destruct x.
      + inv H0. left. reflexivity.
      + inv H0. right. apply IHrus. exists x. apply IH.
    - simpl in H. destruct H.
      + exists 0. apply AI0. auto.
      + apply IHrus in H. inv H. exists (S x).
        apply AI1. apply H0.
  Qed.

  Lemma In_least_index : forall rus ru,
      In ru rus <-> (exists n, least_index ru n rus).
  Proof.
    intros rus ru. split.
    {
      generalize dependent ru. induction rus; intros ru H. contradiction.
      destruct (ru_dec a ru).
      {
        subst. exists 0. apply LI1.
        - apply AI0. auto.
        - intros n' Hlt. omega.
      }
      {
        destruct H.
        - contradiction.
        - apply IHrus in H. destruct H. exists (S x). inv H. apply LI1.
          + apply AI1. apply Hat.
          + intros n' Hlt. intros C. destruct n'.
            * inv C. contradiction.
            * assert(Hlt' : n' < x). omega.
              apply Hnot in Hlt'. inv C. contradiction.
      }
    }
    {
      generalize dependent ru. induction rus; intros ru H.
      - inv H. inv H0. inv Hat.
      - destruct (ru_dec a ru); subst.
        + simpl. auto.
        + inv H. destruct x.
          * inv H0. inv Hat. contradiction.
          * simpl. right. apply IHrus. exists x. inv H0. apply LI1.
            -- inv Hat. apply IH.
            -- intros n' Hlt. specialize (Hnot (S n')).
               assert(A : S n' < S x). omega.
               apply Hnot in A. intros C. destruct A.
               apply AI1. apply C.
    }
  Qed.

  Lemma at_index_num_prev : forall rus1 ru rus2,
      at_index ru (length rus1) (rus1 ++ ru :: rus2).
  Proof.
    induction rus1; intros ru rus2.
    - simpl. apply AI0. reflexivity.
    - simpl. apply AI1. apply IHrus1.
  Qed.

  Lemma part_around_least_index : forall rus n ru,
      least_index ru n rus -> (exists rus1 rus2,
                                 rus = rus1 ++ (ru :: rus2)
                                 /\ length rus1 = n
                                 /\ ~(In ru rus1)).
  Proof.
    induction rus; intros n ru H.
    {
      inv H. inv Hat.
    }
    {
      inv H. inv Hat.
      - exists []. exists rus. split; [| split]; try(auto).
      - assert(least_index ru n0 rus).
        {
          apply LI1.
          - apply IH.
          - intros n' H C.
            assert(A0 : S n' < S n0).
            { omega. }
            apply Hnot in A0. destruct A0.
            apply AI1. apply C.
        }
        apply IHrus in H.
        destruct H as (rus1 & rus2 & IH').
        destruct IH' as (Heq & Hlen & Hnin).
        exists (a :: rus1). exists rus2. split; [| split].
        + rewrite Heq. reflexivity.
        + simpl. omega.
        + intros C. destruct Hnin. simpl in C. destruct C.
          * specialize (Hnot 0). rewrite H in Hnot. destruct Hnot.
            -- omega.
            -- apply AI0. reflexivity.
          * apply H.
    }
  Qed.

  (* Ah so this is what proof automation can do... *)
  Lemma lgr_pref_assoc : forall a b c,
      longer_pref (longer_pref a b) c = longer_pref a (longer_pref b c).
  Proof.
    intros a b c. unfold longer_pref.
    repeat dm; repeat inj_all; subst; repeat eqb_eq_all; repeat ltb_lt_all;
      try(discriminate);
      try(omega);
      try(auto).
  Qed.

  Lemma all_mprefs_nil : forall label p ps suffix i i' rs r,
      max_of_prefs (max_prefs [] i (r :: rs)) <> (label, Some (p :: ps, suffix, i')).
  Proof.
    intros label p ps suffix. induction rs; intros.
    - intro C. simpl in *. unfold extract_fsm_for_max in *. unfold longer_pref in *. simpl.
      repeat dm; repeat inj_all; dm; try(discriminate).
    - specialize (IHrs a). intros C. destruct IHrs.
      simpl in *. unfold extract_fsm_for_max in *. unfold longer_pref in *. simpl.
      repeat dm;
        repeat inj_all; subst; repeat ltb_lt_all; repeat eqb_eq_all;
          subst; simpl in *; try(omega); repeat dm; try(discriminate).
  Qed.

  Lemma mpref_app_dist : forall ps1 ps2,
      max_of_prefs (ps1 ++ ps2) = longer_pref (max_of_prefs ps1) (max_of_prefs ps2).
  Proof.
    induction ps1; intros ps2.
    - simpl. destruct (max_of_prefs ps2). reflexivity.
    - simpl. rewrite IHps1. symmetry. apply lgr_pref_assoc.
  Qed.

  Lemma mpref_cons_longer : forall ps p,
      max_of_prefs (p :: ps) = longer_pref p (max_of_prefs ps).
  Proof.
    intros ps p. simpl. reflexivity.
  Qed.

  Lemma exists_rus_of_mpref_gen : forall rus code l px suffix i,
      max_of_prefs (max_prefs code (init_index (length code)) rus)
      = (l, Some (px, suffix, i))
      -> (exists r, In (l, r) rus
              /\ max_pref_fn code (init_index (length code)) r
                = Some (px, suffix, i)).
  Proof.
    induction rus; intros.
    {
      simpl in H. discriminate.
    }
    {
      unfold max_prefs in H.
      repeat first [rewrite map_cons in H | rewrite map_app in H].
      symmetry in H. apply max_first_or_rest in H. destruct H.
      - destruct a. simpl in H. injection H; intros; subst.
        exists s. split.
        * left. auto.
        * auto.
      - symmetry in H. apply IHrus in H. destruct H as [r]. destruct H.
        exists r. split.
        + right. apply H.
        + apply H0.
    }
  Qed.

  Lemma exists_rus_of_mpref : forall rus code l px suffix i,
      max_of_prefs (max_prefs code (init_index (length code)) (map init_srule rus))
      = (l, Some (px, suffix, i))
      -> (exists r, In (l, r) rus
              /\ max_pref_fn code (init_index (length code)) (init_state r)
                                  = Some (px, suffix, i)).
  Proof.
    induction rus; intros.
    {
      simpl in H. discriminate.
    }
    {
      unfold max_prefs in H.
      repeat first [rewrite map_cons in H | rewrite map_app in H].
      symmetry in H. apply max_first_or_rest in H. destruct H.
      - destruct a. simpl in H. injection H; intros; subst.
        exists r. split.
        * left. auto.
        * auto.
      - symmetry in H. apply IHrus in H. destruct H as [r]. destruct H.
        exists r. split.
        + right. apply H.
        + apply H0.
    }
  Qed.

  Lemma nil_mpref_nil_or_no_pref : forall rus code s l l1 r,
      max_of_prefs (max_prefs code (init_index (length code)) (map init_srule rus))
                    = (l1, Some ([], s, init_index (length s)))
      -> In (l, r) rus
      -> re_max_pref code r [] \/ re_no_max_pref code r.
  Proof.
    intros rus code s l l1 r Hmax Hin. assert(L := re_pref_or_no_pref code r).
    destruct L.
    - destruct H. destruct x.
      + left. apply H.
      (* This was a fun one *)
      + exfalso.
        apply re_max_pref_correct__Some in H. destruct H as [q]. symmetry in H.
        assert(L := (part_around_in _ rus (l, r)) Hin).
        destruct L as (rus1 & rus2 & L). subst rus. clear Hin.
        rewrite map_app in Hmax. rewrite map_cons in Hmax. simpl in Hmax.
        unfold max_prefs in Hmax. rewrite map_app in Hmax. rewrite map_cons in Hmax.
        simpl in Hmax.
        rewrite H in Hmax. rewrite mpref_app_dist in Hmax. rewrite mpref_cons_longer in Hmax.
        simpl in Hmax. unfold longer_pref in Hmax.
        (* 32 subgoals, 7 subproofs ! *)
        repeat dmh; subst;
          try (repeat inj_all; discriminate).
        * repeat inj_all. rewrite Nat.eqb_eq in *. sis. omega.
        * repeat inj_all. rewrite false_not_true in *. destruct E8.
          rewrite Nat.ltb_lt. sis. omega.

    - right. apply H.
  Qed.

  Lemma no_mpref_no_pref : forall rus code l l1 r,
      max_of_prefs (max_prefs code (init_index (length code)) (map init_srule rus))
      = (l1, None)
      -> In (l, r) rus
      -> re_no_max_pref code r.
  Proof.
    intros rus code l l1 r Hmax Hin. assert(L := re_pref_or_no_pref code r).
    destruct L.
    - exfalso. destruct H.
      (*apply invert_init_correct_max in H.*)
      apply re_max_pref_correct__Some in H. destruct H as [q]. symmetry in H.
      assert(L := (part_around_in _ rus (l, r)) Hin).
      destruct L as (rus1 & rus2 & L). subst rus. clear Hin.
      rewrite map_app in Hmax. rewrite map_cons in Hmax. simpl in Hmax.
      unfold max_prefs in Hmax. rewrite map_app in Hmax. rewrite map_cons in Hmax. simpl in Hmax.
      rewrite H in Hmax. rewrite mpref_app_dist in Hmax. rewrite mpref_cons_longer in Hmax.
      simpl in Hmax. unfold longer_pref in Hmax.
      repeat dmh; repeat inj_all; subst;
        try(discriminate);
        try(rewrite Hmax in E1; discriminate).
    - apply H.
  Qed.

  Lemma index_closure_mprefs : forall code rus l0 px suf x,
    max_of_prefs (max_prefs code (init_index (length code)) (map init_srule rus))
    = (l0, Some (px, suf, x))
    -> x = init_index (length suf).
  Proof.
    intros. apply exists_rus_of_mpref in H. destruct H. destruct H.
    eapply index_closure; eauto.
  Qed.

  Lemma eq_index_eq_ru : forall n rus ru1 ru2,
      at_index ru1 n rus
      -> at_index ru2 n rus
      -> ru1 = ru2.
  Proof.
    induction n; intros.
    - inv H. inv H0. auto.
    - inv H. inv H0. eapply IHn; eauto.
  Qed.

  Lemma eq_LI_eq_ru : forall n rus ru1 ru2,
      least_index ru1 n rus
      -> least_index ru2 n rus
      -> ru1 = ru2.
  Proof.
    intros. inv H. inv H0. eapply eq_index_eq_ru; eauto.
  Qed.

  Lemma least_index_unique : forall rus ru n1 n2,
      least_index ru n1 rus
      -> least_index ru n2 rus
      -> n1 = n2.
  Proof.
    intros. inv H. inv H0.
    destruct (Nat.lt_trichotomy n1 n2); [| destruct H].
    - apply Hnot0 in H. contradiction.
    - auto.
    - apply Hnot in H. contradiction.
  Qed.

  Lemma earlier_rule_split : forall rus ru1 ru2,
      In ru1 rus
      -> In ru2 rus
      -> ru1 = ru2 \/
        earlier_rule ru1 ru2 rus \/
        earlier_rule ru2 ru1 rus.
  Proof.
    intros.
    apply In_least_index in H. destruct H as [n1].
    apply In_least_index in H0. destruct H0 as [n2].
    assert(L := Nat.lt_trichotomy n1 n2). destruct L as [| L]; [|destruct L].
    - right. left. apply ERu1. intros.
      apply least_index_unique with (n1 := n0) in H; auto; subst.
      apply least_index_unique with (n1 := n3) in H0; auto; subst.
      auto.
    - left. subst. apply eq_LI_eq_ru with (ru1 := ru1) in H0; auto.
    - right. right. apply ERu1. intros.
      apply least_index_unique with (n1 := n3) in H; auto; subst.
      apply least_index_unique with (n1 := n0) in H0; auto; subst.
      auto.
  Qed.

  Lemma flip_gt : forall n m,
      n > m <-> m < n.
  Proof.
    intros. omega.
  Qed.

  Lemma first_token_unique : forall t t' code rus,
      first_token code rus t
      -> first_token code rus t'
      -> t = t'.
  Proof.
    intros. inv H; inv H0.
    (* show p and p0 are prefixes of equal length and thus equal *)
    assert(Alen : length p = length p0).
    {
      destruct (Nat.lt_trichotomy (length p) (length p0)); [|destruct H].
      - apply flip_gt in H. eapply Hout in H; destruct H; eauto.
      - auto.
      - apply flip_gt in H. apply Hout0 with (l' := l) (r' := r) in H; destruct H; auto.
    }
    assert(Aeq : p = p0).
    {
      inv Hmpref. inv Hmpref0.
      eapply eq_len_eq_pref in Alen; eauto.
    }
    subst.
    (* show neither rule can be earlier than the other and thus they are equal *)
    specialize (Hlater r0 l0).
    specialize (Hlater0 r l).
    clear Hout Hout0 Hnempt Hnempt0.
    assert(L := earlier_rule_split rus (l,r) (l0,r0) Hex Hex0). destruct L; [| destruct H].
    - inv H. auto.
    - apply Hlater0 in H; auto. contradiction.
    - apply Hlater in H; auto. contradiction.
  Qed.

End LemmasFn.