(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU Lesser General Public License for more details.                *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************
    Proof of Huffman algorithm: Code.v

    Definitions of code as association lists and some properties

    Definitions:
      code, encode, decode, find_code, find_val,
      in_alphabet, unique_prefix, not_null

                                    Laurent.Thery@inria.fr (2003)
 **********************************************************************)

From Huffman Require Export Aux.
From Huffman Require Export Permutation.
From Huffman Require Export UniqueKey.
From Huffman Require Export Frequency.

Section Code.
(* Arbitrary set *)
Variable A : Type.
(* Equality is decidable *)
Variable eqA_dec : forall a b : A, {a = b} + {a <> b}.

(* A code is an association list *)
Definition code := list (A * list bool).

(*
  Predicate that tells that a message (a list of message) is in the
  alphabet of the code
*)
Definition in_alphabet (m : list A) (c : code) :=
  forall a : A, In a m -> exists l : list bool, In (a, l) c.

(* Being in an alphabet is compatible with inclusion *)
Theorem in_alphabet_incl :
 forall m1 m2 c, incl m1 m2 -> in_alphabet m2 c -> in_alphabet m1 c.
Proof using.
intros m1 m2 c H H0; red in |- *.
intros a H1; case (H0 a); auto.
Qed.

(* Every code is in the alphabet of an empty message *)
Theorem in_alphabet_nil : forall c, in_alphabet nil c.
Proof using.
intros c a H; inversion H.
Qed.
Hint Resolve in_alphabet_nil : core.

(* An element can be added in the message if it is in the code *)
Theorem in_alphabet_cons :
 forall (m : list A) c a ca,
 In (a, ca) c -> in_alphabet m c -> in_alphabet (a :: m) c.
Proof using.
intros m c a ca H H0; red in |- *; simpl in |- *.
intros a1 [H1| H1].
exists ca; rewrite <- H1; auto.
case (H0 a1); auto.
Qed.
Hint Resolve in_alphabet_cons : core.

(* Inversion theorem *)
Theorem in_alphabet_inv :
 forall (c : code) (a : A) (l : list A),
 in_alphabet (a :: l) c -> in_alphabet l c.
Proof using.
intros c a l H; red in |- *.
intros a1 H1; apply H; simpl in |- *; auto.
Qed.

Definition code_dec :
  forall (c : code) a,
  {(exists l : list bool, In (a, l) c)} +
  {(forall l : list bool, ~ In (a, l) c)}.
intros c a; elim c; simpl in |- *; auto.
intros (a1, l1) l H; case (eqA_dec a1 a); intros H1.
left; exists l1; rewrite H1; auto.
case H.
intros e; left; case e; intros l2 H2; exists l2; auto.
intros n; right; intros l0; red in |- *; intros [H0| H0];
 [ case H1 | case (n l0) ]; auto.
injection H0; auto.
Defined.

(* Checking if a code is in an alphabet is decidable *)
Definition in_alphabet_dec :
  forall m c, {in_alphabet m c} + {~ in_alphabet m c}.
intros m; elim m; simpl in |- *; auto.
intros a l H c; case (H c); intros H1.
case (code_dec c a); intros H2.
left; red in |- *; simpl in |- *.
intros a1 [H3| H3];
 [ case H2; intros l1 Hl1; exists l1; rewrite <- H3 | idtac ];
 auto.
right; red in |- *; intros H3; case (H3 a); simpl in |- *; auto.
right; Contradict H1; auto; red in |- *.
intros a0 H0; case (H1 a0); simpl in |- *; auto.
intros x H2; exists x; auto.
Defined.

(* The empty list is associated to none of element of A in the code *)
Definition not_null (c : code) := forall a : A, ~ In (a, nil) c.

(* Inversion theorem *)
Theorem not_null_inv :
 forall (a : A * list bool) l, not_null (a :: l) -> not_null l.
Proof using.
intros a l H; red in |- *.
intros a0; red in |- *; intros H0; case (H a0); simpl in |- *; auto.
Qed.

(* Adding a non-empty element preserves the property of non-emptyness *)
Theorem not_null_cons :
 forall a b (l : list (A * list bool)),
 b <> nil -> not_null l -> not_null ((a, b) :: l).
Proof using.
intros a b l H H0; red in |- *.
intros a1; simpl in |- *; red in |- *; intros [H1| H1]; auto.
case H; injection H1; auto.
case (H0 a1); simpl in |- *; auto.
Qed.
Hint Resolve not_null_cons : core.

(* Non emptyness is compatible with append *)
Theorem not_null_app :
 forall l1 l2 : list (A * list bool),
 not_null l1 -> not_null l2 -> not_null (l1 ++ l2).
Proof using.
intros l1; elim l1; simpl in |- *; auto.
intros (a2, l2); case l2; auto.
intros l H l0 H0 H1; case (H0 a2); simpl in |- *; auto.
intros b l l0 H l3 H0 H1; apply not_null_cons; auto.
red in |- *; intros H2; discriminate.
apply H; auto.
apply not_null_inv with (1 := H0).
Qed.
Hint Resolve not_null_app : core.

(* Adding an element in each component of a code makes it non-empty *)
Theorem not_null_map :
 forall (l : list (A * list bool)) b,
 not_null (map (fun v => match v with
                         | (a1, b1) => (a1, b :: b1)
                         end) l).
Proof using.
intros l; elim l; simpl in |- *; auto.
intros b; red in |- *; intros a; red in |- *; intros H; inversion H.
intros (a1, l1) l0 H b; apply not_null_cons; auto.
red in |- *; intros; discriminate.
Qed.
Hint Resolve not_null_map : core.

(* Define the property of list of booleans to be a prefix of another *)
Inductive is_prefix : list bool -> list bool -> Prop :=
  | prefixNull : forall l, is_prefix nil l
  | prefixCons :
      forall (b : bool) l1 l2,
      is_prefix l1 l2 -> is_prefix (b :: l1) (b :: l2).
Hint Constructors is_prefix : core.

(* A list is a prefix of itself *)
Theorem is_prefix_refl : forall l, is_prefix l l.
Proof using.
intros l; elim l; simpl in |- *; auto.
Qed.
Hint Resolve is_prefix_refl : core.

(* A code is unique_prefix, if there is no encoding that is prefix of another *)
Definition unique_prefix (l : code) :=
  (forall (a1 a2 : A) (lb1 lb2 : list bool),
   In (a1, lb1) l -> In (a2, lb2) l -> is_prefix lb1 lb2 -> a1 = a2) /\
  unique_key l.

(* The empty code is unique prefix *)
Theorem unique_prefix_nil : unique_prefix nil.
Proof using.
split; auto.
intros a1 a2 lb1 lb2 H; inversion H; auto.
Qed.
Hint Resolve unique_prefix_nil : core.

(* A unique prefix code can not have two elements prefix one from another *)
Theorem unique_prefix1 :
 forall (c : code) (a1 a2 : A) (lb1 lb2 : list bool),
 unique_prefix c ->
 In (a1, lb1) c -> In (a2, lb2) c -> is_prefix lb1 lb2 -> a1 = a2.
Proof using.
intros c a1 a2 lb1 lb2 (H1, H2); apply (H1 a1 a2 lb1 lb2); auto.
Qed.

(* A unique prefix code has unique keys *)
Theorem unique_prefix2 : forall c : code, unique_prefix c -> unique_key c.
Proof using.
intros c (H1, H2); auto.
Qed.

(* Inversion theorem *)
Theorem unique_prefix_inv :
 forall (c : code) (a : A) (l : list bool),
 unique_prefix ((a, l) :: c) -> unique_prefix c.
Proof using.
intros c a l (H1, H2); split.
intros a1 a2 lb1 lb2 H H0 H3; apply (H1 a1 a2 lb1 lb2); simpl in |- *; auto.
apply unique_key_inv with (1 := H2); auto.
Qed.

(* A prefix code with a  least two distinct elements is not_null *)
Theorem unique_prefix_not_null :
 forall (c : code) (a b : A),
 a <> b -> in_alphabet (a :: b :: nil) c -> unique_prefix c -> not_null c.
Proof using.
intros c a b H H0 H1.
unfold not_null in |- *; intros a1; red in |- *; intros Ha1.
case (H0 a); simpl in |- *; auto; intros l1 Hl1.
case (H0 b); simpl in |- *; auto; intros l2 Hl2.
case H; apply trans_equal with a1.
apply sym_equal; apply unique_prefix1 with (3 := Hl1) (2 := Ha1); auto.
apply unique_prefix1 with (3 := Hl2) (2 := Ha1); auto.
Qed.

(* Unique prefix is preserved by permutation *)
Theorem unique_prefix_permutation :
 forall c1 c2 : code,
 permutation c1 c2 -> unique_prefix c1 -> unique_prefix c2.
Proof using.
intros c1 c2 H (H1, H2).
cut (permutation c2 c1); [ intros HP; split | apply permutation_sym; auto ].
intros a1 a2 lb1 lb2 H0 H3 H4.
apply (H1 a1 a2 lb1 lb2); auto.
apply permutation_in with (2 := H0); auto.
apply permutation_in with (2 := H3); auto.
apply unique_key_perm with (2 := H2); auto.
Qed.

(*
  Find the list of booleans associated with an element,
  return the empty list if the element does not exists
*)
Fixpoint find_code (a : A) (l : code) {struct l} : list bool :=
  match l with
  | nil => nil
  | (b, c) :: l1 =>
      match eqA_dec a b with
      | left _ => c
      | right _ => find_code a l1
      end
  end.

(* The result of find_code is in the code *)
Theorem find_code_correct1 :
 forall (c : code) (a : A) (b : bool) (l : list bool),
 find_code a c = b :: l -> In (a, b :: l) c.
Proof using.
intros c a b l; elim c; simpl in |- *; auto.
intros; discriminate.
intros a0; case a0.
intros a1; case (eqA_dec a a1); simpl in |- *; auto.
intros e l0 l1 H H0; left;
 apply f_equal2 with (f := pair (A:=A) (B:=list bool));
 auto.
Qed.

(* What is in the code can be found by find_code *)
Theorem find_code_correct2 :
 forall (c : code) (a : A) (l : list bool),
 unique_key c -> In (a, l) c -> find_code a c = l.
Proof using.
intros c a l; generalize a l; elim c; clear a l c; simpl in |- *; auto.
intros a l H H0; case H0.
intros a; case a.
intros a0 l l0 H a1 l1 H0 H1; case (eqA_dec a1 a0).
intros H2; case H1; intros H3.
injection H3; auto.
apply unique_key_in_inv with (l := (a0, l) :: l0) (a := a0); simpl in |- *;
 auto.
rewrite <- H2; auto.
intros H2; case H1; auto.
intros H3; case H2; injection H3; auto.
intros; apply H; auto.
apply unique_key_inv with (1 := H0); auto.
Qed.

(* There is not more than what is in the code *)
Theorem not_in_find_code :
 forall a l, (forall p, ~ In (a, p) l) -> find_code a l = nil.
Proof using.
intros a l; elim l; simpl in |- *; auto.
intros (a1, l1) l0 H H0.
case (eqA_dec a a1); auto.
intros H1; case (H0 l1); rewrite H1; auto.
intros H1; apply H; intros p; red in |- *; intros Hp; case (H0 p); auto.
Qed.

(* find_code is composed by append *)
Theorem find_code_app :
 forall a l1 l2,
 not_null l1 ->
 find_code a (l1 ++ l2) =
 match find_code a l1 with
 | nil => find_code a l2
 | b1 :: l3 => b1 :: l3
 end.
Proof using.
intros a l1; generalize a; elim l1; simpl in |- *; auto; clear a l1.
intros (a1, l1) l H a l2 H1; case (eqA_dec a a1); auto.
generalize H1; case l1; auto.
intros H0; case (H0 a1); simpl in |- *; auto.
cut (not_null l); simpl in |- *; auto.
apply not_null_inv with (1 := H1); auto.
Qed.

(* find_code is invariant under permutation *)
Theorem find_code_permutation :
 forall (a : A) (c1 c2 : code),
 permutation c1 c2 -> unique_prefix c1 -> find_code a c1 = find_code a c2.
Proof using.
intros a c1 c2 H; elim H; simpl in |- *; auto.
intros a0; case a0.
intros a1; case (eqA_dec a a1); auto.
intros n l L1 L2 H0 H1 H2; apply H1.
apply unique_prefix_inv with (1 := H2).
intros a0; case a0.
intros a1 l1.
case (eqA_dec a a1).
intros Ha1 b; case b; auto.
intros a2 l2 L HL; case (eqA_dec a a2); auto.
intros e.
case unique_key_in with (1 := unique_prefix2 _ HL) (b2 := l2); auto.
rewrite <- Ha1; rewrite e; simpl in |- *; auto.
intros Ha1 b; case b; auto.
intros L1 L2 L3 H0 H1 H2 H3 H4; apply trans_equal with (find_code a L2); auto.
apply H3.
apply (unique_prefix_permutation _ _ H0); auto.
Qed.

(*
  Searching in a list with a common first element is equivalent
  to the search skipping the element
*)
Theorem in_find_map :
 forall p a l b,
 In (a, l) p ->
 find_code a
   (map
      (fun v : A * list bool => match v with
                          | (a1, b1) => (a1, b :: b1)
                          end) p) = b :: find_code a p.
Proof using.
intros p; elim p; simpl in |- *; auto.
intros a l b H; case H.
intros (a1, l1) l H a0 l0 b [H0| H0]; auto.
case (eqA_dec a0 a1); auto.
intros HH; case HH; injection H0; auto.
case (eqA_dec a0 a1); auto.
intros n; apply (H a0 l0 b); auto.
Qed.

(*
  Searching in a list with a common first element is equivalent
  to the search skipping the element
*)
Theorem not_in_find_map :
 forall p a b,
 (forall l, ~ In (a, l) p) ->
 find_code a
   (map
      (fun v : A * list bool => match v with
                                | (a1, b1) => (a1, b :: b1)
                                end) p) = nil.
Proof using.
intros p; elim p; simpl in |- *; auto.
intros (a1, l1) l H a0 b H0; case (eqA_dec a0 a1); auto.
intros e; case (H0 l1); rewrite e; auto.
intros n; apply (H a0 b); auto.
intros l0; red in |- *; intros H1; case (H0 l0); auto.
Qed.

(*
  Find the element associated with a list of booleans,
  return None if it does not exist in the code
*)
Fixpoint find_val (a : list bool) (l : code) {struct l} : option A :=
  match l with
  | nil => None
  | (b, c) :: l1 =>
      match list_eq_dec eq_bool_dec a c with
      | left _ => Some b
      | right _ => find_val a l1
      end
  end.

(* find_val returns an element of the code *)
Theorem find_val_correct1 :
 forall (c : code) (a : A) (l : list bool),
 find_val l c = Some a -> In (a, l) c.
Proof using.
intros c a l; elim c; simpl in |- *; auto.
intros; discriminate.
intros a0; case a0.
intros a1 l0 l1; case (list_eq_dec eq_bool_dec l l0); auto.
intros e H H0; injection H0.
intros e1; left; apply f_equal2 with (f := pair (A:=A) (B:=list bool)); auto.
Qed.

(* An element of the code can be found by find_val *)
Theorem find_val_correct2 :
 forall (c : code) (a : A) (l : list bool),
 unique_prefix c -> In (a, l) c -> find_val l c = Some a.
Proof using.
intros c a l; generalize a l; elim c; clear a l c; simpl in |- *; auto.
intros a l H H0; case H0.
intros a; case a.
intros a0 l l0 H a1 l1 H0 H1; case (list_eq_dec eq_bool_dec l1 l).
intros H2; apply f_equal with (f := Some (A:=A)).
case H1; intros H3.
injection H3; auto.
apply unique_prefix1 with (1 := H0) (lb1 := l) (lb2 := l1); simpl in |- *;
 auto.
rewrite H2; auto.
intros H2; case H1; auto.
intros H3; case H2; injection H3; auto.
intros; apply H; auto.
apply unique_prefix_inv with (1 := H0); auto.
Qed.

Opaque list_eq_dec.

(* The value of an empty list cannot be found in a non empty code *)
Theorem not_null_find_val :
 forall c : code, not_null c -> find_val nil c = None.
Proof using.
intros c; elim c; simpl; auto.
intros a; case a.
intros a1 l; case (list_eq_dec eq_bool_dec nil l); auto.
intros e l0 H H0; case (H0 a1); rewrite e; simpl in |- *; auto.
intros n l0 H H0; apply H.
unfold not_null in |- *; intros a2; red in |- *; intros H1.
case (H0 a2); simpl in |- *; auto.
Qed.

(* Encoding is done by iteratively applying find_code *)
Fixpoint encode (c : code) (m : list A) {struct m} : list bool :=
  match m with
  | nil => nil
  | a :: b => find_code a c ++ encode c b
  end.

(* Encoding can be splitted for appended lists *)
Theorem encode_app :
 forall l1 l2 c, encode c (l1 ++ l2) = encode c l1 ++ encode c l2.
Proof using.
intros l1; elim l1; simpl in |- *; auto.
intros a l H l2 c; rewrite H; auto.
rewrite app_ass; auto.
Qed.

(* Inversion theorem for encode *)
Theorem encode_cons_inv :
 forall a l1 l m1, ~ In a m1 -> encode ((a, l1) :: l) m1 = encode l m1.
Proof using.
intros a l1 l m1; generalize a l1 l; elim m1; simpl in |- *; auto;
 clear a l1 l m1.
intros a l H a0 l1 l0 H0; case (eqA_dec a a0); simpl in |- *; auto.
intros H1; case H0; auto.
intros e; rewrite H; auto.
Qed.

(* The encoding does not depend of permutation *)
Theorem encode_permutation :
 forall (m : list A) (c1 c2 : code),
 permutation c1 c2 -> unique_prefix c1 -> encode c1 m = encode c2 m.
Proof using.
intros m; elim m; simpl in |- *; auto.
intros a l H c1 c2 H0 H1.
apply f_equal2 with (f := app (A:=bool)); auto.
apply find_code_permutation; auto.
Qed.

(* Permuting the message permutes the encoding *)
Theorem encode_permutation_val :
 forall m1 m2 c, permutation m1 m2 -> permutation (encode c m1) (encode c m2).
Proof using.
intros m1 m2 c H; elim H; simpl in |- *; auto; clear H m1 m2.
intros; repeat rewrite <- app_ass; auto.
intros l1 l2 l3 H H0 H1 H2; apply permutation_trans with (1 := H0); auto.
Qed.

(*
  To decode, first find the initial section of
  booleans that maps an encoding, this initial section is
  accumulated in the head
*)
Fixpoint decode_aux (c : code) (head m : list bool) {struct m} : list A :=
  match m with
  | nil => match find_val head c with
           | Some a => a :: nil
           | None => nil
           end
  | a :: m1 =>
      match find_val head c with
      | Some a1 => a1 :: decode_aux c (a :: nil) m1
      | None => decode_aux c (head ++ a :: nil) m1
      end
  end.

(* decode_aux is correct *)
Theorem decode_aux_correct :
 forall c : code,
 unique_prefix c ->
 not_null c ->
 forall (m1 m2 head : list bool) (a : A),
 find_val (head ++ m1) c = Some a ->
 decode_aux c head (m1 ++ m2) = a :: decode_aux c nil m2.
Proof using.
intros c Hc1 Hc2 m1; elim m1; simpl in |- *; auto.
intros m2; case m2; simpl in |- *; auto.
intros head a; rewrite <- app_nil_end.
intros H1; rewrite H1; auto.
rewrite not_null_find_val; auto.
intros b l head a; rewrite <- app_nil_end.
intros H1; rewrite H1; auto.
rewrite not_null_find_val; auto.
intros a l Rec m2 head a1 H2.
rewrite <- Rec with (head := head ++ a :: nil).
generalize (fun a => find_val_correct1 c a head).
case (find_val head c); auto.
intros a0 H; (cut (In (a0, head) c); [ intros Hin1 | auto ]).
cut (In (a1, head ++ a :: l) c);
 [ intros Hin2 | apply find_val_correct1; auto ].
cut (a1 = a0); [ intros Heq | idtac ].
absurd (head ++ a :: l = head); auto.
elim head; simpl in |- *; auto.
red in |- *; intros; discriminate.
intros a2 l0 H0; red in |- *; intros H1; case H0; auto.
injection H1; auto.
apply unique_key_in_inv with (l := c) (a := a1); auto.
apply unique_prefix2; auto.
rewrite Heq; auto.
apply sym_equal; apply (unique_prefix1 c a0 a1 head (head ++ a :: l)); auto.
elim head; simpl in |- *; auto.
rewrite app_ass; auto.
Qed.

(* Decode is just decode_aux with an empty head *)
Definition decode (c : list (A * list bool)) (m : list bool) :=
  decode_aux c nil m.

(* Decoding is correct *)
Theorem decode_correct :
 forall c : code,
 unique_prefix c ->
 not_null c ->
 forall (m1 m2 : list bool) (a : A),
 find_val m1 c = Some a -> decode c (m1 ++ m2) = a :: decode c m2.
Proof using.
intros c H H0 m1 m2 a H1; unfold decode in |- *; apply decode_aux_correct;
 auto.
Qed.

(* Encoding and decoding return the same message if the code is prefix *)
Theorem correct_encoding :
 forall c : code,
 unique_prefix c ->
 not_null c ->
 forall m : list A, in_alphabet m c -> decode c (encode c m) = m.
Proof using.
intros c H1 H2 m; elim m; simpl in |- *; auto.
intros H3; unfold decode in |- *; simpl in |- *.
rewrite not_null_find_val; auto.
intros a l H H0; rewrite decode_correct with (a := a); auto.
apply f_equal2 with (f := cons (A:=A)); auto.
apply H; apply in_alphabet_inv with (1 := H0); auto.
case (H0 a); simpl in |- *; auto.
intros l1 Hl1.
apply find_val_correct2; auto.
case (H0 a); simpl in |- *; auto.
intros x1; case x1.
intros H3; case (H2 a); auto.
intros b l0 H3; cut (find_code a c = b :: l0).
intros H4; rewrite H4; apply find_code_correct1; auto.
apply find_code_correct2 with (2 := H3); auto.
case H1; auto.
Qed.

(* A unique prefix code in an alphabet of at least 2 elements is non-empty *)
Theorem frequency_not_null :
 forall m (c : code),
 1 < length (frequency_list eqA_dec m) ->
 unique_prefix c -> in_alphabet m c -> not_null c.
Proof using.
intros m c H H0 H1.
CaseEq (frequency_list eqA_dec m); auto.
intros H2; rewrite H2 in H; Contradict H; simpl in |- *; auto with arith.
intros p l; case p; case l; simpl in |- *; auto.
intros a n H2; rewrite H2 in H; Contradict H; simpl in |- *; auto with arith.
intros p0 l0; case p0; intros b nb a na H2.
apply unique_prefix_not_null with a b; auto.
intros H3; absurd (In (fst (a, na)) (fst (b, nb) :: map (fst (B:=_)) l0)).
cut (ulist (map (fst (B:=_)) (frequency_list eqA_dec m))).
rewrite H2; simpl in |- *; intros H4; inversion H4.
case H7; rewrite H3; auto with datatypes.
apply unique_key_ulist.
apply frequency_list_unique.
simpl in |- *; rewrite H3; auto with datatypes.
case (H1 a); auto.
apply frequency_list_in with eqA_dec na; rewrite H2; auto with datatypes.
intros l1 Hl1; apply in_alphabet_cons with l1; auto.
case (H1 b); auto.
apply frequency_list_in with eqA_dec nb; rewrite H2; auto with datatypes.
intros l2 Hl2; apply in_alphabet_cons with l2; auto.
Qed.

End Code.
Arguments encode [A].
Arguments decode [A].
Arguments find_code [A].
Arguments find_val [A].
Arguments in_alphabet [A].
Arguments unique_prefix [A].
Arguments not_null [A].
Hint Constructors is_prefix : core.
Hint Resolve is_prefix_refl : core.
Hint Resolve not_null_map : core.
Hint Resolve unique_prefix_nil : core.
Hint Resolve in_alphabet_nil in_alphabet_cons : core.
Hint Resolve not_null_app : core.


(*===========================================================================
    I/O actions
  ===========================================================================*)
Require Import ssreflect ssrbool eqtype tuple.
Require Import bitsrep bitsops bitsprops.

Definition Chan := BYTE.
Definition Data := BYTE.

Inductive Action :=
| Out (c:Chan) (d:Data)
| In (c:Chan) (d:Data).

Definition actionEq a1 a2 :=
  match a1, a2 with
  | Out c1 d1, Out c2 d2 => (c1 == c2) && (d1 == d2)
  | In c1 d1, In c2 d2 => (c1 == c2) && (d1 == d2)
  | _, _ => false
  end.

Lemma action_eqP: Equality.axiom actionEq.
Proof. case => c1 d1.  case => c2 d2. simpl.
+ case E1: (c1 == c2).
  case E2: (d1 == d2).
  simpl. rewrite (eqP E1) (eqP E2). by apply ReflectT.
  apply ReflectF => H.  inversion H.
  rewrite H2 in E2. by rewrite eq_refl in E2.
  apply ReflectF => H. inversion H.
  rewrite H1 in E1. by rewrite eq_refl in E1.
  by apply ReflectF => H.
  case => c2 d2.
  by apply ReflectF => H.
simpl.
case E1: (c1 == c2).
case E2: (d1 == d2).
  simpl. rewrite (eqP E1) (eqP E2). by apply ReflectT.
  apply ReflectF => H.  inversion H.
  rewrite H2 in E2. by rewrite eq_refl in E2.
  apply ReflectF => H. inversion H.
  rewrite H1 in E1. by rewrite eq_refl in E1.
Qed.

Canonical action_eqMixin := EqMixin action_eqP.
Canonical action_eqType := Eval hnf in EqType _ action_eqMixin.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frédéric Blanqui, 2014-02-25 (classes)
- Adam Koprowski and Hans Zantema, 2007-03

  This file contains a definition of weakly monotone algebra and
  extended monotone algebra and some results concerning them, based
  on:

References:
  J. Endrullis, J. Waldmann and H. Zantema,
  "Matrix Interpretations for Proving Termination of Term Rewriting",
  Proceedings of the 3rd International Joint Conference (IJCAR 2006), 2006.
*)

Require Import ATrs RelUtil SN ListUtil ARelation LogicUtil.
Require Export AWFMInterpretation.

(***********************************************************************)
(** * Module type specifying a weakly monotone algebra.                *)
(***********************************************************************)

  (**
     A weakly monotone algebra consist of:
     - interpretation [I]
     - [succ] and [succeq] relations
     along with the following conditions:
     - [IM]: [I] is monotone with respect to [succ]
     - [succ_wf]: [succ] is well-founded
     - [succ_succeq_compat]: compatibility between [succ] and [succeq]
     - [succ_dec] ([succeq_dec]): decidability of [succ] ([succeq])

     An extended monotone algebra additionaly requires that every
   operation is monotone with respect to [succ] but we demand
   it as an extra hypothesis in respective theorems (dealing with
   extended monotone algebras).
  *)

Section S.

  Variable Sig : Signature.

  Class MonotoneAlgebraType := {
  ma_int                : interpretation Sig;
  ma_succ               : relation (domain ma_int);
  ma_succeq             : relation (domain ma_int);
  ma_refl_succeq        : reflexive ma_succeq;
  ma_trans_succ         : transitive ma_succ;
  ma_trans_succeq       : transitive ma_succeq;
  ma_monotone_succeq    : monotone ma_int ma_succeq;
  ma_succ_wf            : WF ma_succ;
  ma_succ_succeq_compat : absorbs_left ma_succ ma_succeq;

  (** For certification of concrete examples we need some subrelations of
      [succ] and [succeq] that are decidable *)

  ma_succ'       : relation (term Sig);
  ma_succeq'     : relation (term Sig);
  ma_succ'_sub   : ma_succ' << IR ma_int ma_succ;
  ma_succeq'_sub : ma_succeq' << IR ma_int ma_succeq;
  ma_succ'_dec   : rel_dec ma_succ';
  ma_succeq'_dec : rel_dec ma_succeq' }.

End S.

(***********************************************************************)
(** * Functor with a theory of weakly monotone algebras                *)
(***********************************************************************)

Require Import ACompat.

Section MonotoneAlgebraResults.

  Variable Sig: Signature.

  Context {MA : MonotoneAlgebraType Sig}.

  Notation term      := (@term Sig).
  Notation rule      := (@rule Sig).
  Notation rules     := (@list rule).
  Notation I         := (ma_int Sig).
  Notation ma_succ   := (ma_succ Sig).
  Notation ma_succeq := (ma_succeq Sig).
  Notation IR_succ   := (IR I ma_succ).
  Notation IR_succeq := (IR I ma_succeq).

  Lemma absorb_succ_succeq : absorbs_left IR_succ IR_succeq.

  Proof.
    intros x z xz val.
    apply ma_succ_succeq_compat.
    destruct xz as [y [ge_xy gt_yz]].
    exists (term_int val y). split; auto.
  Qed.

  Lemma IR_rewrite_ordering : forall succ,
    monotone I succ -> rewrite_ordering (IR I succ).

  Proof.
    split.
    apply IR_substitution_closed.
    apply IR_context_closed.
    hyp.
  Qed.

  Lemma ma_succeq_rewrite_ordering : rewrite_ordering IR_succeq.

  Proof.
    apply IR_rewrite_ordering.
    exact (ma_monotone_succeq Sig).
  Qed.

  Definition part_succeq := rule_partition (ma_succeq'_dec Sig).
  Definition part_succ   := rule_partition (ma_succ'_dec Sig).

  Lemma partition_succ_compat : forall R,
    compat IR_succ (fst (partition part_succ R)).

  Proof.
    intros R l r lr.
    apply ma_succ'_sub.
    apply partition_by_rel_true with term (ma_succ'_dec Sig).
    apply rule_partition_left with R. hyp.
  Qed.

(**********************************************************)
(** relative termination criterion with monotone algebras *)

  Section RelativeTermination.

    Variable R E : rules.

    (* Termination in one go *)
    Lemma ma_compat_red_mod :
      monotone I ma_succ -> compat IR_succ R ->
                            compat IR_succeq E -> WF (red_mod E R).

    Proof.
      intros. apply WF_incl with IR_succ.
      apply compat_red_mod with IR_succeq; trivial.
      apply IR_rewrite_ordering; trivial.
      exact ma_succeq_rewrite_ordering.
      exact absorb_succ_succeq.
      apply IR_WF. exact (ma_succ_wf Sig).
    Qed.

  End RelativeTermination.

(**********************************************************************)
(** top termination (for DP setting) criterion with monotone algebras *)

  Section RelativeTopTermination.

    Variable R E : rules.

    Lemma ma_compat_hd_red_mod :
      compat IR_succ R -> compat IR_succeq E -> WF (hd_red_mod E R).

    Proof.
      intros. apply WF_incl with IR_succ.
      apply compat_hd_red_mod with IR_succeq; trivial.
      apply IR_substitution_closed.
      exact ma_succeq_rewrite_ordering.
      exact absorb_succ_succeq.
      apply IR_WF. exact (ma_succ_wf Sig).
    Qed.

  End RelativeTopTermination.

(**********************************************************)
(** results and tactics for proving relative termination
    of concrete examples. *)

  Section RelativeTerminationCriterion.

    Variable R E : rules.

    Lemma partition_succeq_compat : forall R,
      snd (partition part_succeq R) = nil ->
      compat IR_succeq (snd (partition part_succ R)).

    Proof.
      clear R. intros R Rpart l r lr.
      apply ma_succeq'_sub.
      apply partition_by_rel_true with term (ma_succeq'_dec Sig).
      apply rule_partition_left with R. fold part_succeq.
      ded (partition_complete part_succeq (mkRule l r) R).
      simpl in H. rewrite Rpart in H. destruct H.
      apply partition_inright with part_succ. hyp.
      hyp. destruct H.
    Qed.

    Lemma ma_relative_termination :
      let E_gt := partition part_succ E in
      let E_ge := partition part_succeq E in
      let R_gt := partition part_succ R in
      let R_ge := partition part_succeq R in
        monotone I ma_succ ->
        snd R_ge = nil ->
        snd E_ge = nil ->
        WF (red_mod (snd E_gt) (snd R_gt)) ->
        WF (red_mod E R).

    Proof.
      intros. unfold red_mod.
      set (Egt := fst E_gt) in *. set (Ege := snd E_gt) in *.
      set (Rgt := fst R_gt) in *. set (Rge := snd R_gt) in *.
      apply WF_incl with ((red Egt U red Ege)# @ (red Rgt U red Rge)).
      comp. apply clos_refl_trans_inclusion. apply rule_partition_complete.
      apply rule_partition_complete.
      apply wf_rel_mod. fold (red_mod Ege Rge). hyp.
      apply WF_incl with (red_mod (Rge ++ Ege) (Rgt ++ Egt)).
      unfold red_mod. comp.
      apply clos_refl_trans_inclusion. apply red_union_inv. apply red_union_inv.
      apply ma_compat_red_mod; trivial.
      apply compat_app.
      unfold Rgt, R_gt, part_succ. apply partition_succ_compat.
      unfold Egt, E_gt, part_succ. apply partition_succ_compat.
      apply compat_app.
      unfold Rge, R_gt. apply partition_succeq_compat. hyp.
      unfold Ege, E_gt. apply partition_succeq_compat. hyp.
    Qed.

  End RelativeTerminationCriterion.

(**********************************************************)
(** results and tactics for proving termination (as a special
    case of relative termination) of concrete examples. *)

  Section TerminationCriterion.

    Variable R : rules.

    Lemma ma_termination :
      let R_gt := partition part_succ R in
      let R_ge := partition part_succeq R in
        monotone I ma_succ ->
        snd R_ge = nil ->
        WF (red (snd R_gt)) ->
        WF (red R).

    Proof.
      intros. apply WF_incl with (red_mod nil R). apply red_incl_red_mod.
      apply ma_relative_termination. hyp. hyp. trivial.
      simpl. apply WF_incl with (red (snd (partition part_succ R))).
      apply red_mod_empty_incl_red. hyp.
    Qed.

  End TerminationCriterion.

(**********************************************************)
(** results and tactics for proving relative top termination
    of concrete examples. *)

  Section RelativeTopTerminationCriterion.

    Variable R E : rules.

    Lemma partition_succeq_compat_fst : forall R,
      compat IR_succeq (fst (partition part_succeq R)).

    Proof.
      clear R. intros R l r lr.
      apply ma_succeq'_sub. apply partition_by_rel_true with term (ma_succeq'_dec Sig).
      apply rule_partition_left with R. hyp.
    Qed.

    Lemma partition_succeq_compat_snd : forall R,
      snd (partition part_succeq R) = nil ->
      compat IR_succeq (snd (partition part_succ R)).

    Proof.
      clear R. intros R Rpart l r lr.
      apply ma_succeq'_sub. apply partition_by_rel_true with term (ma_succeq'_dec Sig).
      apply rule_partition_left with R. fold part_succeq.
      ded (partition_complete part_succeq (mkRule l r) R).
      simpl in H. rewrite Rpart in H. destruct H.
      apply partition_inright with part_succ. hyp.
      hyp. destruct H.
    Qed.

    Lemma ma_relative_top_termination :
      let E_ge := partition part_succeq E in
      let R_gt := partition part_succ R in
      let R_ge := partition part_succeq R in
        snd R_ge = nil ->
        snd E_ge = nil ->
        WF (hd_red_mod E (snd R_gt)) ->
        WF (hd_red_mod E R).

    Proof.
      intros. unfold hd_red_mod.
      set (Rgt := fst R_gt) in *. set (Rge := snd R_gt) in *.
      apply WF_incl with (red E # @ (hd_red Rgt U hd_red Rge)).
      comp. incl_trans (hd_red Rgt U hd_red Rge).
      apply hd_rule_partition_complete.
      apply wf_rel_mod_simpl. fold (red_mod E Rge). hyp.
      apply WF_incl with (hd_red_mod (Rge ++ E) Rgt).
      unfold hd_red_mod. comp.
      apply clos_refl_trans_inclusion.
      incl_trans (red Rge U red E). union. apply hd_red_incl_red.
      apply red_union_inv.
      apply ma_compat_hd_red_mod; trivial.
      unfold Rgt, R_gt, part_succ. apply partition_succ_compat.
      apply compat_app.
      unfold Rge, R_gt. apply partition_succeq_compat_snd. hyp.
      apply incl_compat with (fst E_ge ++ snd E_ge). unfold incl. intros.
      apply in_or_app. unfold E_ge. apply partition_complete. exact H2.
      rewrite H0. rewrite <- app_nil_end.
      unfold E_ge. apply partition_succeq_compat_fst.
    Qed.

  End RelativeTopTerminationCriterion.

(**********************************************************)
(** tactics *)

  Ltac partition R := norm (snd (partition part_succ R)).

  Ltac do_prove_termination prove_int_monotonicity lemma R :=
    apply lemma;
      match goal with
      | |- monotone _ _ => prove_int_monotonicity
      | |- WF _ => partition R
      | |- _ = _ => refl
      | _ => first
        [ solve [vm_compute; trivial]
	| idtac
        | fail 10 "Failed to deal with generated goal"
        ]
      end.

  Ltac prove_termination prove_int_monotone :=
    let prove := do_prove_termination prove_int_monotone in
    match goal with
    | |- WF (red ?R) =>
            prove ma_termination R
    | |- WF (red_mod _ ?R) =>
            prove ma_relative_termination R
    | |- WF (hd_red_mod _ ?R) =>
            prove ma_relative_top_termination R
    | |- WF (hd_red_Mod _ ?R) =>
	    eapply WF_incl;[try apply hd_red_mod_of_hd_red_Mod;
			try apply hd_red_mod_of_hd_red_Mod_int | idtac];
	    prove ma_relative_top_termination R
    | _ => fail 10 "Unsupported termination problem type"
   end.

End MonotoneAlgebraResults.


(** * System KT4 for classical logic encoded as an LL theory

This file encodes the inference rules of the system KT4. Since the
rules used are cut-coherent, the cut-elimination theorem applies for
this system.
 *)

Require Import MMLL.OL.CutCoherence.OLTactics.
Require Import MMLL.OL.CutCoherence.OLPosNeg.
Require Import MMLL.OL.CutCoherence.LNSkt4.KT4Bipoles.
Require Import MMLL.SL.FLLReasoning.

Require Import Coq.Init.Nat.
Require Import MMLL.Misc.Permutations.

Export ListNotations.
Export LLNotations.
Set Implicit Arguments.

Section KT4Adequacy.
Context {SI : Signature}.
Context {USI : UnbSignature}.
Context {USInoD : UnbNoDSignature}.

(** An inductive definition for KT4. This will be used to prove that
the LL encoding is sound and complete *)
Inductive KT4Seq : list uexp -> list uexp -> list uexp -> Prop :=
| KT4TRUE : forall D L L', KT4Seq D L ((t_cons TT)::L')
| KT4FALSE : forall D L L', KT4Seq D (t_cons FF :: L) L'
| KT4init : forall D L L' F,  KT4Seq D (F:: L) (F::L')

| KT4AndL1 : forall D L F G L', KT4Seq D (F :: L) L' -> KT4Seq D ( (t_bin AND F G) :: L) L'
| KT4AndL2 : forall D L F G L', KT4Seq D (G :: L) L' -> KT4Seq D ( (t_bin AND F G) :: L) L'
| KT4AndR : forall D L F G L', KT4Seq D L (F::L') -> KT4Seq D L (G::L') -> KT4Seq D L (t_bin AND F G :: L')

| KT4OrL : forall D L F G L',  KT4Seq D (F :: L) L' -> KT4Seq D (G :: L) L' -> KT4Seq D ( (t_bin OR F G) :: L) L'
| KT4OrR1 : forall D L F G L', KT4Seq D L (F::L') -> KT4Seq D L (t_bin OR F G :: L')
| KT4OrR2 : forall D L F G L', KT4Seq D L (G::L') -> KT4Seq D L (t_bin OR F G :: L')

 (* Explicit exchange *)
| KT4ExL : forall D L L' Delta, Permutation L L' -> KT4Seq D L Delta -> KT4Seq D L' Delta
| KT4ExR : forall D L L' Delta, Permutation L L' -> KT4Seq D Delta L -> KT4Seq D Delta L'
(* Explicit contraction *)
| KT4CtL : forall D L L' F, KT4Seq D (F :: F :: L)  L' -> KT4Seq D (F :: L)  L'
| KT4CtR : forall D L L' F, KT4Seq D L (F :: F :: L')   -> KT4Seq D L (F :: L')

| KT4WkL : forall D L L' F, KT4Seq D L L' -> KT4Seq D (F :: L)  L'
| KT4WkR : forall D L L' F, KT4Seq D L L' -> KT4Seq D L (F :: L')

| KT4Dec : forall D L L' F, In F D  -> KT4Seq D (F::L) L' ->  KT4Seq D L L'

| KT4BoxL : forall D L F L', KT4Seq (F::D) L L' ->  KT4Seq D (t_ucon BOX F :: L) L'

| KT4BoxR : forall D L F L', KT4SeqT D L [ ] [ ] [F] ->  KT4Seq D L (t_ucon BOX F :: L')
    with
      KT4SeqT : list uexp -> list uexp -> list uexp -> list uexp -> list uexp -> Prop :=
       | KT4_K: forall F A A' B D L R, Permutation (F::A') A -> KT4SeqT A' B D (F::L) R ->  KT4SeqT A B D L R
       | KT4_4: forall F A A' B D L R, Permutation (F::A') A -> KT4SeqT A' B (F::D) L R -> KT4SeqT A B D L R
       | KT4Release : forall A B D L R, KT4Seq D L R -> KT4SeqT A B D L R
.

 Notation "D ';' L '|--' R " := (KT4Seq D L R)  (at level 80).
 Notation "A ';' B '//' D ';' L '|--' R " := (KT4SeqT A B D L R)  (at level 80).

Hint Constructors KT4Seq : core .
Hint Constructors KT4SeqT : core .

Definition toBox D:= map (fun x => t_ucon BOX x) D.

  Theorem KT4SeqPerm1 A1  : forall A2 L R B D,
  Permutation A1 A2 -> KT4SeqT A2 B D L R -> KT4SeqT A1 B D L R .
  Proof with  CleanContext.
   intros *.
  intros Hp Hseq.
  generalize dependent A1.
  induction Hseq;intros;eauto using Permutation_in.
  symmetry in Hp.
   eapply KT4_K with (F:=F) (A':=A')...

  symmetry in Hp.
   eapply KT4_4 with (F:=F) (A':=A')...

  Qed.

   Theorem KT4SeqPerm2 B1  : forall B2 L R A D,
  Permutation B1 B2 -> KT4SeqT A B2 D L R -> KT4SeqT A B1 D L R .
  Proof with  CleanContext.
   intros *.
  intros Hp Hseq.
  generalize dependent B1.
  induction Hseq;intros;eauto using Permutation_in.
  Qed.

  Theorem KT4SeqPerm4 L1  : forall L2 R A B D,
  Permutation L1 L2 -> KT4SeqT A B D L2 R -> KT4SeqT A B D L1 R .
  Proof with  CleanContext.
   intros *.
  intros Hp Hseq.
  generalize dependent L1.
  induction Hseq;intros;eauto using Permutation_in.
  apply KT4Release...
  eapply KT4ExL.
  exact (symmetry Hp).
  auto.
  Qed.

  Theorem KT4SeqPerm5 R1  : forall L R2 A B D,
  Permutation R1 R2 -> KT4SeqT A B D L R2 -> KT4SeqT A B D L R1.
  Proof with  CleanContext.
   intros *.
  intros Hp Hseq.
  generalize dependent R1.
  induction Hseq;intros;eauto using Permutation_in.
  apply KT4Release...
  eapply KT4ExR.
  exact (symmetry Hp).
  auto.
  Qed.

 Theorem KT4SeqPerm D1  : forall D2 L R,
  Permutation D1 D2 -> KT4Seq D2 L R -> KT4Seq D1 L R .
  Proof with  CleanContext.
   intros *.
  intros Hp Hseq.
  generalize dependent D1.
  induction Hseq;intros;eauto using Permutation_in.

  eapply KT4Dec with (F:=F)...
  rewrite Hp...

  apply KT4BoxR.
  eapply KT4SeqPerm1 with (A2:=D)...
  Qed.

  Theorem KT4SeqPerm3 D1  : forall D2 L R A B,
  Permutation D1 D2 -> KT4SeqT A B D2 L R -> KT4SeqT A B D1 L R .
  Proof with  CleanContext.
   intros *.
  intros Hp Hseq.
  generalize dependent D1.
  induction Hseq;intros;eauto using Permutation_in.
  apply KT4Release...
  eapply KT4SeqPerm;eauto.
  Qed.

  Global Instance KT4T_morph :
  Proper ((@Permutation uexp) ==> (@Permutation uexp) ==>  (@Permutation uexp) ==> (@Permutation uexp) ==>  (@Permutation uexp)  ==> iff) (KT4SeqT).
Proof.
  unfold Proper; unfold respectful.
  intros.
  split;intros;subst.
  - symmetry in H.
    symmetry in H0.
    symmetry in H1.
    symmetry in H2.
    symmetry in H3.
    eapply KT4SeqPerm1;eauto.
    eapply KT4SeqPerm2;eauto.
    eapply KT4SeqPerm3;eauto.
    eapply KT4SeqPerm4;eauto.
    eapply KT4SeqPerm5;eauto.
  - eapply KT4SeqPerm1;eauto.
    eapply KT4SeqPerm2;eauto.
    eapply KT4SeqPerm3;eauto.
    eapply KT4SeqPerm4;eauto.
    eapply KT4SeqPerm5;eauto.
Qed.

  Global Instance KT4_morph :
  Proper ((@Permutation uexp) ==> (@Permutation uexp) ==> (@Permutation uexp) ==> iff) (KT4Seq).
Proof.
  unfold Proper; unfold respectful.
  intros.
  split;intros;subst.
  1: eapply KT4SeqPerm with (D2:=x);eauto.
  symmetry in H0.
  symmetry in H1.
  eapply KT4SeqPerm with (D2:=y);eauto.
Qed.

  Theorem KT4SeqTWkL : forall F L R A B D, KT4SeqT A B D L R -> KT4SeqT A B D (F::L) R .
  Proof with  CleanContext.
   intros.
   induction H;intros...
     rewrite <- H.
     eapply KT4_K with (F:=F0) (A':=A')...
     rewrite perm_swap...
     rewrite <- H.
     eapply KT4_4 with (F:=F0) (A':=A')...
  Qed.

  Theorem KT4SeqTWkR : forall F L R A B D, KT4SeqT A B D L R -> KT4SeqT A B D L (F::R) .
  Proof with  CleanContext.
   intros.
   induction H;intros...
     rewrite <- H.
     eapply KT4_K with (F:=F0) (A':=A')...
     rewrite <- H.
     eapply KT4_4 with (F:=F0) (A':=A')...
 Qed.

  Theorem KT4SeqTWkL1 : forall F L R A B D, KT4SeqT A B D L R -> KT4SeqT (F::A) B D L R .
  Proof with  CleanContext.
   intros.
   induction H;intros...
     rewrite <- H.
     rewrite perm_swap.
      eapply KT4_K with (F:=F0) (A':=F::A')...
     rewrite <- H.
     rewrite perm_swap.
      eapply KT4_4 with (F:=F0) (A':=F::A')...
 Qed.

   Theorem KT4SeqTWkL2 : forall F L R A B D, KT4SeqT A B D L R -> KT4SeqT A (F::B) D L R .
  Proof with  CleanContext.
   intros.
   induction H;intros...
     rewrite <- H.
      eapply KT4_K with (F:=F0) (A':=A')...
     rewrite <- H.
      eapply KT4_4 with (F:=F0) (A':=A')...
 Qed.

 Theorem KT4SeqWkL' D : forall F L R, KT4Seq D L R -> KT4Seq (F::D) L R .
  Proof with  CleanContext.
   intros.
   induction H;intros...
   rewrite <- H...
   rewrite <- H...
    apply InPermutation in H...
     rewrite H.
     rewrite perm_swap.
     eapply KT4Dec with (F:=F0)...
     rewrite perm_swap...
     rewrite <- H...
     apply KT4BoxL.
     rewrite perm_swap...
     apply KT4BoxR.
     apply KT4SeqTWkL1...
 Qed.

   Theorem KT4SeqTWkL3 : forall F L R A B D, KT4SeqT A B D L R -> KT4SeqT A B (F::D) L R .
  Proof with  CleanContext.
   intros.
   induction H;intros...
     rewrite <- H.
      eapply KT4_K with (F:=F0) (A':=A')...
     rewrite <- H.
      eapply KT4_4 with (F:=F0) (A':=A')...
      rewrite perm_swap...
    apply KT4Release...
    apply KT4SeqWkL'...
 Qed.

 Theorem ImpGenInv A B D L R:
    KT4SeqT A B D L R ->
    exists A1 A2 A3, Permutation A (A1++A2++A3) /\ KT4Seq (D++A1) (L++A2) R.
  Proof with  CleanContext.
   intros.
   induction H;intros...
   - eexists x.
     exists (F::x0).
     exists x1.
     split...
     rewrite <- H.
     rewrite H2...
     rewrite <- Permutation_middle...
   - eexists (F::x).
     exists x0.
     eexists x1.
     split...
     rewrite <- H.
     rewrite H2...
     rewrite <- Permutation_middle...
   - exists [].
     exists [].
     exists A.
     split...
 Qed.

 Theorem ImpGen A : forall D A1 A2 A3 B L R,
    Permutation A (A1++A2++A3) -> KT4Seq (D++A1) (L++A2) R ->
    KT4SeqT A B D L R.
  Proof with  CleanContext.
   induction A;intros...
   checkPermutationCases H.
   - rewrite H1 in H0.
     rewrite <- Permutation_middle in H0.
     rewrite app_comm_cons in H0.
     eapply IHA with (B:=B) (A3:=A3) in H0...
     apply KT4_4 with (F:=a) (A':=A)...
   - checkPermutationCases H1.
     + rewrite H1 in H0.
       rewrite <- Permutation_middle in H0.
       rewrite app_comm_cons in H0.
       eapply IHA with (B:=B) (A3:=A3) in H0...
       apply KT4_K with (F:=a) (A':=A)...
       rewrite <- H2.
       rewrite <- H3...
     + apply KT4SeqTWkL1...
       eapply IHA with (A1:=A1) (A2:=A2) (A3:=x0)...
       rewrite <- H2.
       rewrite <- H3...
 Qed.

Theorem KT4CtLGen C : forall D L L', KT4Seq D (C ++ C ++ L)  L' -> KT4Seq D (C ++ L) L'.
Proof with sauto.
  induction C;intros...
  rewrite <- app_comm_cons.
  apply KT4CtL.
  rewrite Permutation_cons_append.
  rewrite Permutation_cons_append.
  do 2 rewrite app_assoc_reverse.
  eapply IHC.
  assert(Hs: Permutation (C ++ C ++ L ++ [a] ++ [a]) ((a :: C) ++ (a :: C) ++ L)) by perm.
  rewrite Hs...
Qed.

Theorem KT4CtRGen D C : forall L L', KT4Seq D L (C ++ C ++ L') -> KT4Seq D L (C ++ L').
Proof with sauto.
  induction C;intros...
  rewrite <- app_comm_cons.
  apply KT4CtR.
  rewrite Permutation_cons_append.
  rewrite Permutation_cons_append.
  do 2 rewrite app_assoc_reverse.
  eapply IHC.
  assert(Hs: Permutation (C ++ C ++ L' ++ [a] ++ [a]) ((a :: C) ++ (a :: C) ++ L')) by perm.
  rewrite Hs...
Qed.

Theorem KT4WkLGen C : forall D L L', KT4Seq D L  L' -> KT4Seq D (C ++ L) L'.
Proof with sauto.
  induction C;intros...
  rewrite <- app_comm_cons.
  apply KT4WkL...
Qed.

Theorem KT4WkRGen C : forall D L L', KT4Seq D L  L' -> KT4Seq D L (C++L').
Proof with sauto.
  induction C;intros...
  rewrite <- app_comm_cons.
  apply KT4WkR...
Qed.

Theorem KT4WkLGen' C : forall D L L', KT4Seq D L  L' -> KT4Seq (C++D) L L'.
Proof with sauto.
  induction C;intros...
  rewrite <- app_comm_cons.
  apply KT4SeqWkL'...
Qed.

Lemma storeAll X : forall D L th, IsPositiveAtomFormulaL (Arrow2LL X) ->
  seq th L ((Arrow2LL X)++D) (UP []) -> seq th L D X.
Proof with sauto;SLSolve;OLSolve.
  destruct X;simpl;intros...
  * revert dependent L.
    revert D.
    revert dependent l.
    intro.
    induction l;intros...
    inversion H...
    inversion H3...
    LLStore.
    apply IHl... LLExact H0.
    LLStore.
    apply IHl... LLExact H0.
  * inversion H...
    inversion H3...
 Qed.

Lemma storeAllN X : forall n D L th, IsPositiveAtomFormulaL (Arrow2LL X) ->
  seqN th n L ((Arrow2LL X)++D) (UP []) -> exists m, m <= S n +length (Arrow2LL X) /\
  seqN th m L D X.
Proof with sauto;SLSolve;OLSolve.
  destruct X;simpl;intros...
  * revert dependent L.
    revert D.
    revert dependent l.
    revert dependent n.
    intro.
    induction l;intros...
    exists n...
    inversion H...
    inversion H3...
    assert(exists m : nat,
        m <= S n + length l /\ seqN th m L (d| A |::D) (UP l)).
    apply IHl... LLExact H0.
    destruct H2...
    eexists (S x)...
    simpl...
     assert(exists m : nat,
        m <= S n + length l /\ seqN th m L (u| A |::D) (UP l)).
    apply IHl... LLExact H0.
    destruct H2...
    eexists (S x)...
    simpl...
  * inversion H...
    inversion H3...
    eexists (S (S n))...
    eexists (S (S n))...
 Qed.

Lemma storeAllInv X : forall D L th, IsPositiveAtomFormulaL (Arrow2LL X) ->
  seq th L D X -> seq th L ((Arrow2LL X)++D) (UP []).
Proof with sauto;SLSolve;OLSolve.
  destruct X;simpl;intros...
  * revert dependent L.
    revert D.
    revert dependent l.
    intro.
    induction l;intros...
    rewrite Permutation_cons_append.
    rewrite app_assoc_reverse.
    apply IHl...
    inversion H...
    inversion H0;inversion H3...
  * inversion H...
    inversion H0;inversion H3...
    all: inversion H7...
 Qed.

Lemma adequacy_aux a j F L D X:
mt a = true ->
mt j = true -> m4 j = true ->
IsPositiveAtomFormulaL X ->
IsPositiveAtomFormulaL D ->
IsPositiveAtomFormulaL (second L) ->
 isOLFormula (t_ucon BOX F) ->
           seq (KT4 j) ((j, d|F |)::L) D (UP X) <->
           seq (KT4 j) ((a,d| t_ucon BOX F|)::L) D (UP X).
Proof with CleanContext;SLSolve;OLSolve.
  intros aT jT jF isFX. split;intros.
 *
   apply storeAll...
   apply storeAllInv in H2...
   TFocus (UnBipole (BOX_BODY j) Left F).
   apply ooth_boxC.
   constructor... inversion H3.
   LLTensor (@nil oo) (X++D)...
   simpl... solveLL.
   simpl. LLRelease. LLStoreC. LLSwap.
   apply weakening...
   solveSignature1.
 *
   apply storeAll...
   apply storeAllInv in H2...
   apply seqtoSeqN in H2...
   remember (X++D) as Y.
   assert(IsPositiveAtomFormulaL Y).
   rewrite HeqY. OLSolve.
   simpl in *. rewrite <- HeqY.
   rewrite <- HeqY in H2.
   clear HeqY.
   clear H isFX.
   rename H3 into H.
   revert dependent Y.
   revert dependent L.
   revert dependent F.
   revert dependent j.
   induction x using strongind;intros...
   - inversion H2...
   - inversion H2...
     -- apply RemoveNotPos1 in H6;sauto...
         inversion H4; inversion H5...
     -- apply InUNotPos in H8;sauto...
     -- apply RemoveNotPos2 in H8;sauto...
     -- inversion H5...
   + inversion H4...
     ++
        apply BipoleReasoning in H7...
        +++
        TFocus (CteBipole TT_BODY Right).
        LLTensor [u| t_cons TT | ] x1.
        simpl...
        +++
        checkPermutationCases  H13.
        TFocus (CteBipole TT_BODY Right).
        LLTensor (@nil oo) Y.
        apply weakening... solveSignature1.
        solveLL...
        simpl...
     ++
        apply BipoleReasoning in H7...
        +++
         inversion H11...
         +++
         inversion H11...
    ++
        apply BipoleReasoning in H7...
        +++
         inversion H11...
         +++
         inversion H11...
    ++
        apply BipoleReasoning in H7...
        +++
        TFocus (CteBipole FF_BODY Left).
        LLTensor [d| t_cons FF | ] x1.
        simpl...
        +++
        checkPermutationCases  H13.
        TFocus (CteBipole FF_BODY Left).
        LLTensor (@nil oo) Y.
        apply weakening... solveSignature1.
        solveLL...
        simpl...
   + inversion H4...
     ++
        apply BipoleReasoning in H7...
        +++
        TFocus (BinBipole AND_BODY Right F1 G).
        LLTensor [u| t_bin AND F1 G | ] x1.
        apply FocusingWith in H11...
        simpl.
        LLRelease. LLWith.
        1-2: LLStore.
        apply H in H11...
        apply H in H13...
        +++
        checkPermutationCases H13.
        TFocus (BinBipole AND_BODY Right F1 G).
        LLTensor (@nil oo) Y.
        apply weakening... solveSignature1.
        solveLL...
        apply FocusingWith in H11...
        simpl.
        LLRelease. LLWith.
        1-2: LLStore.
        apply H in H14...
        apply H in H15...
     ++
        apply BipoleReasoning in H7...
        +++
        TFocus (BinBipole AND_BODY Left F1 G).
        LLTensor [d| t_bin AND F1 G | ] x1.
        apply FocusingPlus in H11...
        1: simpl; LLPlusL; LLRelease; LLStore.
        2: simpl; LLPlusR; LLRelease; LLStore.
        1-2: apply H in H10...
        +++
        checkPermutationCases H13.
        TFocus (BinBipole AND_BODY Left F1 G).
        LLTensor (@nil oo) Y.
        apply weakening... solveSignature1.
        solveLL...
        apply FocusingPlus in H11...
        simpl.
        1: simpl; LLPlusL; LLRelease; LLStore.
        2: simpl; LLPlusR; LLRelease; LLStore.
        1-2: apply H in H13...
     ++
        apply BipoleReasoning in H7...
        +++
        TFocus (BinBipole OR_BODY Right F1 G).
        LLTensor [u| t_bin OR F1 G | ] x1.
        apply FocusingPlus in H11...
        1: simpl; LLPlusL; LLRelease; LLStore.
        2: simpl; LLPlusR; LLRelease; LLStore.
        1-2: apply H in H10...
        +++
        checkPermutationCases H13.
        TFocus (BinBipole OR_BODY Right F1 G).
        LLTensor (@nil oo) Y.
        apply weakening... solveSignature1.
        solveLL...
        apply FocusingPlus in H11...
        simpl.
        1: simpl; LLPlusL; LLRelease; LLStore.
        2: simpl; LLPlusR; LLRelease; LLStore.
        1-2: apply H in H13...
     ++
        apply BipoleReasoning in H7...
        +++
        TFocus (BinBipole OR_BODY Left F1 G).
        LLTensor [d| t_bin OR F1 G | ] x1.
        apply FocusingWith in H11...
        simpl.
        LLRelease. LLWith.
        1-2: LLStore.
        apply H in H11...
        apply H in H13...
        +++
        checkPermutationCases H13.
        TFocus (BinBipole OR_BODY Left F1 G).
        LLTensor (@nil oo) Y.
        apply weakening... solveSignature1.
        solveLL...
        apply FocusingWith in H11...
        simpl.
        LLRelease. LLWith.
        1-2: LLStore.
        apply H in H14...
        apply H in H15...
   + apply FocusingInitRuleU in H7...
        ++
        TFocus (RINIT OO).
        LLTensor [u| OO |] [d| OO |].
        ++
        checkPermutationCases H10.
        TFocus (UnBipole (BOX_BODY j) Right F).
        do 2 constructor;auto.
        inversion H1.
        LLTensor [u| t_ucon BOX F |] (@nil oo).
        simpl. createWorld. solveSignature1.
        apply GenK4RelUT' with (C4:=[(j, d| F |)]) (CK:=[]) (CN:=L)...
        solveSignature1.
        constructor...
        reflexivity.
        simpl... LLStore.
        TFocus (RINIT F).
        apply ooth_initC...
        inversion H1.
        LLTensor [u| F |] (@nil oo).
        solveLL.
        TFocus (RINIT OO).
        LLTensor [u| OO |] (@nil oo).
        apply weakening... solveSignature1.
        solveLL...
      ++
        checkPermutationCases H10.
        TFocus (RINIT OO).
        LLTensor (@nil oo) [d| OO |] .
        apply weakening... solveSignature1.
        solveLL...
      ++
        checkPermutationCases H10.
        checkPermutationCases H8.
       TFocus (UnBipole (BOX_BODY j) Right F).
        do 2 constructor;auto.
        inversion H1.
        LLTensor.
        apply weakening... solveSignature1.
        solveLL...
        simpl. createWorld. solveSignature1.
        apply GenK4RelUT' with (C4:=[(j, d| F |)]) (CK:=[]) (CN:=L)...
        solveSignature1.
        constructor...
        reflexivity.
        simpl... LLStore.
        TFocus (RINIT F).
        apply ooth_initC...
        inversion H1.
        LLTensor [u| F |] (@nil oo).
        solveLL.
        TFocus (RINIT OO).
        LLTensor.
        all: apply weakening...
        1-3: solveSignature1.
        all: solveLL...
   + inversion H4...
     ++
        apply BipoleReasoning in H7...
        +++
        TFocus  (UnBipole (BOX_BODY j) Right F1).
        LLTensor [u| t_ucon BOX F1 |] x1.
        apply FocusingBang' in H11...
        checkPermutationCases H11.
        1-2: simpl; createWorld; solveSignature1.
        LLrewrite H8 in H17.
        apply H in H17...
        apply GenK4RelUT' with (C4:=[(j, d| F |)]++x0) (CK:=[]) (CN:=x3)...
        solveSignature1.
        rewrite H8 in H13...
        inversion H13...
        constructor...

        rewrite H8 in H9...
        inversion H9...
        constructor...

         rewrite H8 in H14...
        inversion H14...
        constructor...

        reflexivity.
        rewrite <- H11...
        simpl...
        OLSolve.
        symmetry in H11.
        srewrite  H11 in H0.
        OLSolve.
        rewrite map_app in H0.
        OLSolve.
        apply GenK4RelUT' with (C4:=x2) (CK:=[]) (CN:=(j, d| F |)::x0)...
        solveSignature1.
        rewrite <- H11...
        simpl...
        LLStore.
        HProof.
        +++
        checkPermutationCases H13.
        TFocus  (UnBipole (BOX_BODY j) Right F1).
        LLTensor (@nil oo) Y.
        apply weakening... solveSignature1.
        solveLL...

        apply FocusingBang' in H11...
        checkPermutationCases H14.
        1-2: simpl; createWorld; solveSignature1.
        LLrewrite H11 in H19.
        apply H in H19...
        apply GenK4RelUT' with (C4:=[(j, d| F |)]++x0) (CK:=[]) (CN:=x5)...
        solveSignature1.
        rewrite H11 in H15...
        inversion H15...
        constructor...

        rewrite H11 in H13...
        inversion H13...
        constructor...

        rewrite H11 in H16...
        inversion H16...
        constructor...
        reflexivity.
        rewrite <- H14...
        simpl...
        OLSolve.
        symmetry in H14.
        srewrite  H14 in H0.
        OLSolve.
        rewrite map_app in H0.
        OLSolve.
        apply GenK4RelUT' with (C4:=x4) (CK:=[]) (CN:=(j, d| F |)::x0)...
        solveSignature1.
        rewrite <- H14...
        simpl...
        LLStore.
        HProof.
     ++
        apply BipoleReasoning in H7...
        +++
        simpl in H11.
        TFocus (UnBipole (BOX_BODY j) Left F1).
        simpl in H12.
        LLTensor [d| t_ucon BOX F1 | ] x1.
        apply FocusingQuest in H11...
        simpl.
        LLRelease. LLStoreC.
        LLSwapC H9.
        apply H in H9...
        LLExact H9.
        +++
        checkPermutationCases H13.

        2:{
        TFocus (UnBipole (BOX_BODY j) Left F1).
        LLTensor (@nil oo) Y.
        apply weakening... solveSignature1.
        solveLL...
        apply FocusingQuest in H11...
        simpl.
        LLRelease. LLStoreC.
        LLSwapC H13.
        apply H in H13...
        LLExact H13. }

         apply FocusingQuest in H11...
         LLSwapC H8.
         apply H in H8...
         apply contraction in H8...
         solveSignature1.
      + apply BipoleReasoning in H7...
        ++
        TFocus(POS OO loc).
        LLTensor [d| OO |] x1.
        LLRelease. LLStoreC.
        apply FocusingQuest in H10...
        LLSwapC H9.
        apply H in H9...
        LLExact H9.
      ++
         checkPermutationCases H12.

         2:{
         TFocus(POS OO loc).
         LLTensor (@nil oo) Y.
         apply weakening... solveSignature1.
         solveLL.
         LLRelease. LLStoreC.
         apply FocusingQuest in H10...
         LLSwapC H12.
         apply H in H12...
         LLExact H12. }

         apply FocusingQuest in H10...
         apply ContractionLoc in H8...
         apply H in H8...
         solveSignature1.
   + apply BipoleReasoning in H7...
        ++
        TFocus(NEG OO loc).
        LLTensor [u| OO |] x1.
        LLRelease. LLStoreC.
        apply FocusingQuest in H10...
        LLSwapC H9.
        apply H in H9...
        LLExact H9.
      ++
         checkPermutationCases H12.
         TFocus(NEG OO loc).
         LLTensor (@nil oo) Y.
         apply weakening... solveSignature1.
         solveLL.
         LLRelease. LLStoreC.
         apply FocusingQuest in H10...
         LLSwapC H12.
         apply H in H12...
         LLExact H12.
 -- solveSignature1.
 Qed.

Lemma adequacy_aux_instance_loc j F L D X:
mt j = true -> m4 j = true ->
IsPositiveAtomFormulaL X ->
IsPositiveAtomFormulaL D ->
IsPositiveAtomFormulaL (second L) ->
 isOLFormula (t_ucon BOX F) ->
           seq (KT4 j) ((j, d|F |)::L) D (UP X) <->
           seq (KT4 j) ((loc,d| t_ucon BOX F|)::L) D (UP X).
Proof with CleanContext;SLSolve;OLSolve.
  intros jT jF. split;intros.
  - apply adequacy_aux... solveSignature1.
  - apply adequacy_aux in H3... solveSignature1.
Qed.

Lemma adequacy_auxK4_instance_loc j F L D :
mt j = true -> m4 j = true ->
IsPositiveAtomFormulaL (second L) ->
IsPositiveAtomFormulaL (second D) ->
 isOLFormula F ->
   tri_bangK4' (KT4 j) D j ((j, d|F |)::L) [] (UP []) <->
   tri_bangK4' (KT4 j) D j ((loc,d| t_ucon BOX F|)::L) [] (UP []).
Proof with CleanContext;SLSolve;OLSolve.
   intros jT jF. split;intros.
 * apply InvSubExpPhaseUTK4' in H2...
   apply GenK4Rel' with (C4:= x)
                        (CK:=[])
                        (CN:=x0)...
   solveSignature1.
   simpl...
  apply adequacy_aux_instance_loc;auto.
  rewrite secondApp.
  rewrite PlusT_fixpoint'...
  srewrite H3 in H0.
  rewrite map_app in H0...
  rewrite PlusT_fixpoint'...
  solveSignature1.
  solveSignature1.
 * apply InvSubExpPhaseUTK4' in H2...
   apply GenK4Rel' with (C4:= x)
                        (CK:=[])
                        (CN:=x0)...
   solveSignature1.
   simpl...
  apply adequacy_aux_instance_loc;auto.
  rewrite secondApp.
  rewrite PlusT_fixpoint'...
  srewrite H3 in H0.
  rewrite map_app in H0...
  rewrite PlusT_fixpoint'...
  solveSignature1.
  solveSignature1.
 Qed.

Lemma adequacy_auxK4 a j F L D :
mt j = true -> m4 j = true ->
mt a = true -> m4 a = true ->
IsPositiveAtomFormulaL (second L) ->
IsPositiveAtomFormulaL (second D) ->
 isOLFormula F ->
   tri_bangK4' (KT4 j) D j ((j, d|F |)::L) [] (UP []) <->
   tri_bangK4' (KT4 j) D j ((a,d| t_ucon BOX F|)::L) [] (UP []).
Proof with CleanContext;SLSolve;OLSolve.
   intros aT aF jT jF. split;intros.
 * apply InvSubExpPhaseUTK4' in H2...
   apply GenK4Rel' with (C4:= x)
                        (CK:=[])
                        (CN:=x0)...
  solveSignature1.
  simpl...
  apply adequacy_aux;auto.
  rewrite secondApp.
  rewrite PlusT_fixpoint'.
  OLSolve.
  srewrite H3 in H0.
  rewrite map_app in H0...
  auto.
  rewrite PlusT_fixpoint'...
  solveSignature1.
  solveSignature1.
 *  apply InvSubExpPhaseUTK4' in H2;solveSignature1...

  apply GenK4Rel' with (C4:= x)
                        (CK:=[])
                        (CN:=x0);sauto;solveSignature1...
  simpl...
  rewrite PlusT_fixpoint'.
 rewrite <- app_comm_cons in H10.
  apply adequacy_aux in H10;sauto.
  rewrite secondApp.
  OLSolve.
  srewrite H3 in H0.
  rewrite map_app in H0...
  auto.
 Qed.

Lemma adequacy_auxK4' a j F L D Y X:
mt j = true -> m4 j = true ->
mt a = true -> m4 a = true ->
lt j a ->
IsPositiveAtomFormulaL X ->
IsPositiveAtomFormulaL (second L) ->
IsPositiveAtomFormulaL (second D) ->
IsPositiveAtomFormulaL Y ->
 isOLFormula F ->
   tri_bangK4' (KT4 j) ((j, d|F |)::D) j L Y (UP X) <->
   tri_bangK4' (KT4 j) ((a,d| t_ucon BOX F|)::D) j L Y (UP X).
Proof with CleanContext;SLSolve;OLSolve.
   intros aT aF jT jF ltaj. split;intros.
 * apply InvSubExpPhaseUTK4' in H4;solveSignature1...
   checkPermutationCases H5.
   -
   assert(SetK4 x1).
   rewrite H5 in H7.
   solveSE.
  assert(LtX j x1).
  rewrite H5 in H6.
  solveLT.
  assert(SetT x1).
   rewrite H5 in H10.
   solveSE.

   copyK4 a (d| t_ucon BOX F |) D...
   rewrite plustpropT...
   apply GenK4RelUT' with (C4:= x1)
                        (CK:=[])
                        (CN:=x0);solveSignature1...
  simpl...
  rewrite <- Permutation_cons_append.
  rewrite <- app_comm_cons.
  apply adequacy_aux;auto.
  rewrite secondApp.
  OLSolve.

  symmetry in H11.
  srewrite H11 in H1.
  rewrite map_app in H1...
  srewrite H5 in H12.
  LLExact H12.
  -
   rewrite Permutation_cons_append.
   apply weakeness_mutual'...
   solveSignature1.
   apply GenK4RelUT' with (C4:= x)
                        (CK:=[])
                        (CN:=x1);solveSignature1...
   simpl...
 * apply InvSubExpPhaseUTK4' in H4;solveSignature1...
   checkPermutationCases H5.
   -
   assert(SetK4 x1).
   rewrite H5 in H7.
   solveSE.
  assert(LtX j x1).
  rewrite H5 in H6.
  solveLT.
  assert(SetT x1).
   rewrite H5 in H10.
   solveSE.

   copyK4 j (d|  F |) D...
   reflexivity.
   rewrite plustpropT...
   apply GenK4RelUT' with (C4:= x1)
                        (CK:=[])
                        (CN:=x0);solveSignature1...
  simpl...
  srewrite H5 in H12.
  LLPermH H12 ((a, d| t_ucon BOX F |) :: L++x1).
  apply adequacy_aux in H12;auto.
  LLExact H12.
  rewrite secondApp.
  OLSolve.

  symmetry in H11.
  srewrite H11 in H1.
  rewrite map_app in H1...
  -
   rewrite Permutation_cons_append.
   apply weakeness_mutual'...
   solveSignature1.
   apply GenK4RelUT' with (C4:= x)
                        (CK:=[])
                        (CN:=x1);solveSignature1...
   simpl...
 Qed.

  Theorem  SoundenessKT4T j A B D R L
     (Mj: mt j = true) (Fj: m4 j = true)
     (isFL: isOLFormulaL L) (isFR: isOLFormulaL R)
     (isFD: isOLFormulaL D) (isFA: isOLFormulaL A) :
     forall  (Hyp: KT4SeqT A B D L R),
     tri_bangK4' (KT4 j) (CEncode j (LEncode A)) j
     (CEncode j (LEncode D) ++ (CEncode loc (LEncode L) ++ CEncode loc (REncode R))) [] (UP []) with
      SoundenessKT4 j D L R
     (Mj: mt j = true) (Fj: m4 j = true)
     (isFD: isOLFormulaL D) (isFL: isOLFormulaL L) (isFR: isOLFormulaL R)  :
     forall (Hyp: KT4Seq D L R),
     seq (KT4 j)
     (CEncode j (LEncode D) ++ (CEncode loc (LEncode L) ++ CEncode loc (REncode R))) [] (UP []).
Proof with CleanContext;SLSolve;OLSolve.
  * clear SoundenessKT4T.
  intros.
  induction Hyp.
  +
    symmetry in H.
    srewrite H...
    apply IHHyp in isFD...
    clear IHHyp.
    copyK4 j (d| F |) (CEncode j (LEncode A')).
    reflexivity.
    rewrite plustpropT...
    rewrite Permutation_app_comm.
    apply ContractionLocK4'...
    solveSignature1.
    eapply exchangeCCKK4.
    2:{ exact isFD. }
    simpl...
    rewrite H in isFA.
    OLSolve.
  +
    symmetry in H.
    srewrite H...
    apply IHHyp in isFR...
    clear IHHyp.
    copyK4 j (d| F |) (CEncode j (LEncode A')).
    reflexivity.
    rewrite plustpropT...
    eapply exchangeCCKK4.
    2:{ exact isFR. }
    simpl...
    rewrite H in isFA.
    OLSolve.
  + eapply SoundenessKT4 with (j:=j)  in H...
      finishExp...
  * clear SoundenessKT4.
    intros.
    induction Hyp.
     + (* True on the right *)
    TFocus (CteBipole TT_BODY Right).
    constructor;constructor;auto.
    inversion H.
    LLTensor.
    simpl...
    rewrite  Permutation_cons_append...
    rewrite !app_assoc...
    apply weakeningGen...
    init2 loc (@nil TypedFormula).
    solveSignature1.
    simpl...
   + (* false on the left *)
    TFocus (CteBipole FF_BODY Left).
    constructor;constructor;auto.
    inversion H.
    LLTensor.
    simpl...
    rewrite  Permutation_cons_append...
    rewrite !app_assoc...
    apply weakeningGen...
    init2 loc (@nil TypedFormula).
    solveSignature1.
    simpl...
   +
    TFocus (RINIT F)...
    apply ooth_initC...
    inversion H.
    LLTensor.
    simpl...
    rewrite  Permutation_cons_append...
    rewrite !app_assoc_reverse...
    apply weakeningGen...
    apply weakeningGen...
    apply weakeningGen_rev...
    init2 loc (CEncode loc (REncode L')).
    solveSignature1.
    simpl...
    rewrite  Permutation_cons_append...
    rewrite !app_assoc...
    apply weakeningGen...
    init2 loc (@nil TypedFormula).
    solveSignature1.
   +
    TFocus (BinBipole AND_BODY Left F G)...
    apply ooth_rulesC...
    constructor...
    inversion H.
    LLTensor.
    simpl...
    rewrite Permutation_cons_append...
    rewrite !app_assoc.
    apply weakeningGen...
    init2 loc (@nil TypedFormula).
    solveSignature1.

    LLPlusL. LLRelease. LLStore.
    simpl...
    rewrite Permutation_cons_append...
    rewrite !app_assoc.
    apply weakeningGen_rev...
    apply PosF with (a:=loc)...
    intro;intros...
    apply IHHyp in isFR as Hs...
    simpl in Hs.
    simpl.
    LLExact Hs.
   +
    TFocus (BinBipole AND_BODY Left F G)...
    apply ooth_rulesC...
    constructor...
    inversion H.
    LLTensor.
    simpl...
    rewrite Permutation_cons_append...
    rewrite !app_assoc.
    apply weakeningGen...
    init2 loc (@nil TypedFormula).
    solveSignature1.

    LLPlusR. LLRelease. LLStore.
    simpl...
    rewrite Permutation_cons_append...
    rewrite !app_assoc.
    apply weakeningGen_rev...
    apply PosF with (a:=loc)...
    intro;intros...
    apply IHHyp in isFR as Hs...
    simpl in Hs.
    simpl.
    LLExact Hs.
    +
    TFocus (BinBipole AND_BODY Right F G)...
    apply ooth_rulesC...
    constructor...
    inversion H.
    LLTensor...
    simpl...
    rewrite Permutation_cons_append...
    rewrite !app_assoc.
    apply weakeningGen...
    init2 loc (@nil TypedFormula).
    solveSignature1.

    simpl. LLRelease. LLWith; LLStore.
    1-2: simpl; rewrite Permutation_cons_append...
    1-2: rewrite !app_assoc.
    1-2: apply weakeningGen_rev...

    1-2: apply NegF with (a:=loc)...
    1,3: intro; intros...
    apply IHHyp1 in isFL...
    simpl in isFL...
    simpl...
    LLExact isFL.
    apply IHHyp2 in isFL...
    simpl in isFL...
    simpl...
    LLExact isFL.
    +
    TFocus (BinBipole OR_BODY Left F G)...
    apply ooth_rulesC...
    constructor...
    inversion H.
    LLTensor...
    simpl...
    rewrite Permutation_cons_append...
    rewrite !app_assoc.
    apply weakeningGen...
    init2 loc (@nil TypedFormula).
    solveSignature1.

    simpl. LLRelease. LLWith; LLStore.
    1-2: simpl; rewrite Permutation_cons_append...
    1-2: rewrite !app_assoc.
    1-2: apply weakeningGen_rev...

    1-2: apply PosF with (a:=loc)...
    1,3: intro; intros...
    apply IHHyp1 in isFD...
    simpl in isFD...
    simpl...
    LLExact isFD.
    apply IHHyp2 in isFR...
    simpl in isFR...
    simpl...
    LLExact isFR.
   +
    TFocus (BinBipole OR_BODY Right F G)...
    apply ooth_rulesC...
    constructor...
    inversion H.
    LLTensor.
    simpl...
    rewrite Permutation_cons_append...
    rewrite !app_assoc.
    apply weakeningGen...
    init2 loc (@nil TypedFormula).
    solveSignature1.

    LLPlusL. LLRelease. LLStore.
    simpl...
    rewrite Permutation_cons_append...
    rewrite !app_assoc.
    apply weakeningGen_rev...
    apply NegF with (a:=loc)...
    intro;intros...
    apply IHHyp in isFD...
    simpl in isFD...
    simpl...
    LLExact isFD...
   +
    TFocus (BinBipole OR_BODY Right F G)...
    apply ooth_rulesC...
    constructor...
    inversion H.
    LLTensor.
    simpl...
    rewrite Permutation_cons_append...
    rewrite !app_assoc.
    apply weakeningGen...
    init2 loc (@nil TypedFormula).
    solveSignature1.

    LLPlusR. LLRelease. LLStore.
    simpl...
    rewrite Permutation_cons_append...
    rewrite !app_assoc.
    apply weakeningGen_rev...
    apply NegF with (a:=loc)...
    intro;intros...
    apply IHHyp in isFD...
    simpl in isFD...
    simpl...
    LLExact isFD...
   + (* exchange *)
    srewrite (symmetry H)...
    apply IHHyp...
   + (* exchange *)
    srewrite (symmetry H)...
    apply IHHyp...
  + (* contraction *)
    eapply @contraction with (F:=(loc, d| F |)); solveSignature1...
    apply IHHyp in isFR...
    simpl in isFR...
    simpl...
    LLExact isFR.
    OLSolve.
    simpl...
  + (* contraction *)
    eapply @contraction with (F:=(loc, u| F |));solveSignature1...
    apply IHHyp in isFL...
    simpl in isFL...
    simpl...
    LLExact isFL.
    OLSolve.
    apply in_or_app.
    right.
    simpl...
  + (* weakening *)
    simpl. rewrite Permutation_midle.
    apply weakening;solveSignature1...
    apply IHHyp...
   + (* weakening *)
    simpl. rewrite Permutation_cons_append.
    rewrite !app_assoc.
    apply weakeningGen_rev;solveSignature1...
    rewrite !app_assoc_reverse.
    apply IHHyp...
  + (* decide T *)
    apply InPermutation in H...
    srewrite H...
    simpl...
    rewrite Permutation_cons_append...
    rewrite !app_assoc.
    rewrite Permutation_app_comm.
    apply ContractionL'...

    rewrite H in isFD.
    assert(isOLFormulaL (F :: L))...
    apply IHHyp in H0...
    simpl in H0...
    simpl...
    eapply exchangeCC'.
    2:{ exact H0. }
    simpl...
    srewrite H...
  + (* box left *)
    assert(isOLFormulaL (F :: D))...
    apply IHHyp in H...
    simpl...
    rewrite <- Permutation_middle.
    apply adequacy_aux_instance_loc;auto.
    rewrite !secondApp.
    rewrite !secCEncode...
    OLSolve. inversion isFL... OLSolve.
    OLSolve. OLSolve.
  + (* box right *)
    TFocus (UnBipole (BOX_BODY j) Right F).
    apply ooth_boxC.
    constructor...
    inversion H0.
    LLTensor...
    simpl...
    rewrite Permutation_cons_append.
    apply weakeningGen...
    apply weakeningGen...
    apply weakeningGen...
    init2 loc (@nil TypedFormula).
    solveSignature1.

    simpl.
    apply SoundenessKT4T with (j:=j) in H...
    apply InvSubExpPhaseUTK4' in H;solveSignature1...
    simpl in H7...

   simpl.
   rewrite Permutation_cons_append.

   createWorld. solveSignature1.
   rewrite !app_assoc.
   apply weakeness_mutual'...
   solveSignature1.
   apply destructCEncode in H0...
  (*  apply destructLEncode in H7...
   rewrite PlusT_fixpoint' in H5...
   *)
   apply CEncodePerm with (i:=j) in H9.
   rewrite H9.
   rewrite CEncodeApp.
   rewrite !app_assoc_reverse.
   apply weakeness_mutualGen'...
   eapply @GenK4RelUT' with (C4:=x) (CK:=[]) (CN:=[])...
   solveSignature1.
   simpl...
   LLStore.
   apply NegF with (a:=loc)...
   intro;intros...
 Qed.

Tactic Notation "decideT" :=
       match goal with
        | [ |- ?P :: ?X; ?L |-- ?R] =>  eapply @KT4Dec with (F:= P);sauto
       end.

Tactic Notation "decideTW" :=
       match goal with
        | [ |- ?P :: ?X; ?L |-- ?R] =>  eapply @KT4Dec with (F:= P);sauto; try apply KT4SeqTWkL1
       end.

Lemma PermSecond (L1 L2: list TypedFormula):
     Permutation L1 L2 ->
     Permutation (second L1) (second L2) .
  Proof.
  eapply Permutation_map.
  Qed.

(** Completeness theorem *)
Theorem Completeness: forall n j D L1 L2 R1 R2,
    m4 j = true -> mt j = true ->
    isOLFormulaL D ->
    isOLFormulaL L1 ->
    isOLFormulaL L2 ->
    isOLFormulaL R1 ->
    isOLFormulaL R2 ->
    seqN (KT4 j) n
    (CEncode j (LEncode D) ++ (CEncode loc (LEncode L1) ++ CEncode loc (REncode R1))) (LEncode L2 ++  REncode R2)
    (UP []) ->
    KT4Seq D (L1++L2) (R1++R2).
Proof with CleanContext;solveSE;OLSolve.
  intro.
  induction n using strongind; intros j D L1 L2 R1 R2 Fj Mj HisD HisL1 HisL2 HisR1 HisR2 Hseq;
  inversion Hseq...
  * apply RemoveNotPos1 in H2;sauto...
     inversion H0; inversion H1...
     OLSolve. OLSolve.
  * apply InUNotPos in H4;sauto.
    rewrite !secondApp.
    rewrite !secCEncode.
    OLSolve. all: OLSolve.
  * apply RemoveNotPos2 in H4;sauto.
    rewrite !secondApp.
    rewrite !secCEncode.
    OLSolve. all:OLSolve.
  * inversion H1...
  + inversion H0...
  ++ (* Constant right *)
      apply BipoleReasoning in H3...
      -
      apply checkEncodeCasesU in H8...
      apply OLInPermutation' in H5...
      rewrite H5...
      rewrite <- perm_takeit_2...
      -
      apply PermSecond in H9.
      rewrite !secondApp in H9.
      rewrite !secCEncode in H9.
      simpl in H9.
      rewrite app_assoc in H9.
      rewrite <- LEncodeApp in H9.
      symmetry in H9.
      apply checkEncodeCasesU in H9...
      apply OLInPermutation' in H5...
      rewrite H5...
      rewrite <- app_comm_cons...
  ++ (* Constant left *)
      apply BipoleReasoning in H3...
      -
      simpl in H7.
      inversion H7...
      -
      simpl in H7.
      inversion H7...
  ++ (* Constant left *)
      apply BipoleReasoning in H3...
      -
      simpl in H7.
      inversion H7...
      -
      simpl in H7.
      inversion H7...
  ++ (* Constant right *)
      apply BipoleReasoning in H3...
      -
      apply checkEncodeCasesD in H8...
      apply OLInPermutationL' in H5...
      rewrite H5...
      rewrite <- perm_takeit_2...
      -
      apply PermSecond in H9.
      rewrite !secondApp in H9.
      rewrite !secCEncode in H9.
      simpl in H9.
      rewrite app_assoc in H9.
      rewrite <- LEncodeApp in H9.
      symmetry in H9.
      apply checkEncodeCasesD in H9...
      apply OLInPermutationL' in H5...
      checkPermutationCases H5.
      1-2: rewrite H5...
      2: rewrite <- app_comm_cons...
      decideT.
  + inversion H0...
    ++ (* binary connective right *)
      apply BipoleReasoning in H3...
      -
      apply checkEncodeCasesU in H8...
      apply OLInPermutation' in H5...
        rewrite H5 in HisR2.
        rewrite H5...
        rewrite <- perm_takeit_2...

      apply FocusingWith in H7...
      apply KT4AndR...

      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x2)...
      LLExact H9.
      rewrite <- H6...

      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x2)...
      LLExact H10.
      rewrite <- H6...
      -
      apply PermSecond in H9.
      rewrite !secondApp in H9.
      rewrite !secCEncode in H9.
      simpl in H9.
      rewrite app_assoc in H9.
      rewrite <- LEncodeApp in H9.
      symmetry in H9.

      apply checkEncodeCasesU in H9...
      apply OLInPermutation' in H5...
        rewrite H5 in HisR1.
        rewrite H5...
      rewrite <- app_comm_cons.
      apply KT4CtR.
      rewrite app_comm_cons.
        rewrite <- H5...

      apply FocusingWith in H7...
      apply KT4AndR...

      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x3)...
      simpl...
      LLExact H10.

      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x3)...
      simpl...
      LLExact H11.
    ++
      apply BipoleReasoning in H3...
      -
      apply checkEncodeCasesD in H8...
      apply OLInPermutationL' in H5...
        rewrite H5 in HisL2.
        rewrite H5...
        rewrite <- perm_takeit_2...

      apply FocusingPlus in H7...
      apply KT4AndL1...

      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x2)...
      LLExact H8.
      rewrite <- H6...

      apply KT4AndL2...
      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x2)...
      LLExact H8.
      rewrite <- H6...
      -
      apply PermSecond in H9.
      rewrite !secondApp in H9.
      rewrite !secCEncode in H9.
      simpl in H9.
      rewrite app_assoc in H9.
      rewrite <- LEncodeApp in H9.
      symmetry in H9.

      apply checkEncodeCasesD in H9...
      apply OLInPermutationL' in H5...
      checkPermutationCases H5.
        rewrite H5 in HisD.
        rewrite H5...
        decideT.
        rewrite <- H5.

      apply FocusingPlus in H7...
      apply KT4AndL1...

      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x4)...

      apply KT4AndL2...

      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x4)...

      rewrite H5.

      rewrite <- app_comm_cons.
      apply KT4CtL.
      rewrite app_comm_cons.
        rewrite <- H5...

      apply FocusingPlus in H7...
      apply KT4AndL1...

      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x4)...

      apply KT4AndL2...

      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x4)...
    ++
      apply BipoleReasoning in H3...
      -
      apply checkEncodeCasesU in H8...
      apply OLInPermutation' in H5...
        rewrite H5 in HisR2.
        rewrite H5...
        rewrite <- perm_takeit_2...

      apply FocusingPlus in H7...
      apply KT4OrR1...

      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x2)...
      LLExact H8.
      rewrite <- H6...

      apply KT4OrR2...
      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x2)...
      LLExact H8.
      rewrite <- H6...
      -
      apply PermSecond in H9.
      rewrite !secondApp in H9.
      rewrite !secCEncode in H9.
      simpl in H9.
      rewrite app_assoc in H9.
      rewrite <- LEncodeApp in H9.
      symmetry in H9.

      apply checkEncodeCasesU in H9...
      apply OLInPermutation' in H5...

      rewrite H5.

      rewrite <- app_comm_cons.
      apply KT4CtR.
      rewrite app_comm_cons.
        rewrite <- H5...

      apply FocusingPlus in H7...
      apply KT4OrR1...

      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x3)...
      simpl...
      LLExact H9.

      apply KT4OrR2...

      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x3)...
      simpl...
      LLExact H9.
    ++
      apply BipoleReasoning in H3...
      -
      apply checkEncodeCasesD in H8...
      apply OLInPermutationL' in H5...
        rewrite H5 in HisL2.
        rewrite H5...
        rewrite <- perm_takeit_2...

      apply FocusingWith in H7...
      apply KT4OrL...

      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x2)...
      LLExact H9.
      rewrite <- H6...

      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x2)...
      LLExact H10.
      rewrite <- H6...
      -
      apply PermSecond in H9.
      rewrite !secondApp in H9.
      rewrite !secCEncode in H9.
      simpl in H9.
      rewrite app_assoc in H9.
      rewrite <- LEncodeApp in H9.
      symmetry in H9.

      apply checkEncodeCasesD in H9...
      apply OLInPermutationL' in H5...
      checkPermutationCases H5.

      rewrite H5 in HisD.
      rewrite H5. decideT.
        rewrite <- H5...

       apply FocusingWith in H7...
      apply KT4OrL...

      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x4)...

      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x4)...

      rewrite H5 in HisL1.
      rewrite H5.
      rewrite <- app_comm_cons.
      apply KT4CtL.
      rewrite app_comm_cons.
        rewrite <- H5...
       apply FocusingWith in H7...
      apply KT4OrL...

      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x4)...

      rewrite perm_takeit_2...
      eapply H with (j:=j) (m:=x4)...
  + apply FocusingInitRuleU in H3;sauto.
    ++
      rewrite Permutation_cons_append in H4.
      apply destructEncode in H4...
      all: try repeat match goal with
      | [H: REncode _ = nil |- _] => apply map_eq_nil in H;sauto
      | [H: LEncode _ = nil |- _] => apply map_eq_nil in H;sauto
      | [H: REncode _ = [_] |- _] => apply map_eq_cons in H;sauto
      | [H: LEncode _ = [_] |- _] => apply map_eq_cons in H;sauto
      end...
      inversion H9; inversion H7...
      rewrite Permutation_app_comm.
      simpl...
      rewrite Permutation_app_comm.
      simpl...
    ++
        all: try repeat match goal with
      | [H: REncode _ = nil |- _] => apply map_eq_nil in H;sauto
      | [H: LEncode _ = nil |- _] => apply map_eq_nil in H;sauto
      | [H: REncode _ = [_] |- _] => apply map_eq_cons in H;sauto
      | [H: LEncode _ = [_] |- _] => apply map_eq_cons in H;sauto
      end...

      inversion H8...
      rewrite Permutation_app_comm.
      simpl...

      apply PermSecond in H6.
      rewrite !secondApp in H6.
      rewrite !secCEncode in H6.
      simpl in H6.
      rewrite app_assoc in H6.
      rewrite <- LEncodeApp in H6.
      symmetry in H6.

      apply checkEncodeCasesD in H6...
      apply OLInPermutationL' in H4...
      checkPermutationCases H4.

      rewrite H4.
      decideT.
      rewrite H4...
    ++ apply map_eq_cons in H5...
    ++ apply map_eq_cons in H8...
    ++
        all: try repeat match goal with
      | [H: REncode _ = nil |- _] => apply map_eq_nil in H;sauto
      | [H: LEncode _ = nil |- _] => apply map_eq_nil in H;sauto
      | [H: REncode _ = [_] |- _] => apply map_eq_cons in H;sauto
      | [H: LEncode _ = [_] |- _] => apply map_eq_cons in H;sauto
      end...

      inversion H8...
      rewrite Permutation_app_comm.
      simpl...

      apply PermSecond in H6.
      rewrite !secondApp in H6.
      rewrite !secCEncode in H6.
      simpl in H6.
      rewrite app_assoc in H6.
      rewrite <- LEncodeApp in H6.
      symmetry in H6.

      apply checkEncodeCasesU in H6...
      apply OLInPermutation' in H4...
      rewrite H4...
     ++

      apply PermSecond in H4, H6.
      rewrite !secondApp in H4, H6.
      rewrite !secCEncode in H4, H6.
      simpl in H4, H6.
      rewrite app_assoc in H4, H6.
      rewrite <- LEncodeApp in H4, H6.
      symmetry in H4, H6.

      apply checkEncodeCasesD in H4...
      apply checkEncodeCasesU in H6...
      apply OLInPermutationL' in H9...
      apply OLInPermutation' in H6...
      rewrite H6...
      checkPermutationCases H9.

        all: try repeat match goal with
      | [H: REncode _ = nil |- _] => apply map_eq_nil in H;sauto
      | [H: LEncode _ = nil |- _] => apply map_eq_nil in H;sauto
      | [H: REncode _ = [_] |- _] => apply map_eq_cons in H;sauto
      | [H: LEncode _ = [_] |- _] => apply map_eq_cons in H;sauto
      end...

      rewrite H9. decideT.
      rewrite H9...
    + inversion H0...
    ++ apply BipoleReasoning in H3...
      -
      apply checkEncodeCasesU in H8...
      apply OLInPermutation' in H4...
        rewrite H4 in HisR2.
        rewrite H4...
        rewrite <- perm_takeit_2...
       rewrite <- CEncodeApp in H7.
       rewrite <- LocCEncodeLoc in H7.
       simpl in H7.
       rewrite Permutation_app_comm in H7.
       apply FocusingBangSet in H7...
       apply map_eq_nil in H3...
       apply map_eq_nil in H5...

        apply KT4BoxR.
        apply destructCEncode in H9...
        apply destructLEncode in H9...

        eapply ImpGen with (A1:=x1) (A2:=[]) (A3:=x5)...
         change (@nil uexp) with ( (@nil uexp)++[]).
         rewrite app_comm_cons.
        eapply H with (m:=x2) (j:=j)...
        simpl...
        Import SL.InvPositivePhase.
        rewrite Permutation_app_comm.
        simpl...
        apply AbsorptionL;solveSignature1...
        LLExact H14.
        rewrite H4.
        srewrite H5...
      -
      apply PermSecond in H9.
      rewrite !secondApp in H9.
      rewrite !secCEncode in H9.
      simpl in H9.
      rewrite app_assoc in H9.
      rewrite <- LEncodeApp in H9.
      symmetry in H9.

      apply checkEncodeCasesU in H9...
      apply OLInPermutation' in H4...

        rewrite H4 in HisR1.
        rewrite H4...
        rewrite <- app_comm_cons.
       rewrite <- CEncodeApp in H7.
       rewrite <- LocCEncodeLoc in H7.
       simpl in H7.
       rewrite Permutation_app_comm in H7.
       apply FocusingBangSet in H7...
       apply map_eq_nil in H3, H13...

        apply destructCEncode in H10...
        apply destructLEncode in H14...
        apply KT4BoxR.
        eapply ImpGen with (A1:=x7) (A2:=[]) (A3:=x8)...
         change (@nil uexp) with ( (@nil uexp)++[]).
         rewrite app_comm_cons.
        eapply H with (m:=x3) (j:=j)...
        simpl...
        Import SL.InvPositivePhase.
        rewrite Permutation_app_comm.
        simpl...
        apply AbsorptionL;solveSignature1...
        LLExact H15.
        rewrite H7.
        srewrite H10...
    ++ apply BipoleReasoning in H3...
      -
      apply checkEncodeCasesD in H8...
      apply OLInPermutationL' in H4...
        rewrite H4 in HisL2.
        rewrite H4...
        rewrite <- perm_takeit_2...
        apply FocusingQuest in H7...
        apply KT4BoxL.
        eapply H with (m:=x2) (j:=j)...
        LLExact H8.
      -
      apply PermSecond in H9.
      rewrite !secondApp in H9.
      rewrite !secCEncode in H9.
      simpl in H9.
      rewrite app_assoc in H9.
      rewrite <- LEncodeApp in H9.
      symmetry in H9.

      apply checkEncodeCasesD in H9...
      apply OLInPermutationL' in H4...
      checkPermutationCases H4.

      rewrite H4 in HisD.
      rewrite H4. decideT.
        rewrite <- H4...

       apply FocusingQuest in H7...
       apply KT4BoxL.
        eapply H with (m:=x4) (j:=j)...

      rewrite H4.
      rewrite <- app_comm_cons.
      apply KT4CtL.
      rewrite app_comm_cons.
        rewrite <- H4...

      apply FocusingQuest in H7...
       apply KT4BoxL.
        eapply H with (m:=x4) (j:=j)...
    +
       apply BipoleReasoning in H3...
    ++
        apply FocusingQuest in H6...
        apply checkEncodeCasesD in H7...
        apply OLInPermutationL' in H4...
        rewrite H4.
        rewrite <- Permutation_middle.
        rewrite app_comm_cons.
        eapply H with (m:=x1) (j:=j)...
        LLExact H5. simpl...
    ++
        apply FocusingQuest in H6...

        apply PermSecond in H8.
      rewrite !secondApp in H8.
      rewrite !secCEncode in H8.
      simpl in H8.
      rewrite app_assoc in H8.
      rewrite <- LEncodeApp in H8.
      symmetry in H8.

      apply checkEncodeCasesD in H8...
      apply OLInPermutationL' in H4...
      checkPermutationCases H4.

      rewrite H4 in HisD.
      rewrite H4. decideT.
        rewrite <- H4...
      rewrite app_comm_cons.
       eapply H with (m:=x2) (j:=j)...
       LLExact H6. simpl...

      rewrite H4.
        rewrite <- app_comm_cons.
        apply KT4CtL.
        rewrite app_comm_cons.
        rewrite <- H4.
        rewrite app_comm_cons.
        eapply H with (m:=x2) (j:=j)...
        LLExact H6. simpl...
    +
       apply BipoleReasoning in H3...
    ++
        apply FocusingQuest in H6...
        apply checkEncodeCasesU in H7...
        apply OLInPermutation' in H4...
        rewrite H4.
        rewrite <- Permutation_middle.
        rewrite app_comm_cons.
        eapply H with (m:=x1) (j:=j)...
        LLExact H5. simpl...
    ++
        apply FocusingQuest in H6...

        apply PermSecond in H8.
      rewrite !secondApp in H8.
      rewrite !secCEncode in H8.
      simpl in H8.
      rewrite app_assoc in H8.
      rewrite <- LEncodeApp in H8.
      symmetry in H8.

      apply checkEncodeCasesU in H8...
      apply OLInPermutation' in H4...

      rewrite H4.
        rewrite <- app_comm_cons.
        apply KT4CtR.
        rewrite app_comm_cons.
        rewrite <- H4.
        rewrite app_comm_cons.
        eapply H with (m:=x2) (j:=j)...
        LLExact H6. simpl...
  * solveSignature1.
Qed.

  Lemma  SoundenessKT4' j D L1 R1 L2 R2 :
     mt j = true -> m4 j = true ->
      isOLFormulaL D ->
      isOLFormulaL L1 ->
      isOLFormulaL R1 ->
      isOLFormulaL L2 ->
      isOLFormulaL R2 ->
      KT4Seq D (L1++L2) (R1++R2) ->
      seq (KT4 j)
     (CEncode j (LEncode D) ++ (CEncode loc (LEncode L1) ++ CEncode loc (REncode R1))) (LEncode L2 ++ REncode R2) (UP []).
 Proof with OLSolve.

 intros Mt Ft isFD isFL1 isFR1 isFL2 isFR2 Hyp.
 eapply PosNegSetT with (a:=loc) (b:=loc)...
  1-2: intro; intros...
  eapply SoundenessKT4 with (j:=j) in Hyp...
  eapply exchangeCC'.
  2:{ exact Hyp. }
  rewrite LEncodeApp.
  rewrite REncodeApp.
  rewrite !CEncodeApp... perm.
  Qed.

 Theorem AdequacyKT4 j D L1 R1 L2 R2:
   mt j = true -> m4 j = true ->
      isOLFormulaL D ->
      isOLFormulaL L1 ->
      isOLFormulaL R1 ->
      isOLFormulaL L2 ->
      isOLFormulaL R2 ->
   KT4Seq D (L1 ++ L2) (R1 ++ R2) <->
   seq (KT4 j)
     (CEncode j (LEncode D) ++ (CEncode loc (LEncode L1) ++ CEncode loc (REncode R1))) (LEncode L2 ++ REncode R2) (UP []).
Proof with sauto.
 intros.
  split;intros.
  + apply SoundenessKT4'...
  + apply seqtoSeqN in H6...
    apply Completeness in H6...
Qed.

End KT4Adequacy.


Set Universe Polymorphism.
Set Primitive Projections.

Record sig A (P : A -> Type) := exist {
  wit : A;
  prf : P wit;
}.

Arguments wit {_ _} _.
Arguments prf {_ _} _.

Inductive unit := tt.

(** Horrendous encoding of the delay monad because pattern-matching break
    the positivity condition. *)

Inductive option A :=
| None : option A
| Some : A -> option A.

Arguments None {_}.
Arguments Some {_} _.

CoInductive conat := build { hd : option conat }.

Definition coO := {| hd := None |}.

Inductive hoption {A} (N : Type) (S : A -> Type) : option A -> Type :=
| hNone : N -> hoption N S None
| hSome : forall x, S x -> hoption N S (Some x).

Arguments hNone {_ _ _} _.
Arguments hSome {_ _ _} _ _.

CoInductive Φ@{i} (A : Type@{i}) (i : option conat) : Type@{i} :=
  node { step : hoption@{i i i} A (fun n => Φ A n.(hd)) i }.

Arguments node {_ _} _.
Arguments step {_ _}.

Inductive poption {A N S} (fN : N -> Type) (fS : forall x, S x -> Type) : forall (o : option A), hoption N S o -> Type :=
| pNone : forall x, fN x -> poption fN fS None (hNone x)
| pSome : forall x s, fS x s -> poption fN fS (Some x) (hSome x s).

CoInductive hΦ {A : Type} (f : A -> Type) {i : option conat} (φ : hoption A (fun n => Φ A n.(hd)) i) : Type :=
  hnode { hstep : poption f (fun i ψ => hΦ _ f _ ψ.(step)) _ φ }.

CoFixpoint map {A B} (f : A -> B) (i : option conat) (φ : Φ A i) : Φ B i :=
match φ.(step) in hoption _ _ i return Φ B i with
| hNone x => node (hNone (f x))
| hSome _ n => node (hSome _ (map f _ n))
end.

(** At last reasonable stuff *)

Definition M@{i} (A : Type@{i}) : Type@{i} :=
  sig conat@{i} (fun n => Φ A n.(hd)).

Definition ret {A : Type} (x : A) : M A :=
  exist _ _ coO (@node _ _ (hNone x)).

Definition pointwise {A} (f : A -> Type) (s : M A) : Type.
Proof.
refine (match s.(wit).(hd) as n return Φ A n -> Type
with
| None => fun φ => _
| Some x => fun φ => _
end s.(prf)).
+ refine (
    match φ.(step) in hoption _ _ o return
      match o with
      | None => _
      | Some _ => unit
      end
    with
    | hNone x => f x
    | hSome _ n => tt
    end
  ).
+ refine (hΦ f φ.(step)).
Defined.

Definition TYPE := M (sig Type (fun A => M A -> A)).
Definition El (A : TYPE) := pointwise wit A.

CoFixpoint _bind {A B i}
CoFixpoint bind {A B} (s : M A) (f : A -> M B) : M B.
{| step :=
    match s.(step) with
    | inl x => (f x).(step)
    | inr s => inr (bind s f)
    end
|}.

Definition Typeᶫ : TYPE.
Proof.
refine {|
  wit := ret TYPE;
  alg := fun T => {| wit := bind T wit; alg := _ |};
|}.
unfold is_alg, pointwise; cbn.
destruct (step T) as [A|]; [|exact tt].
destruct A as [wit alg]; cbn.
unfold is_alg, pointwise in *.
destruct (step wit) as [X|]; [|exact tt].
exact alg.
Defined.

Check Typeᶫ : El Typeᶫ.

Definition Prodᶫ (A : TYPE) (B : El A -> TYPE) : TYPE := {|
  wit := ret (forall x : El A, El (B x));
  alg := fun f x => pointwise_alg (B x).(alg) (map (fun f => f x) f)
|}.

Definition Lamᶫ {A B} (f : forall x : El A, El (B x)) : El (Prodᶫ A B) := f.
Definition Appᶫ {A B} (f : El (Prodᶫ A B)) (x : El A) := f x.

Definition boolᶫ : TYPE := {| wit := ret (M bool); alg := fun b => bind b (fun b => b) |}.
Definition trueᶫ : El boolᶫ := ret true.
Definition falseᶫ : El boolᶫ := ret false.

Definition hbind {A B} (l : M A) (f : A -> El B) : El B :=
match l.(step) with
| inl x => f x
| inr s =>
  let later := cofix later (s : M A) : M (El B) := match s.(step) with
  | inl x => ret (f x)
  | inr s => {| step := inr (later s) |}
  end in
  pointwise_alg (B.(alg)) (later s)
end.

Definition bool_caseᶫ (P : TYPE) (Pt : El P) (Pf : El P) (b : El boolᶫ) : El P :=
  hbind b (fun b => if b then Pt else Pf).

Check (eq_refl : (fun P Pt Pf => bool_caseᶫ P Pt Pf trueᶫ) = (fun P Pt Pf => Pt)).
Check (eq_refl : (fun P Pt Pf => bool_caseᶫ P Pt Pf falseᶫ) = (fun P Pt Pf => Pf)).

Definition bool_recᶫ (P : El boolᶫ -> TYPE)
  (Pt : El (P trueᶫ)) (Pf : El (P falseᶫ)) (b : El boolᶫ) : El (bool_caseᶫ Typeᶫ (P trueᶫ) (P falseᶫ) b).
Proof.
unfold bool_caseᶫ, hbind.
set (b0 := step b) in *; clearbody b0; clear b; rename b0 into b.
induction b as [[|]|b]; cbn in *.
+ exact Pt.
+ exact Pf.
+ unfold El; cbn.
  unfold hlist, pointwise, bind; cbn.
  set (b0 := step b) in *; clearbody b0; clear b; rename b0 into b.
  induction b as [[|]|b]; cbn in *; unfold El, hlist, pointwise in *.
  - exact Pt.
  - exact Pf.
  - exact tt.
Defined.

Check (eq_refl : (fun P Pt Pf => bool_recᶫ P Pt Pf trueᶫ) = (fun P Pt Pf => Pt)).
Check (eq_refl : (fun P Pt Pf => bool_recᶫ P Pt Pf falseᶫ) = (fun P Pt Pf => Pf)).

Definition Falseᶫ : TYPE := {|
  wit := ret (M False);
  alg := fun b => bind b (fun b => b);
|}.

Definition fixᶫ : El (Prodᶫ Typeᶫ (fun A => Prodᶫ (Prodᶫ A (fun _ => A)) (fun _ => A))).
Proof.
intros A f; cbn in *.
apply (pointwise_alg A.(alg)); cbn.
unfold El in f.
pose (bot := pointwise_alg A.(alg) (cofix bot := {| step := inr bot |})).
generalize bot; clear bot.
cofix F; intros x.
refine (F x).
Defined.

Definition fixᶫ : El (Prodᶫ Typeᶫ (fun A => Prodᶫ (Prodᶫ (laterᶫ A) (fun _ => A)) (fun _ => A))) :=
  fun A x => x tt.

Definition fail : El (Prodᶫ Eᶫ (fun _ => Prodᶫ Typeᶫ (fun A => A))) :=
  fun e A => pointwise_alg A.(alg) (Err _ e).

Goal El (Prodᶫ Typeᶫ (fun A => A)).
compute.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery64_2e141m9_3limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D Aprime Bprime Cprime Dprime X Y P : Universe, ((wd_ X A /\ (wd_ X Aprime /\ (wd_ X C /\ (wd_ X Cprime /\ (wd_ Y B /\ (wd_ Y Bprime /\ (wd_ Y D /\ (wd_ Y Dprime /\ (wd_ A B /\ (wd_ Aprime Bprime /\ (wd_ A C /\ (wd_ B D /\ (wd_ A Aprime /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ A D /\ (wd_ Aprime Dprime /\ (col_ X A C /\ (col_ X A Aprime /\ (col_ X A Cprime /\ (col_ Y B D /\ (col_ Y B Bprime /\ (col_ Y B Dprime /\ (col_ P X Aprime /\ col_ P Y Bprime)))))))))))))))))))))))) -> col_ P X A)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require list.List.

(* Why3 comment *)
(* combine is replaced with (Lists.List.combine x x1) by the coq driver *)

(* Why3 goal *)
Lemma combine_def : forall {a:Type} {a_WT:WhyType a}
  {b:Type} {b_WT:WhyType b}, forall (x:(list a)) (y:(list b)), match (x,
  y) with
  | ((Init.Datatypes.cons x0 x1), (Init.Datatypes.cons y0 y1)) =>
      ((Lists.List.combine x y) = (Init.Datatypes.cons (x0,
      y0) (Lists.List.combine x1 y1)))
  | _ => ((Lists.List.combine x y) = Init.Datatypes.nil)
  end.
Proof.
now intros a a_WT b b_WT [|xh xt] [|yh yt].
Qed.