Require Import Setoid.
Require Import Bool.
Require Import List.
Require Import ZArith.
Require Import Nat.
(*Load our files*)
Require Import Tools.
Require Import ListExtras.
Require Import Zvec.
Require Import SimpleLieAlgebras.
Open Scope nat_scope.

Section data.
  Definition is_exceptional_multiplier g i m :=
    if (m <? 0)%Z
    then false
    else
      if (m =? 0) %Z
      then true
      else
        if (i =? 0) || (lie_rank g <? i)
        then false
        else
          match g with
            | lie_A (exist _ n _)
              => (n =? 3)
                   || (i =? 1)
                   || (i =? n)
            | lie_B (exist _ n _)
              => (n =? 2)
                   || (i =? 1)
                   || (i =? 2) && (m <=? 2)%Z
                   || (m <=? 1)%Z
            | lie_C (exist _ n _)
              => (i =? 1)
                   || (even i) && (m =? 1)%Z
                   || (i =? 2) && (m =? 2)%Z
                   || (n =? 2)
                   || (n =? 3) && (i =? 3) && (m =? 1)%Z
                   || (n =? 4) && (i =? 4) && (m =? 2)%Z
            | lie_D (exist _ n _)
              => (n =? 3)
                   || (n =? 4) && ((i =? 3) || (i =? 4))
                   || (i =? 1)
                   || (even n) && (((i =? 2) && (m <=? 2)%Z)
                                     || ((even i) && (m <=? 1)%Z)
                                     || ((1 + i =? n) && (m <=? 1)%Z))
            | lie_E6
              => false
            | lie_E7
              => ((i =? 1) && (m <=? 2)%Z)
                   || ((i =? 6) && (m <=? 1)%Z)
                   || ((i =? 7) && (m <=? 1)%Z)
            | lie_E8
              => ((i =? 1) && (m <=? 1)%Z) || ((i =? 8) && (m <=? 8)%Z)
            | lie_F4
              => ((i =? 1) || (i =? 4)) && (m <=? 2)%Z
            | lie_G2
              => (m <=? 2)%Z
          end.
  Definition is_mixed_by_hand_revwt_alg g lambda :=
    (is_radical g lambda)
      && match g, lambda with
           | lie_A (exist _ 2 _), (-1::0::1::nil)%Z => true
           | lie_A (exist _ 3 _), (-1::0::0::1::nil)%Z => true
           | lie_A (exist _ 3 _), (-2::0::1::1::nil)%Z => true
           | lie_A (exist _ 3 _), (-1::-1::0::2::nil)%Z => true
           | lie_B (exist _ 2 _), (0::1::2::nil)%Z => true
           | lie_B (exist _ 3 _), (0::1::2::nil)%Z => true
           | lie_B (exist _ 3 _), (0::3::3::nil)%Z => true
           | lie_B (exist _ 3 _), (1::1::2::nil)%Z => true
           | lie_B (exist _ 3 _), (1::2::2::nil)%Z => true
           | lie_B (exist _ 3 _), (2::2::2::nil)%Z => true
           | lie_B (exist _ 4 _), (0::0::3::3::nil)%Z => true
           | lie_B (exist _ 4 _), (0::1::2::2::nil)%Z => true
           | lie_C (exist _ 2 _), (1::3::nil)%Z => true
           | lie_C (exist _ 3 _), (0::3::3::nil)%Z => true
           | lie_C (exist _ 3 _), (1::1::2::nil)%Z => true
           | lie_C (exist _ 3 _), (2::3::3::nil)%Z => true
           | lie_C (exist _ 3 _), (4::4::4::nil)%Z => true
           | lie_C (exist _ 4 _), (0::2::2::2::nil)%Z => true
           | lie_C (exist _ 4 _), (1::1::2::2::nil)%Z => true
           | lie_C (exist _ 5 _), (0::2::2::2::2::nil)%Z => true
           | lie_C (exist _ 5 _), (2::2::2::2::2::nil)%Z => true
           | _, _ => false
         end.
  (*TODO: add more mixed representations shown "by_hand".*)
End data.

Section branching.
  (*w0 of sl(n+1) coincides with w0 of sl(2)xsl(n-1)*)
  (*Branching of radical representation of sl(n+1) to sl(n-1),
    restricting to zero weight of sl(2).  This criterion is complete.*)
  Definition radical_branching_A_two_revwt_b lambda mu :=
    (length lambda =? S (S (length mu)))
      && (lie_is_radical_revwt_type lie_A_type lambda)
      && (lie_is_radical_revwt_type lie_A_type mu)
      && (Zvec_short_allb Z.leb lambda mu)
      && (Zvec_short_allb Z.leb mu (tl (tl lambda))).
  Definition Is_known_w0_branching_A_revwt lambda mu :=
    radical_branching_A_two_revwt_b lambda mu = true.

  (*w0 of so(2n+1) coincides with w0 of so(4)xso(2n-3)*)
  (*Partial criterion for branching from so(2n+1) to so(2n-1)
    with zero so(2) charge.  Then do it twice.*)
  Definition known_radical_branching_B_one_revwt_b lambda mu :=
    (length lambda =? S (length mu))
      && (lie_is_radical_revwt_type lie_B_type lambda)
      && (lie_is_radical_revwt_type lie_B_type mu)
      && (Zvec_short_allb (fun a b => Z.even (Z.sub a b))
                          (Zvec_short_max lambda mu)
                          (Zvec_long_min (tl lambda) (tl mu))).
  Definition Is_known_w0_branching_B_revwt lambda nu :=
    exists mu,
      known_radical_branching_B_one_revwt_b lambda mu = true
      /\ known_radical_branching_B_one_revwt_b mu nu = true.

  (*w0 of sp(n) coincides with w0 of sl(2)xsp(n-1)*)
  (*Partial criterion for branching from sp(n) to sp(n-1),
    restricting to zero weight of sl(2).*)
  Definition Is_known_w0_branching_C_revwt lambda mu :=
    length lambda = S (length mu)
    /\ lie_is_radical_revwt_type lie_C_type lambda = true
    /\ lie_is_radical_revwt_type lie_C_type mu = true
    /\ Zvec_short_allb
         (fun a b => Z.even (Z.sub a b))
         (Zvec_short_max lambda mu)
         (Zvec_long_min (tl lambda) (tl mu))
       = true.

  (*TODO: add more known branchings that preserve w0*)
  (*Put together all known branchings preserving w0.*)
  (*No need to check ranks of g and h as it is done by the Is_known_... functions.*)
  Definition Is_known_w0_branching_revwt_alg g lambda h mu :=
    is_radical g lambda = true
    /\ is_radical h mu = true
    /\ match lie_algebra_type g, lie_algebra_type h with
         | lie_A_type, lie_A_type => Is_known_w0_branching_A_revwt lambda mu
         | lie_B_type, lie_B_type => Is_known_w0_branching_B_revwt lambda mu
         | lie_C_type, lie_C_type => Is_known_w0_branching_C_revwt lambda mu
         | _, _ => False
       end.
End branching.

Section main.
  Definition Is_nonmixed g lambda :=
    exists i m,
      (is_exceptional_multiplier g i m = true)
      /\ lambda = Zvec_mul m (lie_radical_fundamental_revwt_alg g i).
  Inductive Is_mixed : lie_algebra -> list Z -> Prop :=
  | mixed_by_hand :
      forall g lambda,
        is_mixed_by_hand_revwt_alg g lambda = true
        -> Is_mixed g lambda
  | mixed_by_ideal :
      forall g lambda mu,
        Is_mixed g mu
        -> length lambda = length mu
        -> is_radical g (Zvec_short_sub lambda mu) = true
        -> Is_mixed g lambda
  | mixed_by_induction :
      forall g lambda h mu,
        Is_mixed h mu
        -> Is_known_w0_branching_revwt_alg g lambda h mu
        -> Is_mixed g lambda.
End main.


(*
 * mu-calculus for infinite data words:
 * Basic definition of LTL.
 *)

Require Export Nat Arith.
Require Export Lists.List.
Require Export Lists.Streams.
Require Import Sets.Ensembles.

(* data words *)

Definition D := nat.
Definition At := nat.
Definition Sigma := At -> bool.
Definition data_word := Stream (Sigma * D)%type.

(* LTL syntax *)

Definition register := nat.
Definition Var := nat.

Inductive ltl_atom :=
  | tt : ltl_atom
  | MATCH : register -> ltl_atom
  | p : At -> ltl_atom  (* an atomic proposition *)
  .
Inductive ltl_phi :=
  | pos : ltl_atom -> ltl_phi  (* a positive literal *)
  | neg : ltl_atom -> ltl_phi  (* a negative literal *)
  | AND_phi : ltl_phi -> ltl_phi -> ltl_phi
  .
Inductive ltl :=
  | var : Var -> ltl
  | OR  : ltl -> ltl -> ltl
  | STORE_X : (list register) -> ltl -> ltl_phi -> ltl
  | PHI : ltl_phi -> ltl
  .

Notation "'↑' r" := (MATCH r) (at level 75).
Notation "a '.\/' b" := (OR   a b) (at level 85, right associativity).
Notation "a './\' b" := (AND_phi a b) (at level 75, right associativity).
Notation  "'[' a ']'" := (pos a).
Notation "'~[' a ']'" := (neg a).
Notation "'φ' p" := (PHI p) (at level 78).
Notation "'↓' R ',X' psi '../\' phi" := (STORE_X R psi phi) (at level 200).

(*
Check (STORE_X (1 :: nil) (OR (PHI (neg (p 1))) (PHI (pos (p 2)))) (pos (↑ 1))).
Check (↓ (1 :: nil) ,X ((φ ~[p 1]) .\/ (φ [p 2])) ../\ [↑1]).
*)

(* LTL semantics *)

Definition Theta := register -> D.

Definition update
  (theta : Theta) (i : register) (d : D) : Theta :=
  fun (r : register) =>
    if r =? i then d else theta r.
Fixpoint updateR
  (theta : Theta) (R : list register) (d : D) : Theta :=
  match R with
  | h :: t => update (updateR theta t d) h d
  | nil => theta
  end.

Definition theta_bot : Theta :=
  fun (r : register) => 0.

Definition Vtt : Var := 0.

(* Input data word : Env and models are depends on w *)
Parameter w : data_word.
Definition Env := Var -> nat -> nat -> Theta -> Theta -> Var -> Prop.

Definition empty_env : Env :=
  fun (v : Var) (i j : nat) (theta theta' : Theta) (x : Var)
    => False.

Definition models_atom
  (i : nat) (theta : Theta) (atom : ltl_atom)
  : Prop :=
  match atom with
  | tt => True
  | p a => fst (Str_nth i w) a = true
  | ↑ r => snd (Str_nth i w) = theta r
  end.

Inductive models_phi
  (i : nat) (theta : Theta) : ltl_phi -> Prop :=
  | models_pos : forall atom : ltl_atom,
    models_atom i theta atom -> models_phi i theta (pos atom)
  | models_neg : forall atom : ltl_atom,
    ~models_atom i theta atom -> models_phi i theta (neg atom)
  | models_AND_phi : forall (p1 p2 : ltl_phi),
    models_phi i theta p1 -> models_phi i theta p2
    -> models_phi i theta (AND_phi p1 p2)
  .

CoInductive models (u : Env)
  : nat -> Theta -> ltl -> Prop :=
  | models_var : forall i j theta theta' x v,
      u v i j theta theta' x ->
      i < j ->
      models u j theta' (var x) ->
      models u i theta (var v)
  | models_OR : forall i theta psi1 psi2,
      models u i theta psi1 \/
      models u i theta psi2 ->
      models u i theta (OR psi1 psi2)
  | models_STORE_X : forall i theta R psi phi,
      models_phi i theta phi ->
      models u (S i) (updateR theta R (snd (Str_nth i w))) psi ->
      models u i theta (↓ R ,X psi ../\ phi)
  | models_PHI : forall i theta phi,
      models_phi i theta phi ->
      models u i theta (φ phi)
  .

Notation "'(' i ',' theta '|=' u ',' psi ')'"
  := (models u i theta psi).

(* Equality of two ltl formulas *)

Axiom ltl_extensionality :
  forall psi1 psi2 : ltl,
    (forall i theta u, (i, theta |= u, psi1) <-> (i, theta |= u, psi2))
    -> psi1 = psi2.

Axiom Theta_extensionality :
  forall theta1 theta2 : Theta,
    (forall r, theta1 r = theta2 r) -> theta1 = theta2.

Lemma updateR_nil :
  forall theta d,
  updateR theta nil d = theta.
Proof.
  intros theta d.
  apply Theta_extensionality.
  intro r.
  now unfold updateR.
Qed.

Lemma phi_eq_xtt_phi : forall phi : ltl_phi,
  (φ phi) = ↓ nil ,X (φ [tt]) ../\ phi.
Proof.
  intro phi.
  apply ltl_extensionality.
  intros i theta u;
  split; intro H.
  - (* phi -> Xtt ../\ phi *)
  apply models_STORE_X.
  + (* models_phi i theta phi *)
  now inversion H.
  + (* tt *)
  apply models_PHI.
  now apply models_pos.
  - (* Xtt ../\ phi -> phi *)
  apply models_PHI.
  now inversion H.
Qed.

Lemma psi_eq_psi_or_ff : forall psi : ltl,
  psi = (psi .\/ (φ ~[tt])).
Proof.
  intro psi.
  apply ltl_extensionality.
  intros i theta u;
  split; intro H.
  - (* psi -> psi .\/ ff *)
  apply models_OR.
  now left.
  - (* psi .\/ ff -> psi *)
  inversion H as [|j th p1 p2 H1| |].
  destruct H1 as [H1 | H1]; auto.
  clear H2;
  inversion H1 as [| | |j' th' p1' H2].
  clear H3;
  inversion H2 as [|a H3|].
  unfold models_atom in H3.
  contradiction.
Qed.

(* Semantics on finite sequences *)

Inductive models_fin (u : Env)
  : nat -> nat -> Theta -> Theta -> Var -> ltl -> Prop :=
  | models_fin_var : forall i j theta theta' x v,
      i <= j ->
      u v i j theta theta' x ->
      models_fin u i j theta theta' x (var v)
  | models_fin_OR : forall i j theta theta' x psi1 psi2,
      i <= j ->
      models_fin u i j theta theta' x psi1 \/
      models_fin u i j theta theta' x psi2 ->
      models_fin u i j theta theta' x (OR psi1 psi2)
  | models_fin_STORE_X : forall i j theta theta' x R psi phi,
      i < j ->
      models_phi i theta phi ->
      models_fin u (S i) j (updateR theta R (snd (Str_nth i w))) theta' x psi ->
      models_fin u i j theta theta' x (↓ R ,X psi ../\ phi)
  | models_fin_TT : forall i j theta,
      i <= j ->
      models_fin u i j theta theta Vtt (φ [tt])
  | models_fin_PHI : forall i j theta (phi : ltl_phi),
      phi <> [tt] ->
      i < j ->
      models_phi i theta phi ->
      models_fin u i j theta theta Vtt (φ phi)
  .

Notation "'(' i ',' theta ';' j ',' theta' ',' x '|=' u ',' psi ')'"
  := (models_fin u i j theta theta' x psi).

(* Equation systems *)

Definition eqn_sys := Var -> ltl.  (* the type of equation systems *)

Parameter Var_omega : Var -> Prop.

(* The transformation from Env to Env *)
Definition F (sigma : eqn_sys) (u : Env) : Env :=
  fun (v : Var) (i j : nat) (theta theta' : Theta) (x : Var) =>
  (i, theta; j, theta', x |= u, sigma v)
  \/ (Var_omega v /\ x = v /\ i = j /\ theta = theta').

(* power of F *)
Fixpoint Fpow (sigma : eqn_sys) (i : nat) (u : Env) : Env :=
  match i with
    0   => u
  | S n => F sigma (Fpow sigma n u)
  end.
Definition Fpow_emp sigma i := Fpow sigma i empty_env.

(* Continuities *)

Section Continuities.

Definition env_leq (u1 u2 : Env) : Prop :=
  forall v : Var,
  forall i j theta theta' x,
  u1 v i j theta theta' x -> u2 v i j theta theta' x.

Inductive env_union : Ensemble Env -> Env :=
  env_union_intro :
    forall (s : Ensemble Env) u,
      In Env s u ->
    forall v i j theta theta' x,
      u v i j theta theta' x ->
      env_union s v i j theta theta' x.

Inductive Ens_map {A : Type} : (A -> A) -> Ensemble A -> Ensemble A :=
  Ens_map_intro :
    forall (f : A -> A) (s : Ensemble A) (u : A),
    In A s u -> In A (Ens_map f s) (f u).

Lemma env_leq_union :
  forall (s : Ensemble Env) (u : Env),
    In Env s u -> env_leq u (env_union s).
Proof.
  intros s u Hin.
  unfold env_leq;
  intros v i j theta theta' x Hu.
  now apply env_union_intro with u.
Qed.

Lemma models_fin_is_monotonic :
  forall (u1 u2 : Env),
    env_leq u1 u2 ->
  forall psi i j theta theta' x,
    (i, theta; j, theta', x |= u1, psi) ->
    (i, theta; j, theta', x |= u2, psi).
Proof.
  intros u1 u2 Hu1u2 psi.
  induction psi
  as [| psi1 IH1 psi2 IH2
      | R psi IH phi
      | phi ];
  intros i j theta theta' x H.
  - (* When psi = var v *)
  inversion H;
  apply models_fin_var; auto.
  - (* When psi = l1 .\/ l2 *)
  inversion_clear H as [|i1 j1 t1 t2 x1 p1 p2 Hij Hor| | |];
  apply models_fin_OR; auto;
  destruct Hor as [Hor | Hor];
  [left | right];
  [apply IH1 | apply IH2];
  auto.
  - (* When psi = ↓ R ,X psi ../\ phi *)
  inversion H;
  apply models_fin_STORE_X; auto.
  - (* When psi = φ phi *)
  inversion H.
  + now apply models_fin_TT.
  + now apply models_fin_PHI.
Qed.

Lemma models_fin_is_continuous_half :
  forall (s : Ensemble Env),
    (exists u, In Env s u) (* non-empty *) ->
  forall psi i j theta theta' x,
    (i, theta; j, theta', x |= env_union s, psi) ->
  exists u, In Env s u /\
    (i, theta; j, theta', x |= u, psi).
Proof.
  intros s Hnonemp psi.
  induction psi
  as [v | psi1 IH1 psi2 IH2 | R psi IH phi | phi];
  intros i j theta theta' x H.
  - (* When psi = var v *)
  inversion_clear H as [i1 j1 t1 t2 x1 v2 Hij Huni| | | |].
  inversion_clear Huni as [s1 u].
  exists u.
  split; auto.
  apply models_fin_var; auto.
  - (* When psi = psi1 .\/ psi2 *)
  inversion_clear H as [|i1 j1 t1 t2 x1 p1 p2 Hij Huni| | |].
  destruct Huni as [Huni | Huni];
  [apply IH1 in Huni | apply IH2 in Huni];
  destruct Huni as [u [Hin Huni]];
  exists u;
  split; auto;
  apply models_fin_OR; auto.
  - (* When psi = ↓ R ,X psi ../\ phi *)
  inversion_clear H as [| |i1 j1 t1 t2 x1 R1 p1 p2 Hij Hm Huni| |].
  apply IH in Huni.
  destruct Huni as [u [Hin Huni]].
  exists u.
  split; auto.
  apply models_fin_STORE_X; auto.
  - (* When psi = (φ phi) *)
  destruct Hnonemp as [u Hin].
  exists u;
  split; auto.
  inversion H as [| | | i1 j1 t1 Hij |].
  + now apply models_fin_TT.
  + now apply models_fin_PHI.
Qed.

Theorem models_fin_is_continuous :
  forall (s : Ensemble Env),
    (exists u, In Env s u) (* non-empty *) ->
  forall psi i j theta theta' x,
    (i, theta; j, theta', x |= env_union s, psi) <->
    (exists u, In Env s u /\
      (i, theta; j, theta', x |= u, psi)).
Proof.
  intros s Hnonemp psi i j theta theta' x.
  split.
  - (* -> *)
  now apply models_fin_is_continuous_half.
  - (* <- *)
  intros [u [Hin Hm]].
  apply models_fin_is_monotonic with u; auto.
  now apply env_leq_union.
Qed.

Variable sigma : eqn_sys.

Lemma F_is_monotonic :
  forall (u1 u2 : Env),
    env_leq u1 u2 ->
    env_leq (F sigma u1) (F sigma u2).
Proof.
  intros u1 u2 Hu1u2.
  unfold env_leq.
  intros v i j theta theta' x.
  unfold F.
  intro H;
  destruct H as [H | H].
  - left;
  now apply models_fin_is_monotonic with u1.
  - now right.
Qed.

Lemma F_is_continuous_1st_half :
  forall (s : Ensemble Env),
    (exists u, In Env s u) (* non-empty *) ->
    env_leq (F sigma (env_union s)) (env_union (Ens_map (F sigma) s)).
Proof.
  intros s Hnonemp.
  unfold env_leq.
  intros v i j theta theta' x H.
  inversion H as [Hm | Hf].
  - (* When (i,theta;j,theta',x |= sigma v) *)
  apply models_fin_is_continuous in Hm; auto.
  destruct Hm as [u [Hin Hm]].
  apply env_union_intro with (F sigma u).
  + now apply Ens_map_intro.
  + unfold F;
  now left.
  - (* When Var_omega v *)
  destruct Hnonemp as [u Hin].
  apply env_union_intro with (F sigma u).
  + now apply Ens_map_intro.
  + unfold F;
  now right.
Qed.

Lemma F_is_continuous_2nd_half :
  forall (s : Ensemble Env),
    (exists u, In Env s u) (* non-empty *) ->
    env_leq (env_union (Ens_map (F sigma) s)) (F sigma (env_union s)).
Proof.
  intros s Hnonemp.
  unfold env_leq.
  intros v i j theta theta' x H.
  inversion_clear H as [s1 u Hin v1 i1 j1 t1 t2 x1 Hu].
  inversion Hin as [f s1 u1 Hin1 EQf EQs1 EQu1].
  rewrite <- EQu1 in Hu.
  unfold F;
  unfold F in Hu.
  destruct Hu as [Hu | Hu]; [left | right]; auto.
  apply models_fin_is_monotonic with u1;
  auto.
  now apply env_leq_union.
Qed.

Theorem F_is_continuous :
  forall (s : Ensemble Env),
    (exists u, In Env s u) (* non-empty *) ->
    env_leq (F sigma (env_union s)) (env_union (Ens_map (F sigma) s)) /\
    env_leq (env_union (Ens_map (F sigma) s)) (F sigma (env_union s)).
Proof.
  intros s Hnonemp.
  split.
  - now apply F_is_continuous_1st_half.
  - now apply F_is_continuous_2nd_half.
Qed.

End Continuities.

Section LeastFixedPoint.

Variable sigma : eqn_sys.

Inductive all_Fpow : Ensemble Env :=
  all_Fpow_intro :
    forall ell : nat, In Env all_Fpow (Fpow_emp sigma ell).

Definition lfpF : Env := env_union all_Fpow.

Lemma lfpF_is_upperbound_Fpow :
  forall ell v i j theta theta' x,
  Fpow_emp sigma ell v i j theta theta' x ->
  lfpF v i j theta theta' x.
Proof.
  intros ell v i j theta theta' x H.
  unfold lfpF.
  apply env_union_intro with (Fpow_emp sigma ell); auto.
  apply all_Fpow_intro.
Qed.

Theorem lfpF_is_sup_Fpow :
  forall v i j theta theta' x,
  lfpF v i j theta theta' x <->
  exists ell,
  Fpow_emp sigma ell v i j theta theta' x.
Proof.
  intros v i j theta theta' x.
  split; intro H.
  - (* -> *)
  unfold lfpF in H.
  inversion_clear H as [s u Hin v1 i1 j1 t1 t2 x1 Hu].
  inversion Hin as [ell EQu].
  exists ell.
  now rewrite EQu.
  - (* <- *)
  destruct H as [ell H].
  now apply lfpF_is_upperbound_Fpow with ell.
Qed.

End LeastFixedPoint.

(* Syntactical assumptions *)

(* The meaning of Vtt *)
Axiom sigma_Vtt : forall sigma : eqn_sys,
  sigma Vtt = (φ [tt]).

Axiom tt_Vtt_or_Var_omega :
  forall (sigma : eqn_sys) (v : Var),
  sigma v = (φ [tt]) ->
  v = Vtt \/ Var_omega v.

Axiom sigma_injective_on_Var_omega :
  forall (sigma : eqn_sys) (v1 v2 : Var),
  Var_omega v1 ->
  sigma v1 = sigma v2 -> v1 = v2.

(* Normalized LTL formulas *)

Inductive isNormal : ltl -> Prop :=
  | isNormal_OR : forall v v' : Var,
      isNormal (var v .\/ var v')
  | isNormal_STORE_X :
      forall R (v : Var) (phi : ltl_phi),
      isNormal (↓ R ,X (var v) ../\ phi)
  | isNormal_TT :
      isNormal (φ [tt])
  .


Require Import PArith.
Require Import ZArith.
Require Import FunctionalExtensionality.
Require Import ClassicalFacts.
Require Import Relations.
Require Import RelationClasses.
Require Import EquivDec.
Require Import List.
From sflib Require Import sflib.

Require Import PromisingArch.lib.Basic.

Set Implicit Arguments.

Class orderC (A:Type) (EQ LE: relation A) (join: forall (a b:A), A) (bot: A) `{_: PartialOrder A EQ LE} := mk {
  join_l: forall a b, LE a (join a b);
  join_r: forall a b, LE b (join a b);
  join_assoc: forall a b c, EQ (join (join a b) c) (join a (join b c));
  join_comm: forall a b, EQ (join a b) (join b a);
  join_spec:
    forall a b c
      (AC: LE a c)
      (BC: LE b c),
      LE (join a b) c;

  bot_spec: forall a, LE bot a;
}.

Definition ifc (A:Type) `{_: orderC A} (cond:bool) (a:A): A :=
  if cond then a else bot.

Definition joins (A:Type) `{_: orderC A} (l:list A): A :=
  List.fold_right join bot l.

Lemma join_le (A:Type) (eq le:relation A) `{_: orderC A eq le}
      a b c d
      (AC: le a c)
      (BD: le b d):
  le (join a b) (join c d).
Proof.
  apply join_spec.
  - etrans; eauto using join_l.
  - etrans; eauto using join_r.
Qed.

Lemma bot_join (A:Type) (eq le: relation A) `{_: orderC A eq le}
      a:
  eq (join a bot) a.
Proof.
  antisym.
  - eapply join_spec; eauto.
    + refl.
    + apply bot_spec.
  - eapply join_l.
Qed.

Lemma joins_le A (eq le: relation A) `{_: orderC A eq le}
      (a:A) (l:list A)
      (IN: In a l):
  le a (joins l).
Proof.
  revert IN. induction l; ss. i. des.
  - subst. apply join_l.
  - etrans; eauto. apply join_r.
Qed.

Lemma joins_spec A (eq le: relation A) `{_: orderC A eq le}
      (l:list A) (b:A)
      (LE: forall a (IN: In a l), le a b):
  le (joins l) b.
Proof.
  revert LE. induction l; ss.
  { i. apply bot_spec. }
  i. apply join_spec.
  - apply LE. left. ss.
  - apply IHl. auto.
Qed.

Lemma le_join_l A (eq le: relation A) `{_: orderC A eq le}
      (a b: A)
      (LE: le b a):
  eq (join a b) a.
Proof.
  antisym.
  - apply join_spec; ss. refl.
  - apply join_l.
Qed.

Lemma le_join_r A (eq le: relation A) `{_: orderC A eq le}
      (a b: A)
      (LE: le a b):
  eq (join a b) b.
Proof.
  antisym.
  - apply join_spec; ss. refl.
  - apply join_r.
Qed.

Definition equiv (A:Type) `{_: Equivalence A} := R.
Definition le (A:Type) `{_: orderC A} := LE.
Definition join (A:Type) `{_: orderC A} := join.
Definition bot (A:Type) `{_: orderC A} := bot.

Definition fun_add A B `{_: EqDec A} (a:A) (b:B) (f:A -> B): A -> B :=
  fun x => if x == a then b else f x.
#[export]
Hint Unfold fun_add: core.

Lemma fun_add_spec A B `{_: EqDec A} a (b:B) f x:
  (fun_add a b f) x = if x == a then b else f x.
Proof. refl. Qed.

Definition fun_eq A B `{_: Equivalence B} (f g: A -> B): Prop :=
  forall a, R (f a) (g a).
#[export]
Hint Unfold fun_eq: core.

Definition fun_le A B `{_: orderC B} (f g: A -> B): Prop :=
  forall a, LE (f a) (g a).
#[export]
Hint Unfold fun_le: core.

Definition fun_join A B `{_: orderC B} (f g: A -> B) :=
  fun a => join (f a) (g a).
#[export]
Hint Unfold fun_join: core.

Definition fun_bot A B `{_: orderC B} := fun (_:A) => bot.
#[export]
Hint Unfold fun_bot: core.

#[export]
Program Instance fun_equiv A B `{_: Equivalence B}: Equivalence (fun_eq (A:=A) (B:=B)).
Next Obligation. ii. refl. Qed.
Next Obligation. ii. symmetry. ss. Qed.
Next Obligation. ii. etrans; eauto. Qed.

#[export]
Program Instance fun_preorder A B `{_: orderC B}: PreOrder (fun_le (A:=A) (B:=B)).
Next Obligation. ii. refl. Qed.
Next Obligation. ii. etrans; eauto. Qed.

#[export]
Program Instance fun_partialorder A B `{_: orderC B}: @PartialOrder (A -> B) (fun_eq (A:=A) (B:=B)) _ (fun_le (A:=A) (B:=B)) _.
Next Obligation.
  econs.
  - econs; ii.
    + eapply (H (x a)) in H1. inv H1. ss.
    + eapply (H (x a)) in H1. inv H1. ss.
  - ii. antisym; apply H1.
Qed.

#[export]
Program Instance fun_order A B `{_: orderC B}:
  @orderC
    (A -> B)
    (fun_eq (A:=A) (B:=B))
    (fun_le (A:=A) (B:=B))
    (fun_join (A:=A) (B:=B))
    (fun_bot (A:=A) (B:=B))
    (fun_equiv A)
    (fun_preorder A)
    (fun_partialorder (A:=A) (B:=B)).
Next Obligation.
  unfold fun_le, fun_join, fun_bot.
  ii. apply join_l.
Qed.
Next Obligation.
  unfold fun_le, fun_join, fun_bot.
  ii. apply join_r.
Qed.
Next Obligation.
  unfold fun_eq, fun_le, fun_join, fun_bot.
  i. eauto using join_assoc.
Qed.
Next Obligation.
  unfold fun_eq, fun_le, fun_join, fun_bot.
  i. eauto using join_comm.
Qed.
Next Obligation.
  unfold fun_eq, fun_le, fun_join, fun_bot.
  eauto using join_spec.
Qed.
Next Obligation.
  unfold fun_eq, fun_le, fun_join, fun_bot.
  eauto using bot_spec.
Qed.

#[export]
Program Instance fun_eq_partialorder A B `{_: orderC B eq}: @PartialOrder (A -> B) eq _ (fun_le (A:=A) (B:=B)) _.
Next Obligation.
  econs.
  - i. subst. econs; refl.
  - i. funext. i. antisym; apply H1.
Qed.

#[export]
Program Instance fun_eq_order A B `{_: orderC B eq}:
  @orderC
    (A -> B)
    eq
    (fun_le (A:=A) (B:=B))
    (fun_join (A:=A) (B:=B))
    (fun_bot (A:=A) (B:=B))
    eq_equivalence
    (fun_preorder A)
    (fun_eq_partialorder (A:=A) (B:=B)).
Next Obligation.
  unfold fun_le, fun_join, fun_bot.
  ii. apply join_l.
Qed.
Next Obligation.
  unfold fun_le, fun_join, fun_bot.
  ii. apply join_r.
Qed.
Next Obligation.
  unfold fun_le, fun_join, fun_bot.
  funext. eauto using join_assoc.
Qed.
Next Obligation.
  unfold fun_le, fun_join, fun_bot.
  funext. eauto using join_comm.
Qed.
Next Obligation.
  unfold fun_le, fun_join.
  eauto using join_spec.
Qed.
Next Obligation.
  unfold fun_le, fun_join, fun_bot.
  eauto using bot_spec.
Qed.

Inductive opt_eq X `{_: Equivalence X}: forall (a b: option X), Prop :=
| opt_eq_None: opt_eq None None
| opt_eq_Some a b (EQX: equiv a b): opt_eq (Some a) (Some b)
.
#[export]
Hint Constructors opt_eq: core.

Inductive opt_le X `{_: orderC X}: forall (a b: option X), Prop :=
| opt_le_None b: opt_le None b
| opt_le_Some a b (LEX: le a b): opt_le (Some a) (Some b)
.
#[export]
Hint Constructors opt_le: core.

Definition opt_join X `{_: orderC X}(a b:option X) :=
  match a, b with
  | None, _ => b
  | _, None => a
  | Some a, Some b => Some (join a b)
  end.
#[export]
Hint Unfold opt_join: core.

Definition opt_bot X `{_: orderC X}: option X := None.
#[export]
Hint Unfold opt_bot: core.

#[export]
Program Instance opt_equiv X `{_: Equivalence X}: Equivalence (opt_eq (X:=X)).
Next Obligation. ii. destruct x; eauto. econs. refl. Qed.
Next Obligation. ii. inv H0; eauto. econs. symmetry. ss. Qed.
Next Obligation. ii. inv H0; inv H1; eauto. econs. etrans; eauto. Qed.

#[export]
Program Instance opt_eqdec X `{_: EqDec X eq}: EqDec (option X) eq.
Next Obligation.
  destruct x, y;
    (try by left);
    (try by right; i; ss).
  destruct (H x x0).
  - left. f_equal. ss.
  - right. intro Y. inv Y. intuition.
Defined.

#[export]
Program Instance opt_preorder X `{_: orderC X}: PreOrder (opt_le (X:=X)).
Next Obligation. ii. destruct x; eauto. econs. refl. Qed.
Next Obligation. ii. inv H1; inv H2; eauto. econs. etrans; eauto. Qed.

#[export]
Program Instance opt_partialorder X `{_: orderC X}: PartialOrder (opt_eq (X:=X)) (opt_le (X:=X)).
Next Obligation.
  econs.
  - i. inv H1.
    + econs; ss.
    + econs; econs; rewrite EQX; refl.
  - i. inv H1. inv H2; inv H3; econs. antisym; eauto.
Qed.

#[export]
Program Instance opt_order X `{_: orderC X}:
  @orderC
    (option X)
    (opt_eq (X:=X))
    (opt_le (X:=X))
    (opt_join (X:=X))
    (opt_bot (X:=X))
    (opt_equiv)
    (opt_preorder)
    (opt_partialorder (X:=X)).
Next Obligation.
  destruct a, b; ss; econs.
  - apply join_l.
  - refl.
Qed.
Next Obligation.
  destruct a, b; ss; econs.
  - apply join_r.
  - refl.
Qed.
Next Obligation.
  destruct  a, b, c; econs; try by refl.
  apply join_assoc.
Qed.
Next Obligation.
  destruct  a, b; econs; try by refl.
  apply join_comm.
Qed.
Next Obligation.
  inv AC; inv BC; econs; eauto. apply join_spec; ss.
Qed.
Next Obligation.
  econs.
Qed.

Definition prop_le (a b:Prop): Prop := a -> b.

Definition prop_join (a b:Prop): Prop := a \/ b.

Definition prop_bot: Prop := False.

#[export]
Program Instance prop_preorder: PreOrder prop_le.
Next Obligation. ii. ss. Qed.
Next Obligation. ii. auto. Qed.

#[export]
Program Instance prop_partialorder: PartialOrder eq prop_le.
Next Obligation.
  econs.
  - i. inv H. econs; ss.
  - i. inv H. propext. econs; eauto.
Qed.

#[export]
Program Instance prop_order:
  @orderC
    Prop
    eq
    prop_le
    prop_join
    prop_bot
    eq_equivalence
    prop_preorder
    prop_partialorder.
Next Obligation.
  unfold prop_le, prop_join, prop_bot in *.
  intuition.
Qed.
Next Obligation.
  unfold prop_le, prop_join, prop_bot in *.
  intuition.
Qed.
Next Obligation.
  unfold prop_le, prop_join, prop_bot in *.
  propext. intuition.
Qed.
Next Obligation.
  unfold prop_le, prop_join, prop_bot in *.
  propext. intuition.
Qed.
Next Obligation.
  unfold prop_le, prop_join, prop_bot in *.
  intuition.
Qed.
Next Obligation.
  unfold prop_le, prop_join, prop_bot in *.
  intuition.
Qed.

Definition bool_le (a b:bool): Prop := a -> b.

Definition bool_join (a b:bool): bool := a || b.

Definition bool_bot: bool := false.

#[export]
Program Instance bool_preorder: PreOrder bool_le.
Next Obligation. ii. ss. Qed.
Next Obligation. ii. auto. Qed.

#[export]
Program Instance bool_partialorder: PartialOrder eq bool_le.
Next Obligation.
  unfold bool_le in *.
  econs.
  - i. inv H. econs; ss.
  - i. inv H. destruct x, x0; intuition.
Qed.

#[export]
Program Instance bool_order:
  @orderC
    bool
    eq
    bool_le
    bool_join
    bool_bot
    eq_equivalence
    bool_preorder
    bool_partialorder.
Next Obligation.
  unfold bool_le, bool_join, bool_bot in *.
  destruct a, b; intuition.
Qed.
Next Obligation.
  unfold bool_le, bool_join, bool_bot in *.
  destruct a, b; intuition.
Qed.
Next Obligation.
  unfold bool_le, bool_join, bool_bot in *.
  destruct a, b, c; intuition.
Qed.
Next Obligation.
  unfold bool_le, bool_join, bool_bot in *.
  destruct a, b; intuition.
Qed.
Next Obligation.
  unfold bool_le, bool_join, bool_bot in *.
  destruct a, b, c; intuition.
Qed.

Definition unit_le (a b:unit): Prop := True.

Definition unit_join (a b:unit): unit := tt.

Definition unit_bot: unit := tt.

#[export]
Program Instance unit_preorder: PreOrder unit_le.
Next Obligation. ii. ss. Qed.

#[export]
Program Instance unit_partialorder: PartialOrder eq unit_le.
Next Obligation.
  ii. econs; ss. destruct x, x0; ss.
Qed.

#[export]
Program Instance unit_order:
  @orderC
    unit
    eq
    unit_le
    unit_join
    unit_bot
    eq_equivalence
    unit_preorder
    unit_partialorder.
Next Obligation.
  unfold unit_le, unit_join, unit_bot in *.
  destruct a, b; intuition.
Qed.
Next Obligation.
  unfold unit_le, unit_join, unit_bot in *.
  destruct a, b; intuition.
Qed.
Next Obligation.
  unfold unit_le, unit_join, unit_bot in *.
  ss.
Qed.


(**
CoqTL user theorem: Attribute_name_preservation
Def: all non-derived attributes in the source model will create
    a column in the target model with the same name
**)

Require Import String.
Require Import Lia.
Require Import core.utils.Utils.
Require Import core.Model.
Require Import core.Semantics.
Require Import core.Certification.

Require Import transformations.Class2Relational.Class2Relational.
Require Import transformations.Class2Relational.ClassMetamodel.
Require Import transformations.Class2Relational.RelationalMetamodel.

Theorem Attribute_name_preservation:
    forall (rm : RelationalModel) (cm: ClassModel),
        (* transformation *)
        rm = execute Class2Relational cm ->
        (* postcondition *)
        forall (a: Attribute),
        In (ClassMetamodel_toObject AttributeClass a) (allModelElements cm) ->
        getAttributeDerived a = false ->
        exists (c: Column),
            In (RelationalMetamodel_toObject ColumnClass c) (allModelElements rm) /\
            getColumnName c = getAttributeName a.
Proof.
    intros.
    exists (BuildColumn (getAttributeId a) (getAttributeName a)).
    split.
    - rewrite H.
      rewrite (tr_execute_in_elements Class2Relational).
      exists ([ClassMetamodel_toObject AttributeClass a]).
      split.
      + apply allTuples_incl_length.
        * unfold incl.
          intros.
          apply in_inv in H2.
          destruct H2.
          -- rewrite <- H2. assumption.
          -- contradiction.
        * unfold maxArity. simpl. lia.
      + destruct a.
        simpl in H1.
        rewrite H1.
        simpl.
        left.
        reflexivity.
    - reflexivity.
Qed.


(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Arith.Arith Coq.Logic.Eqdep_dec Coq.Vectors.Vector Coq.micromega.Lia
     Coq.NArith.NArith Coq.Strings.String Coq.NArith.Ndigits.
Require Import Cava.Arrow.ArrowExport
     Cava.BitArithmetic Cava.VectorUtils.
Require Import Cava.Tactics.

Require Import Aes.Pkg Aes.SboxCanrightPkg.

Import VectorNotations.
Import KappaNotation.
Open Scope kind_scope.

(* function automatic logic [3:0] aes_inverse_gf2p4(logic [3:0] gamma);
  logic [3:0] delta;
  logic [1:0] a, b, c, d;
  a          = gamma[3:2] ^ gamma[1:0];
  b          = aes_mul_gf2p2(gamma[3:2], gamma[1:0]);
  c          = aes_scale_omega2_gf2p2(aes_square_gf2p2(a));
  d          = aes_square_gf2p2(c ^ b);
  delta[3:2] = aes_mul_gf2p2(d, gamma[1:0]);
  delta[1:0] = aes_mul_gf2p2(d, gamma[3:2]);
  return delta;
endfunction *)
Program Definition aes_inverse_gf2p4
  : <<Vector Bit 4, Unit>> ~> (Vector Bit 4) :=
  <[\ gamma =>
      let a = (gamma[:3:2]) ^ (gamma[:1:0]) in
      let b = !aes_mul_gf2p2 (gamma[:3:2]) (gamma[:1:0]) in
      let c = !aes_scale_omega2_gf2p2 (!aes_square_gf2p2 a) in
      let d = !aes_square_gf2p2 (c ^ b) in
      concat
        (!aes_mul_gf2p2 d (gamma[:3:2]))
        (!aes_mul_gf2p2 d (gamma[:1:0]))
  ]>.

  (* // Inverse in GF(2^8), using normal basis [d^16, d]
  // (see Figure 11 in the technical report)
  function automatic logic [7:0] aes_inverse_gf2p8(logic [7:0] gamma);
    logic [7:0] delta;
    logic [3:0] a, b, c, d;
    a          = gamma[7:4] ^ gamma[3:0];
    b          = aes_mul_gf2p4(gamma[7:4], gamma[3:0]);
    c          = aes_square_scale_gf2p4_gf2p2(a);
    d          = aes_inverse_gf2p4(c ^ b);
    delta[7:4] = aes_mul_gf2p4(d, gamma[3:0]);
    delta[3:0] = aes_mul_gf2p4(d, gamma[7:4]);
    return delta;
  endfunction *)
Definition aes_inverse_gf2p8
  :  <<Vector Bit 8, Unit>> ~> (Vector Bit 8) :=
  <[\ gamma =>
      let a = (gamma[:7:4]) ^ (gamma[:3:0]) in
      let b = !aes_mul_gf2p4 (gamma[:7:4]) (gamma[:3:0]) in
      let c = !aes_square_scale_gf2p4_gf2p2 a in
      let d = !aes_inverse_gf2p4 (c ^ b) in

      concat
        (!aes_mul_gf2p4 d (gamma[:7:4]))
        (!aes_mul_gf2p4 d (gamma[:3:0]))
  ]>.

(* module aes_sbox_canright (
  input  aes_pkg::ciph_op_e op_i,
  input  logic [7:0]        data_i,
  output logic [7:0]        data_o
); *)
Definition aes_sbox_canright
  :  << Bit, Vector Bit 8, Unit>> ~> (Vector Bit 8) :=
  <[\ op_i data_i =>
      (* // Convert to normal basis X.
      assign data_basis_x = (op_i == CIPH_FWD) ? aes_mvm(data_i, A2X) :
                                                aes_mvm(data_i ^ 8'h63, S2X); *)
      let data_basis_x = if op_i == !CIPH_FWD
                        then !aes_mvm data_i !A2X
                        else !aes_mvm (data_i ^ #99) !S2X in

      (* // Do the inversion in normal basis X.
      assign data_inverse = aes_inverse_gf2p8(data_basis_x); *)
      let data_inverse = !aes_inverse_gf2p8 data_basis_x in

      (* // Convert to basis S or A.
      assign data_o       = (op_i == CIPH_FWD) ? aes_mvm(data_inverse, X2S) ^ 8'h63 :
                                                aes_mvm(data_inverse, X2A);  *)
      let data_o = if op_i == !CIPH_FWD
                  then (!aes_mvm data_inverse !X2S) ^ #99
                  else !aes_mvm data_inverse !X2A in

      data_o
  ]>.

Definition canright_composed
  :  << Vector Bit 8, Unit>> ~> (Vector Bit 8) :=
  <[\input =>
  let encoded = !aes_sbox_canright !CIPH_FWD input in
  let decoded = !aes_sbox_canright !CIPH_INV encoded in
  decoded ]>.

Lemma canright_composed_combinational: is_combinational (closure_conversion aes_sbox_canright).
Proof. time simply_combinational. Qed.

Local Notation "# x" := (nat_to_bitvec_sized 8 x) (at level 99).

Goal kinterp canright_composed (# 0, tt) = (# 0).
Proof. time (vm_compute; auto). Qed.

(* TODO(blaxill): reduced bound for CI time *)
Goal forall x, x < 100 ->
kinterp canright_composed (#x, tt) = (#x).
Proof. time (repeat (lia || destruct x); now vm_compute). Qed.


(** * A tree with data *)
Require Export Recdef.
Require Export CommonDefinitions.

Section tree.
  Variable node_data : Type.
  Variable leaf_data : Type.

  Inductive tree :=
  | Leaf : leaf_data -> tree
  | Node : tree -> node_data -> option tree -> tree.

  Fixpoint map_nodes_with_data
           (data : tree -> option tree -> node_data)
           (l : list tree)
  : list tree
    := match l with
         | nil => nil
         | x::nil => (Node x
                           (data x None)
                           None)::nil
         | x::y::rest => (Node x
                               (data x (Some y))
                               (Some y))
                           ::map_nodes_with_data data rest
       end.

  Fixpoint list_rect' {A} l (P : list A -> Type)
        (H0 : P nil)
        (H1 : forall x, P nil -> P (x::nil))
        (H2 : forall x y rest, P rest -> P (x::y::rest))
  : P l
    := match l as l return P l with
         | nil => H0
         | x::nil => H1 _ H0
         | x::y::rest => H2 x y rest (@list_rect' _ rest P H0 H1 H2)
       end.

  Lemma map_nodes_with_data_length data x y rest
  : List.length (map_nodes_with_data data (x::y::rest)) < List.length (x::y::rest).
  Proof.
    eapply (@list_rect' _ rest); simpl.
    - repeat constructor.
    - intros; repeat constructor.
    - intros. apply lt_S_n in H.
      repeat apply lt_n_S.
      etransitivity; try eassumption.
      auto.
  Defined.

  Function list_to_tree_helper data (l : list tree) {measure List.length l}
  : option tree
    := match map_nodes_with_data data l with
         | nil => None
         | x::nil => Some x
         | l' => list_to_tree_helper data l'
       end.
  Proof.
    intros.
    subst.
    destruct l as [|?[|?[|?[ ]]]];
    try solve [ inversion_clear teq; auto ].
    rewrite <- teq.
    apply map_nodes_with_data_length.
  Defined.

  Definition list_to_tree data (l : list leaf_data)
  : option tree
    := list_to_tree_helper data (map Leaf l).
End tree.


From Coq Require Export Bool.Bool.
From Coq Require Export Init.Nat.
From Coq Require Export Arith.Arith.
From Coq Require Export Arith.EqNat.
From Coq Require Export Lia.
From Coq Require Export Lists.List.
From Coq Require Export Strings.String.

Definition FILL_IN_HERE {T: Type} : T.  Admitted.

Inductive ev : nat -> Prop :=
| ev_0 : ev 0
| ev_SS (n : nat) (H : ev n) : ev (S (S n)).

Inductive le : nat -> nat -> Prop :=
  | le_n (n : nat)                : le n n
  | le_S (n m : nat) (H : le n m) : le n (S m).

Notation "n <= m" := (le n m).

Inductive subseq {X: Type}: list X -> list X -> Prop :=
| empty : forall l, subseq nil l
| cons_right : forall x l1 l2, subseq l1 l2 -> subseq l1 (x :: l2)
| cons_both : forall x l1 l2, subseq l1 l2 -> subseq (x :: l1) (x :: l2).

Inductive aexp : Type :=
  | ANum (n : nat)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp).

Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BNot (b : bexp)
  | BAnd (b1 b2 : bexp).

Fixpoint aeval (a : aexp) : nat :=
  match a with
  | ANum n => n
  | APlus  a1 a2 => (aeval a1) + (aeval a2)
  | AMinus a1 a2 => (aeval a1) - (aeval a2)
  | AMult  a1 a2 => (aeval a1) * (aeval a2)
  end.

Fixpoint beval (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => (aeval a1) =? (aeval a2)
  | BLe a1 a2   => (aeval a1) <=? (aeval a2)
  | BNot b1     => negb (beval b1)
  | BAnd b1 b2  => andb (beval b1) (beval b2)
  end.

Fixpoint optimize_1mult (a:aexp) : aexp :=
  match a with
  | ANum n =>
      ANum n
  | APlus e1 e2 =>
      APlus (optimize_1mult e1) (optimize_1mult e2)
  | AMinus e1 e2 =>
      AMinus (optimize_1mult e1) (optimize_1mult e2)
  | AMult (ANum 1) e2 =>
      optimize_1mult e2
  | AMult e1 (ANum 1) =>
      optimize_1mult e1
  | AMult e1 e2 =>
      AMult (optimize_1mult e1) (optimize_1mult e2)
  end.

Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum n :
      aevalR (ANum n) n
  | E_APlus (e1 e2: aexp) (n1 n2: nat) :
      aevalR e1 n1 ->
      aevalR e2 n2 ->
      aevalR (APlus e1 e2) (n1 + n2)
  | E_AMinus (e1 e2: aexp) (n1 n2: nat) :
      aevalR e1 n1 ->
      aevalR e2 n2 ->
      aevalR (AMinus e1 e2) (n1 - n2)
  | E_AMult (e1 e2: aexp) (n1 n2: nat) :
      aevalR e1 n1 ->
      aevalR e2 n2 ->
      aevalR (AMult e1 e2) (n1 * n2).

Theorem aeval_iff_aevalR : forall a n,
  (aevalR a n) <-> aeval a = n.
Proof.
  (* WORKED IN CLASS *)
  split.
  - (* -> *)
    intros H; induction H; subst; reflexivity.
  - (* <- *)
    generalize dependent n.
    induction a; simpl; intros; subst; constructor;
       try apply IHa1; try apply IHa2; reflexivity.
Qed.


Require Export Utf8_core.
Require Export Classical.

Fact all_iff_ex_1 : ∀ {A : Type} (P : A → Prop) (Q : Prop),
  (∀ x, (P x → Q)) ↔ ((∃ x, P x) → Q).
Proof.
  intros A P Q. split.
  - intros H [x Hpx]. apply (H x Hpx).
  - intros H x Hpx. apply H. exists x. apply Hpx.
Qed.

Fact all_iff_ex_2 : ∀ {A : Type} (P : A → Prop) (Q : Prop),
  (∃ x, P x → Q) ↔ (inhabited A ∧ ((∀ x, P x) → Q)).
Proof.
  intros A P Q. split.
  - intros [x H]. split.
    + exact (inhabits x).
    + intros Hpx. apply H. apply Hpx.
  - intros [[a] H].
    destruct (classic (∀ x, P x)) as [Hpx|Hnx].
    + exists a. intros Ha. apply H. apply Hpx.
    + apply not_all_ex_not in Hnx as [x Hnx].
      exists x. intros Hx. exfalso. apply Hnx. apply Hx.
Qed.

Axiom rule : ∀ {A : Type} (P : A → Prop) (Q : Prop),
  (Q ∨ ∃ y, P y) → ∃ x, Q ∨ P x.

Fact all_iff_ex_2' : ∀ {A : Type} (P : A → Prop) (Q : Prop),
  (∃ x, P x → Q) ↔ (((∀ x, P x) → Q)).
Proof.
  intros A P Q. split.
  - intros [x H] Hx. apply H. apply Hx.
  - intros H.
    destruct (classic (∀ x, P x)) as [Hpx|Hnx].
    + destruct (rule P Q) as [a [Hq|_]]. {
        left. apply H. apply Hpx.
      }
      * exists a. intros _. apply Hq.
      * exists a. intros _. apply H. apply Hpx.
    + apply not_all_ex_not in Hnx as [x Hnx].
      exists x. intros Hx. exfalso. apply Hnx. apply Hx.
Qed.

(* 命题“存在x:A满足P”定义为满足以下条件的类型ex A P :=
∀ x:A, (P x → ex A P)
这个定义的意思是说，对于任意一个x:A，如果它满足P，你就能得到ex A P
如果你真的有一个这样的x，那么你也就得到了ex A P，也就证明了语义上的
∃ x:A, P x.
实际上，在软件里，∃ x:A, P x 只是 ex A P 的另一种表示而已。
如果你并没有x:A满足P，空有∀ x:A, (P x → ex A P) 是永远无法得到ex A P的
但是你一旦真的有了，用∀ x:A, (P x → ex A P) 这个定义就能得到ex A P *)

Inductive ex (A : Type) (P : A → Prop) : Prop :=
  ex_intro : ∀ x, (P x → ex A P).

Axiom A : Type.
Axiom a : A.

Fact ex_test : ∀ (P : A → Prop) (Q : Prop),
  P a → ex A P.
Proof.
  intros P Q Hpa.
  exact (ex_intro A P a Hpa).
Qed.

Lemma test : ∀ {A : Type} (R : A → Prop) (S : A → Prop),
  ((∀ y, R y) ∧ (∃ y, S y)) → ∃ y, (R y ∧ S y).
Proof.
  firstorder.
Qed.


Require Export P03.

(** **** Problem #4 : 1 star (zero_nbeq_plus_1) *)

(* See the base file for the definition of [beq_nat]. *)

Theorem zero_nbeq_plus_1 : forall n : nat,
  beq_nat 0 (n + 1) = false.
Proof.
  intros n.
  destruct n as [|n'].
  - reflexivity.
  - reflexivity.
Qed.


(* Это многострочный комментарий
В нём нужно соблюдать парность кавычек строковых литералов
Многострочные комментарии могут быть вложены
*)

(*
Тип-перечисление day
Состоит из перечисления вариантов.
Заканчивается точкой (точку можно поставить на отдельной строке, чтобы обратить на неё внимание).
*)

Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

(* Определяем функцию для работы с днями
В Coq есть вывод типов, поэтому типы явно указывать не надо

Сопоставление с образцом выведет ошибку, если предусмотрены не все варианты
*)
Definition next_weekday (d:day) : day :=
  match d with
  | monday    => tuesday
  | tuesday   => wednesday
  | wednesday => thursday
  | thursday  => friday
  | friday    => saturday
  | saturday  => sunday
  | sunday    => monday
  end
  .

(*
Определяем некорректную функцию next_weekday
*)
Definition next_weekday_incorrect (d:day) : day :=
  match d with
  | monday    => tuesday
  | tuesday   => wednesday
  | wednesday => thursday
  | thursday  => friday
  | friday    => monday
  | saturday  => monday
  | sunday    => monday
  end
  .

(*
Значение функции можно вычислить с помощью Compute
Оно будет выведено на консоль CoqIDE
Вызов идёт без скобок: сначала имя функции, потом параметры, например:
next_weekday friday

Однако, если нужно получить значение этой функции, то её берут в скобки,
так что это становится на синтаксис Lisp
 *)
Compute (next_weekday friday).

(*
Example - это пример
Он имеет имя
По сути, он является утверждением, которое можно по этому имени, например, доказать
То есть на него затем можно ссылаться по имени
*)
Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = monday
  .

(* Доказываем *)
Proof. simpl. reflexivity. Qed.

(*
Следующее утверждение даст ошибку при доказаетльстве
Unable to unify "monday" with "wednesday".
     = saturday
     : day
*)

(*
Example test_next_weekday_incorrect:
  (next_weekday_incorrect (next_weekday_incorrect saturday)) = monday.

(* Доказываем то, что неверно и получаем ошибку *)
Proof. simpl. reflexivity. Qed.
*)

(*
Если написать только один раз в конце программы
Proof. simpl. reflexivity. Qed.
то выдастся ошибка

Nested proofs are not allowed unless you turn the Nested Proofs Allowed flag on.

То есть нужно сначала доказать теоремы выше, а потом уже ниже (или установить возможность вложенных доказательств).
*)

Example test_next_weekday7:
  (next_weekday (next_weekday (next_weekday (next_weekday (next_weekday (next_weekday (next_weekday monday))))))) = monday
  .

Proof. simpl. reflexivity. Qed.

(*
Example test_next_weekday_notequal:
	(next_weekday monday) <> monday
	.

Proof. simpl. reflexivity. Qed.

Example test_next_weekday_incorrect_notequal:
	(next_weekday_incorrect monday) <> monday
	.

Proof. simpl. reflexivity. Qed.
*)

(*
При этом определяем также свой модуль VinBool: в конце определения не забываем точку!
Модуль VinBool заканчивается сторокой End VinBool.
Обращаем внимание на то, что End пишется с большой буквы и точку после имени модуля.

Всё, что внутри модуля, будет доступно теперь через точку: VinBool.bool и т.п.
*)
Module VinBool.

(*
Определяем булевский тип операций (он уже определён в стандартной библиотеке)
*)
Inductive bool : Type :=
  | true
  | false
  .

Definition negb (b:bool) : bool :=
  match b with
  | true  => false
  | false => true
  end
  .

Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true  => b2
  | false => false
  end
  .

Definition orb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true  => true
  | false => b2
  end
  .

(*
Определяем нотацию булевского типа
*)
Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

(*
Ключевое слово "Admitted" оставляет доказательство/определение в исходниках незавершённым (допущение)
В полосе CoqIDE ошибки подсвечиваются красным, а Admitted подсвечивается оранжевым и в ошибках не значится
*)

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.
Example test_andb31: (andb3 true true true) = true.
(* FILL IN HERE *) Admitted.

End VinBool.


Require Export FunctionProperties.
Require Import DecidableDec.
Require Import Description.
Require Import Classical.

Unset Standard Proposition Elimination Names.

(* CSB = Cantor-Schroeder-Bernstein theorem *)

Section CSB.
Variable X Y:Type.
Variable f:X->Y.
Variable g:Y->X.
Hypothesis f_inj: injective f.
Hypothesis g_inj: injective g.

Inductive X_even: X->Prop :=
  | not_g_img: forall x:X, (forall y:Y, g y <> x) -> X_even x
  | g_Y_odd: forall y:Y, Y_odd y -> X_even (g y)
with Y_odd: Y->Prop :=
  | f_X_even: forall x:X, X_even x -> Y_odd (f x).
Inductive X_odd: X->Prop :=
  | g_Y_even: forall y:Y, Y_even y -> X_odd (g y)
with Y_even: Y->Prop :=
  | not_f_img: forall y:Y, (forall x:X, f x <> y) -> Y_even y
  | f_X_odd: forall x:X, X_odd x -> Y_even (f x).

Scheme X_even_coind := Minimality for X_even Sort Prop
  with Y_odd_coind := Minimality for Y_odd Sort Prop.
Scheme X_odd_coind := Minimality for X_odd Sort Prop
  with Y_even_coind := Minimality for Y_even Sort Prop.

Lemma even_odd_excl: forall x:X, ~(X_even x /\ X_odd x).
Proof.
intro.
assert (X_even x -> ~ X_odd x).
2:tauto.
pose proof (X_even_coind (fun x:X => ~ X_odd x) (fun y:Y => ~ Y_even y)).
apply H.
intuition.
destruct H1.
apply H0 with y.
reflexivity.
intuition.
inversion H2.
apply g_inj in H3.
apply H1.
rewrite <- H3.
assumption.
intuition.
inversion H2.
apply H3 with x0.
reflexivity.
apply f_inj in H3.
apply H1.
rewrite <- H3.
assumption.
Qed.

Lemma even_odd_excl2: forall y:Y, ~(Y_even y /\ Y_odd y).
Proof.
intro.
assert (Y_odd y -> ~ Y_even y).
2:tauto.
pose proof (Y_odd_coind (fun x:X => ~ X_odd x) (fun y:Y => ~ Y_even y)).
apply H.
intuition.
destruct H1.
apply H0 with y0.
reflexivity.
intuition.
inversion H2.
apply g_inj in H3.
apply H1.
rewrite <- H3.
assumption.
intuition.
inversion H2.
apply H3 with x.
reflexivity.
apply f_inj in H3.
apply H1.
rewrite <- H3.
assumption.
Qed.

Definition finv: forall y:Y, (exists x:X, f x = y) ->
  { x:X | f x = y }.
intros.
apply constructive_definite_description.
destruct H.
exists x.
red; split.
assumption.
intros.
apply f_inj.
transitivity y; trivial.
symmetry; trivial.
Defined.

Definition ginv: forall x:X, (exists y:Y, g y = x) ->
  { y:Y | g y = x }.
intros.
apply constructive_definite_description.
destruct H.
exists x0.
red; split.
assumption.
intros.
apply g_inj.
transitivity x; trivial; symmetry; trivial.
Defined.

Definition ginv_odd: forall x:X, X_odd x ->
  { y:Y | g y = x }.
intros.
apply ginv.
destruct H.
exists y.
reflexivity.
Defined.

Definition finv_noteven: forall y:Y, ~ Y_even y ->
  { x:X | f x = y }.
intros.
apply finv.
apply NNPP.
red; intro.
contradict H.
constructor 1.
intro; red; intro.
apply H0.
exists x.
assumption.
Defined.

Definition CSB_bijection (x:X) : Y :=
  match (classic_dec (X_odd x)) with
  | left o => proj1_sig (ginv_odd x o)
  | right _ => f x
  end.
Definition CSB_bijection2 (y:Y) : X :=
  match (classic_dec (Y_even y)) with
  | left _ => g y
  | right ne => proj1_sig (finv_noteven y ne)
  end.

Lemma CSB_comp1: forall x:X, CSB_bijection2 (CSB_bijection x) = x.
Proof.
intro.
unfold CSB_bijection; case (classic_dec (X_odd x)).
intro.
destruct ginv_odd.
simpl.
unfold CSB_bijection2; case (classic_dec (Y_even x1)).
intro.
assumption.
intro.
destruct x0.
contradict n.
apply g_inj in e.
rewrite e.
assumption.
intro.
unfold CSB_bijection2; case (classic_dec (Y_even (f x))).
intro.
contradict n.
inversion y.
pose proof (H x).
contradict H1; reflexivity.
apply f_inj in H.
rewrite <- H.
assumption.
intro.
destruct finv_noteven.
simpl.
apply f_inj.
assumption.
Qed.

Lemma CSB_comp2: forall y:Y, CSB_bijection (CSB_bijection2 y) = y.
Proof.
intro.
unfold CSB_bijection2; case (classic_dec (Y_even y)).
intro.
unfold CSB_bijection; case (classic_dec (X_odd (g y))).
intro.
destruct ginv_odd.
simpl.
apply g_inj.
assumption.
intro.
contradict n.
constructor.
assumption.
intro.
destruct finv_noteven.
simpl.
unfold CSB_bijection; case (classic_dec (X_odd x)).
intro.
contradict n.
rewrite <- e.
constructor 2.
assumption.
trivial.
Qed.

Theorem CSB: exists h:X->Y, bijective h.
Proof.
exists CSB_bijection.
apply invertible_impl_bijective.
exists CSB_bijection2.
exact CSB_comp1.
exact CSB_comp2.
Qed.

End CSB.


Definition plus (n : nat)(m : nat) : nat := n + m.
Eval compute in plus 3 5.
Definition id (A : Type)(x : A) : A := x.
Eval compute in id nat 5.

Definition prop0 : forall (A : Prop), A -> A := fun A x => x.
Definition prop1 : forall (A B C : Prop), (B -> C) -> (A -> B) -> (A -> C) :=
  fun A B C f g x => f (g x).
Definition prop2 : forall (A B : Prop), A -> (A -> B) -> B :=
  fun A B x f => f x.
Definition prop3 : forall (A B C : Prop), (A -> B -> C) -> (B -> A -> C) :=
  fun A B C f x y => (f y) x.
Definition prop4 : forall (A : Prop), A -> A.
Proof.
  intros.
  apply H.
Qed.


Require Import Omega.

Lemma foo : forall n m : Z, (n >= 0)%Z -> (n * m >= 0)%Z -> (n <= n + n * m)%Z.
Proof.
  intros. omega.
Qed.

Lemma foo' : forall n m : nat, n <=  n + n * m.
Proof.
  intros. Fail omega.
Abort.


From Coq Require Import List.

Theorem concat_nil_right : forall l : list nat,
  app l nil = l.
Proof. intros. induction l. simpl. reflexivity. simpl. rewrite -> IHl. reflexivity.
  (* FILL IN HERE *)
Qed.


(* ---------------------------------------------------------------------
   This file contains definitions and proof scripts related to
   (i) closure operations for context-free grammars,
   (ii) context-free grammars simplification
   (iii) context-free grammar Chomsky normalization and
   (iv) pumping lemma for context-free languages.

   More information can be found in the paper "Formalization of the
   Pumping Lemma for Context-Free Languages", submitted to JFR.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

Require Import List.

Require Import misc_list.
Require Import cfg.
Require Import cfl.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import ListNotations.

(* --------------------------------------------------------------------- *)
(* CONCATENATION - DEFINITIONS                                           *)
(* --------------------------------------------------------------------- *)

Section Concatenation.

Variables non_terminal_1 non_terminal_2 terminal: Type.

Inductive g_cat_nt: Type:=
| Start_cat
| Transf1_cat_nt: non_terminal_1 -> g_cat_nt
| Transf2_cat_nt: non_terminal_2 -> g_cat_nt.

Lemma nt_eqdec':
 (forall x y: non_terminal_1, {x=y}+{x<>y}) ->
 (forall x y: non_terminal_2, {x=y}+{x<>y}) ->
 (forall x y: g_cat_nt, {x=y}+{x<>y}).
Proof. decide equality. Qed.

Notation sf1:= (list (non_terminal_1 + terminal)).
Notation sf2:= (list (non_terminal_2 + terminal)).
Notation sfc:= (list (g_cat_nt + terminal)).
Notation nlist:= (list g_cat_nt).
Notation tlist:= (list terminal).

Definition g_cat_sf_lift1 (c: non_terminal_1 + terminal): g_cat_nt + terminal:=
  match c with
  | inl nt => inl (Transf1_cat_nt nt)
  | inr t  => inr t
  end.

Definition g_cat_sf_lift2 (c: non_terminal_2 + terminal): g_cat_nt + terminal:=
  match c with
  | inl nt => inl (Transf2_cat_nt nt)
  | inr t  => inr t
  end.

Inductive g_cat_rules (g1: cfg non_terminal_1 terminal) (g2: cfg non_terminal_2 terminal): g_cat_nt -> sfc -> Prop :=
| New_cat: g_cat_rules g1 g2 Start_cat ([inl (Transf1_cat_nt (start_symbol g1))]++[inl (Transf2_cat_nt (start_symbol g2))])
| Lift1_cat: forall nt s,
             rules g1 nt s ->
             g_cat_rules g1 g2 (Transf1_cat_nt nt) (map g_cat_sf_lift1 s)
| Lift2_cat: forall nt s,
             rules g2 nt s ->
             g_cat_rules g1 g2 (Transf2_cat_nt nt) (map g_cat_sf_lift2 s).

Lemma g_cat_finite:
forall g1: cfg non_terminal_1 terminal,
forall g2: cfg non_terminal_2 terminal,
exists n: nat,
exists ntl: list g_cat_nt,
exists tl: tlist,
In Start_cat ntl /\
forall left: g_cat_nt,
forall right: sfc,
g_cat_rules g1 g2 left right ->
(length right <= n) /\
(In left ntl) /\
(forall s: g_cat_nt, In (inl s) right -> In s ntl) /\
(forall s: terminal, In (inr s) right -> In s tl).
Proof.
intros g1 g2.
destruct (rules_finite g1) as [n1 [ntl1 [tl1 H1]]].
destruct (rules_finite g2) as [n2 [ntl2 [tl2 H2]]].
exists (S (S (max n1 n2))), (Start_cat :: (map Transf1_cat_nt ntl1) ++ (map Transf2_cat_nt ntl2)), (tl1 ++ tl2).
split.
- simpl.
  left.
  reflexivity.
- split.
  + inversion H.
    * simpl.
      omega.
    * destruct H1 as [_ H1].
      subst.
      specialize (H1 nt s H0).
      destruct H1 as [H1 _].
      rewrite map_length.
      assert (H3: n1 >= n2 \/ n1 <= n2) by omega.
      {
      destruct H3 as [H3 | H3].
      - apply max_l in H3.
        rewrite H3.
        omega.
      - assert (H3':= H3).
        apply max_r in H3.
        rewrite H3.
        omega.
      }
    * destruct H2 as [_ H2].
      subst.
      specialize (H2 nt s H0).
      destruct H2 as [H2 _].
      rewrite map_length.
      assert (H3: n1 >= n2 \/ n1 <= n2) by omega.
      {
      destruct H3 as [H3 | H3].
      - assert (H3':= H3).
        apply max_l in H3.
        rewrite H3.
        omega.
      - apply max_r in H3.
        rewrite H3.
        omega.
      }
  + split.
    * {
      inversion H.
      - simpl.
        left.
        reflexivity.
      - simpl.
        right.
        apply in_or_app.
        left.
        destruct H1 as [_ H1].
        specialize (H1 nt s H0).
        destruct H1 as [_ [H5 [_ _]]].
        apply in_split in H5.
        destruct H5 as [l1 [l2 H5]].
        rewrite H5.
        rewrite map_app.
        apply in_or_app.
        right.
        simpl.
        left.
        reflexivity.
      - simpl.
        right.
        apply in_or_app.
        right.
        destruct H2 as [_ H2].
        specialize (H2 nt s H0).
        destruct H2 as [_ [H5 [_ _]]].
        apply in_split in H5.
        destruct H5 as [l1 [l2 H5]].
        rewrite H5.
        rewrite map_app.
        apply in_or_app.
        right.
        simpl.
        left.
        reflexivity.
      }
    * {
      split.
      - inversion H.
        + subst.
          intros s H4.
          simpl in H4.
          destruct H4 as [H4 | H4].
          * inversion H4.
            simpl.
            right.
            apply in_or_app.
            left.
            destruct H1 as [H1 _].
            apply in_split in H1.
            destruct H1 as [l1 [l2 H1]].
            rewrite H1.
            rewrite map_app.
            apply in_or_app.
            right.
            simpl.
            left.
            reflexivity.
          * {
            destruct H4 as [H4 | H4].
            - inversion H4.
              simpl.
              right.
              apply in_or_app.
              right.
              destruct H2 as [H2 _].
              apply in_split in H2.
              destruct H2 as [l1 [l2 H2]].
              rewrite H2.
              rewrite map_app.
              apply in_or_app.
              right.
              simpl.
              left.
              reflexivity.
            - contradiction.
            }
        + subst.
          intros s0 H4.
          destruct H1 as [_ H1].
          specialize (H1 nt s H0).
          destruct H1 as [_ [_ [H5 _]]].
          simpl.
          right.
          apply in_or_app.
          left.
          destruct s0.
          * apply in_split in H4.
            destruct H4 as [l1 [l2 H4]].
            symmetry in H4.
            apply map_expand in H4.
            destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
            change (inl Start_cat :: l2) with ([inl Start_cat] ++ l2) in H4'''.
            symmetry in H4'''.
            apply map_expand in H4'''.
            destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
            {
            destruct s1'0.
            - inversion H5''.
            - simpl in H5''.
              inversion H5''.
              destruct s0.
              + simpl in H3.
                inversion H3.
              + simpl in H3.
                inversion H3.
            }
          * assert (H6: In (inl n) s).
              {
              apply in_split in H4.
              destruct H4 as [l1 [l2 H4]].
              symmetry in H4.
              apply map_expand in H4.
              destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
              change (inl (Transf1_cat_nt n) :: l2) with ([inl (Transf1_cat_nt n)] ++ l2) in H4'''.
              symmetry in H4'''.
              apply map_expand in H4'''.
              destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
              destruct s1'0.
              - inversion H5''.
              - inversion H5''.
                destruct s0.
                + simpl in H3.
                  inversion H3.
                  subst.
                  apply in_or_app.
                  right.
                  simpl.
                  left.
                  reflexivity.
                + simpl in H3.
                  inversion H3.
              }
            specialize (H5 n H6).
            apply in_map.
            exact H5.
          * apply in_split in H4.
            destruct H4 as [l1 [l2 H4]].
            symmetry in H4.
            apply map_expand in H4.
            destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
            change (inl (Transf2_cat_nt n) :: l2) with ([inl (Transf2_cat_nt n)] ++ l2) in H4'''.
            symmetry in H4'''.
            apply map_expand in H4'''.
            destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
            {
            destruct s1'0.
            - inversion H5''.
            - simpl in H5''.
              inversion H5''.
              destruct s0.
              + simpl in H3.
                inversion H3.
              + simpl in H3.
                inversion H3.
            }
        + subst.
          intros s0 H4.
          destruct H2 as [_ H2].
          specialize (H2 nt s H0).
          destruct H2 as [_ [_ [H5 _]]].
          simpl.
          right.
          apply in_or_app.
          right.
          destruct s0.
          * apply in_split in H4.
            destruct H4 as [l1 [l2 H4]].
            symmetry in H4.
            apply map_expand in H4.
            destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
            change (inl Start_cat :: l2) with ([inl Start_cat] ++ l2) in H4'''.
            symmetry in H4'''.
            apply map_expand in H4'''.
            destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
            {
            destruct s1'0.
            - inversion H5''.
            - simpl in H5''.
              inversion H5''.
              destruct s0.
              + simpl in H3.
                inversion H3.
              + simpl in H3.
                inversion H3.
            }
          * apply in_split in H4.
            destruct H4 as [l1 [l2 H4]].
            symmetry in H4.
            apply map_expand in H4.
            destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
            change (inl (Transf1_cat_nt n) :: l2) with ([inl (Transf1_cat_nt n)] ++ l2) in H4'''.
            symmetry in H4'''.
            apply map_expand in H4'''.
            destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
            {
            destruct s1'0.
            - inversion H5''.
            - simpl in H5''.
              inversion H5''.
              destruct s0.
              + simpl in H3.
                inversion H3.
              + simpl in H3.
                inversion H3.
            }
          * assert (H6: In (inl n) s).
              {
              apply in_split in H4.
              destruct H4 as [l1 [l2 H4]].
              symmetry in H4.
              apply map_expand in H4.
              destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
              change (inl (Transf2_cat_nt n) :: l2) with ([inl (Transf2_cat_nt n)] ++ l2) in H4'''.
              symmetry in H4'''.
              apply map_expand in H4'''.
              destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
              destruct s1'0.
              - inversion H5''.
              - inversion H5''.
                destruct s0.
                + simpl in H3.
                  inversion H3.
                  subst.
                  apply in_or_app.
                  right.
                  simpl.
                  left.
                  reflexivity.
                + simpl in H3.
                  inversion H3.
              }
            specialize (H5 n H6).
            apply in_map.
            exact H5.
      - inversion H.
        + subst.
          intros s H4.
          simpl in H4.
          destruct H4 as [H4 | H4].
          * inversion H4.
          * {
            destruct H4 as [H4 | H4].
            - inversion H4.
            - contradiction.
            }
        + subst.
          intros s0 H4.
          destruct H1 as [_ H1].
          specialize (H1 nt s H0).
          destruct H1 as [_ [_ [_ H5]]].
          assert (H6: In (inr s0) s).
            {
            apply in_split in H4.
            destruct H4 as [l1 [l2 H4]].
            symmetry in H4.
            apply map_expand in H4.
            destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
            change (inr s0 :: l2) with ([inr s0] ++ l2) in H4'''.
            symmetry in H4'''.
            apply map_expand in H4'''.
            destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
            destruct s1'0.
            - inversion H5''.
            - simpl in H5''.
              inversion H5''.
              destruct s1.
              + simpl in H3.
                inversion H3.
              + simpl in H3.
                inversion H3.
                subst.
                apply in_or_app.
                right.
                simpl.
                left.
                reflexivity.
            }
          specialize (H5 s0 H6).
          apply in_or_app.
          left.
          exact H5.
        + subst.
          intros s0 H4.
          destruct H2 as [_ H2].
          specialize (H2 nt s H0).
          destruct H2 as [_ [_ [_ H5]]].
          assert (H6: In (inr s0) s).
            {
            apply in_split in H4.
            destruct H4 as [l1 [l2 H4]].
            symmetry in H4.
            apply map_expand in H4.
            destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
            change (inr s0 :: l2) with ([inr s0] ++ l2) in H4'''.
            symmetry in H4'''.
            apply map_expand in H4'''.
            destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
            destruct s1'0.
            - inversion H5''.
            - simpl in H5''.
              inversion H5''.
              destruct s1.
              + simpl in H3.
                inversion H3.
              + simpl in H3.
                inversion H3.
                subst.
                apply in_or_app.
                right.
                simpl.
                left.
                reflexivity.
            }
          specialize (H5 s0 H6).
          apply in_or_app.
          right.
          exact H5.
      }
Qed.

Definition g_cat (g1: cfg non_terminal_1 terminal) (g2: cfg non_terminal_2 terminal): (cfg g_cat_nt terminal):= {|
start_symbol:= Start_cat;
rules:= g_cat_rules g1 g2;
t_eqdec:= t_eqdec g1;
nt_eqdec:= nt_eqdec' (nt_eqdec g1) (nt_eqdec g2);
rules_finite:= g_cat_finite g1 g2
|}.

(* --------------------------------------------------------------------- *)
(* CONCATENATION - LEMMAS                                                *)
(* --------------------------------------------------------------------- *)

Lemma derives_add_cat_left:
forall g1: cfg non_terminal_1 terminal,
forall g2: cfg non_terminal_2 terminal,
forall s s': sf1,
derives g1 s s' -> derives (g_cat g1 g2) (map g_cat_sf_lift1 s) (map g_cat_sf_lift1 s').
Proof.
intros g1 g2 s s' H.
induction H as [| x y z left right H1 H2 H3].
- apply derives_refl.
- rewrite map_app.
  rewrite map_app.
  rewrite map_app in H2.
  simpl in H2.
  apply derives_step with (left:=(Transf1_cat_nt left)).
  exact H2.
  simpl.
  apply Lift1_cat.
  apply H3.
Qed.

Lemma derives_add_cat_right:
forall g1: cfg non_terminal_1 terminal,
forall g2: cfg non_terminal_2 terminal,
forall s s': sf2,
derives g2 s s' -> derives (g_cat g1 g2) (map g_cat_sf_lift2 s) (map g_cat_sf_lift2 s').
Proof.
intros g1 g2 s s' H.
induction H as [| x y z left right H1 H2 H3].
- apply derives_refl.
- rewrite map_app.
  rewrite map_app.
  rewrite map_app in H2.
  simpl in H2.
  apply derives_step with (left:=(Transf2_cat_nt left)).
  exact H2.
  simpl.
  apply Lift2_cat.
  apply H3.
Qed.

Lemma g_cat_correct_aux:
forall g1: cfg non_terminal_1 terminal,
forall g2: cfg non_terminal_2 terminal,
forall s11 s12: sf1,
forall s21 s22: sf2,
derives g1 s11 s12 /\ derives g2 s21 s22 ->
derives (g_cat g1 g2)
        ((map g_cat_sf_lift1 s11)++(map g_cat_sf_lift2 s21))
        ((map g_cat_sf_lift1 s12)++(map g_cat_sf_lift2 s22)).
Proof.
intros g1 g2 s11 s12 s21 s22 [H1 H2].
induction H1, H2.
- apply derives_refl.
- rewrite map_app.
  rewrite map_app.
  apply derives_trans with (s2:=
    (map g_cat_sf_lift1 s ++
     map g_cat_sf_lift2 (s2 ++ [inl left] ++ s3))).
  apply derives_context_free_add_left.
  apply derives_add_cat_right.
  simpl.
  exact H2.
  apply derives_context_free_add_left.
  rewrite map_app.
  rewrite map_app.
  simpl.
  apply derives_step with (left:= Transf2_cat_nt left).
  + apply derives_refl.
  + simpl.
    apply Lift2_cat.
    exact H.
- apply derives_context_free_add_right.
  apply derives_add_cat_left.
  apply derives_step with (left:=left).
  + exact H1.
  + exact H.
- rewrite map_app.
  rewrite map_app.
  rewrite <- app_assoc.
  rewrite <- app_assoc.
  rewrite map_app.
  rewrite map_app.
  rewrite map_app in IHderives.
  rewrite map_app in IHderives.
  rewrite <- app_assoc in IHderives.
  simpl in IHderives.
  rewrite map_app in IHderives.
  remember ((map g_cat_sf_lift1 s1 ++
             map g_cat_sf_lift2 s0)) as w1.
  remember (map g_cat_sf_lift1 s3 ++
            map g_cat_sf_lift2 s4 ++
            map g_cat_sf_lift2 right0 ++
            map g_cat_sf_lift2 s5) as w2.
  apply derives_step with (left:= Transf1_cat_nt left).
  exact IHderives.
  simpl.
  apply Lift1_cat.
  exact H.
Qed.

Theorem g_cat_correct:
forall g1: cfg non_terminal_1 terminal,
forall g2: cfg non_terminal_2 terminal,
forall s1: sf1,
forall s2: sf2,
generates g1 s1 /\ generates g2 s2 ->
generates (g_cat g1 g2)
          ((map g_cat_sf_lift1 s1)++(map g_cat_sf_lift2 s2)).
Proof.
unfold generates.
intros g1 g2 s1 s2 H.
destruct H as [H1 H2].
apply derives_trans with (s2:= (map g_cat_sf_lift1 [(inl (start_symbol g1))] ++ map g_cat_sf_lift2 [(inl (start_symbol g2))])).
- match goal with
  | |- derives _ ?s1 ?s2 =>
       change s1 with ([] ++ s1);
       change s2 with ([] ++ s2 ++ [])
  end.
  apply derives_step with (left:= (start_symbol (g_cat g1 g2))).
  + apply derives_refl.
  + simpl.
    apply New_cat.
- apply g_cat_correct_aux.
  split.
  + exact H1.
  + exact H2.
Qed.

Theorem g_cat_correct_inv:
forall g1: cfg non_terminal_1 terminal,
forall g2: cfg non_terminal_2 terminal,
forall s: sfc,
generates (g_cat g1 g2) s ->
s = [inl (start_symbol (g_cat g1 g2))] \/
exists s1: sf1,
exists s2: sf2,
s =(map g_cat_sf_lift1 s1)++(map g_cat_sf_lift2 s2) /\
generates g1 s1 /\
generates g2 s2.
Proof.
unfold generates.
intros g1 g2 s.
remember ([inl (start_symbol (g_cat g1 g2))]) as init.
intros H.
induction H.
- left. reflexivity.
- subst.
  specialize (IHderives eq_refl).
  destruct IHderives.
  + (* IHderives, first case *)
    (* A primeira cadeia gerada é a raiz da gramática *)
    destruct s2.
    * (* Se s2 é vazio, a primeira regra está sendo aplicada *)
      simpl in H1. inversion H1. subst. clear H1.
      simpl in H0. inversion H0. clear H0 H2.
      simpl in *.
      right.
      exists [inl (start_symbol g1)], [inl (start_symbol g2)].
      {
      split.
      - simpl. reflexivity.
      - split. apply derives_refl. apply derives_refl.
      }
    * (* Se s2 não é vazio, temos uma contradição *)
      simpl in H1.
      {
      destruct s2.
      - simpl in *. inversion H1.
      - simpl in *. inversion H1.
      }
  + (* IHderives, second case *)
    (* A primeira cadeia gerada é a concatenação de map x com map x0 *)
    destruct H1 as (? & ? & ? & ? & ?).
    (* Análise da regra usada *)
    inversion H0.
    subst.
    clear H0.
    * (* Case 1: rule New_cat *)
      (* Contradiction: H1 cannot contain Start_cat *)
      assert (IN : In (inl Start_cat) (map g_cat_sf_lift1 x ++ map g_cat_sf_lift2 x0)).
        {
        rewrite <- H1.
        rewrite in_app_iff.
        right.
        simpl.
        left.
        reflexivity.
        }
      rewrite in_app_iff in IN.
      (* Start_cat is in x or x0 *)
      {
      destruct IN.
      - (* Start_cat is in x, contradiction *)
        rewrite in_map_iff in H0.
        destruct H0 as (? & ? & ?).
        (* But Start_cat = lift x1 and x cannot contain x1 *)
        destruct x1.
        + simpl in H0.
          inversion H0.
        + simpl in H0.
          inversion H0.
      - (* Start_cat is in x0, contradiction *)
        rewrite in_map_iff in H0.
        destruct H0 as (? & ? & ?).
        destruct x1.
        + simpl in H0.
          inversion H0.
        + simpl in H0.
          inversion H0.
      }
    * (* Case 2: rule Lift1_cat *)
      (* A rule of g1 has been used *)
      subst.
      (* Consider both situations in H1 *)
      assert (IN : In (inl (Transf1_cat_nt nt)) (map g_cat_sf_lift1 x ++ map g_cat_sf_lift2 x0)).
        {
        rewrite <- H1.
        rewrite in_app_iff.
        right.
        simpl.
        left.
        reflexivity.
        }
      rewrite in_app_iff in IN.
      (* Transf1_cat_nt is in x or x0 *)
      {
      destruct IN.
      - (* Transf1_cat_nt is in x, ok *)
        apply equal_app in H1.
        destruct H1.
        + destruct H1 as [l [H1 H6]].
          right.
          destruct l.
          * {
            destruct x0.
            - simpl in H6.
              inversion H6.
            - simpl in H6.
              inversion H6.
              destruct s0.
              + inversion H8.
              + inversion H8.
            }
          * inversion H6.
            subst.
            clear H6.
            {
            apply derives_step with (right:=(map g_cat_sf_lift1 s)) in H.
            - symmetry in H1.
              apply map_expand in H1.
              destruct H1 as [s1' [s2' [H6 [H7 H8]]]].
              replace (inl (Transf1_cat_nt nt) :: l) with ([inl (Transf1_cat_nt nt)]++l) in H8.
              + symmetry in H8.
                apply map_expand in H8.
                destruct H8 as [s1'' [s2'' [H9 [H10 H11]]]].
                exists (s1'++s++s2''), x0.
                split.
                * repeat rewrite map_app.
                  subst.
                  repeat rewrite <- app_assoc.
                  reflexivity.
                * {
                  split.
                  - subst.
                    destruct s1''.
                    + simpl in H10.
                      inversion H10.
                    + inversion H10.
                      destruct s0.
                       * inversion H6.
                         apply map_eq_nil in H7.
                         subst.
                         {
                         apply derives_step with (right:= s) in H2.
                         - exact H2.
                         - exact H4.
                         }
                       * inversion H6.
                  - exact H3.
                  }
              + simpl.
                reflexivity.
            - exact H0.
            }
        + destruct H1 as [l [H1 H6]].
          assert (IN: In (inl (Transf1_cat_nt nt)) (map g_cat_sf_lift2 x0)).
            {
            rewrite H6.
            apply in_app_iff.
            right.
            simpl.
            left.
            reflexivity.
            }
          apply in_map_iff in IN.
          destruct IN.
          destruct H7.
          destruct x1.
          inversion H7.
          inversion H7.
      - (* Transf1_cat_nt is in x0, contradiction *)
        rewrite in_map_iff in H5.
        destruct H5.
        destruct H5.
        destruct x1.
        + inversion H5.
        + inversion H5.
      }
    * (* Case 3: rule Lift2_cat *)
      (* A rule of g2 has been used *)
      subst.
      (* Consider both situations in H1 *)
      assert (IN : In (inl (Transf2_cat_nt nt)) (map g_cat_sf_lift1 x ++ map g_cat_sf_lift2 x0)).
        {
        rewrite <- H1.
        rewrite in_app_iff.
        right.
        simpl.
        left.
        reflexivity.
        }
      rewrite in_app_iff in IN.
      (* Transf2_cat_nt is in x or x0 *)
      {
      destruct IN.
      - (* Transf2_cat_nt is in x, contradiction *)
        rewrite in_map_iff in H5.
        destruct H5.
        destruct H5.
        destruct x1.
        + inversion H5.
        + inversion H5.
      - (* Transf2_cat_nt is in x0, ok *)
        apply equal_app in H1.
        destruct H1.
        + destruct H1 as [l [H1 H6]].
          right.
          destruct l.
          * {
            destruct x0.
            - simpl in H6.
              inversion H6.
            - simpl in H6.
              inversion H6.
              rewrite app_nil_r in H1.
              subst.
              exists x.
              exists (s++x0).
              split.
              rewrite map_app.
              reflexivity.
              split.
              exact H2.
              inversion H6.
              destruct s0.
              + simpl in H7.
                inversion H7.
                subst.
                rewrite <- app_nil_l in H3.
                apply derives_step with (right:=s) in H3.
                * exact H3.
                * exact H4.
              + inversion H7.
            }
          * inversion H6.
            subst.
            clear H6.
            assert (IN : In (inl (Transf2_cat_nt nt)) (map g_cat_sf_lift1 x)).
              {
              rewrite H1.
              rewrite in_app_iff.
              right.
              simpl.
              left.
              reflexivity.
              }
            rewrite in_map_iff in IN.
            destruct IN as [x0' [H6 H7]].
            {
            destruct x0'.
            - simpl in H6.
              inversion H6.
            - inversion H6.
            }
        + destruct H1 as [l [H7 H8]].
          subst.
          symmetry in H8.
          apply map_expand in H8.
          destruct H8 as [ s1' [s2' [H10 [H11 H12]]]].
          subst.
          destruct s2'.
          * inversion H12.
          * inversion H12.
            subst.
            right.
            exists x.
            exists (s1'++s++s2').
            split.
            rewrite <- app_assoc.
            repeat rewrite map_app.
            reflexivity.
            split.
            exact H2.
            {
            destruct s0.
            - inversion H6.
              subst.
              apply derives_step with (right:=s) in H3.
              exact H3.
              exact H4.
            - inversion H6.
            }
      }
Qed.

End Concatenation.

(* --------------------------------------------------------------------- *)
(* AS LANGUAGES                                                          *)
(* --------------------------------------------------------------------- *)

Section Concatenation_2.

Variable non_terminal_1 non_terminal_2 terminal: Type.

Notation sentence:= (list terminal).

Inductive l_cat (l1 l2: lang terminal): lang terminal:=
| l_cat_app: forall s1 s2: sentence, l1 s1 -> l2 s2 -> l_cat l1 l2 (s1 ++ s2).

(*
Definition l_cat (l1 l2: lang terminal): lang terminal:=
fun s: sentence => exists s1 s2: sentence, s = s1 ++ s2 /\ l1 s1 /\ l2 s2.
*)

Lemma map_cat_1:
forall s: sentence,
map (@g_cat_sf_lift1 non_terminal_1 non_terminal_2 terminal) (map (@terminal_lift non_terminal_1 terminal) s) =
map (@terminal_lift (@g_cat_nt non_terminal_1 non_terminal_2) terminal) s.
Proof.
induction s.
- simpl.
  reflexivity.
- simpl.
  change (inr a) with (terminal_lift (g_cat_nt non_terminal_1 non_terminal_2) a).
  rewrite IHs.
  reflexivity.
Qed.

Lemma map_cat_2:
forall s: sentence,
map (@g_cat_sf_lift2 non_terminal_1 non_terminal_2 terminal) (map (@terminal_lift non_terminal_2 terminal) s) =
map (@terminal_lift (@g_cat_nt non_terminal_1 non_terminal_2) terminal) s.
Proof.
induction s.
- simpl.
  reflexivity.
- simpl.
  change (inr a) with (terminal_lift (g_cat_nt non_terminal_1 non_terminal_2) a).
  rewrite IHs.
  reflexivity.
Qed.

Lemma map_cat_3:
forall s: sentence,
forall l: list (non_terminal_1 + terminal),
map (@terminal_lift (@g_cat_nt non_terminal_1 non_terminal_2) terminal) s =
map (@g_cat_sf_lift1 non_terminal_1 non_terminal_2 terminal) l ->
l = map (@terminal_lift non_terminal_1 terminal) s.
Proof.
induction s.
- intros l H.
  simpl in H.
  symmetry in H.
  apply map_eq_nil in H.
  subst.
  simpl.
  reflexivity.
- intros l H.
  remember (terminal_lift (g_cat_nt non_terminal_1 non_terminal_2) (terminal:=terminal)) as m1.
  remember (g_cat_sf_lift1 non_terminal_2 (terminal:=terminal)) as m2.
  remember (terminal_lift non_terminal_1 (terminal:=terminal)) as m3.
  simpl in H.
  destruct l.
  + simpl in H.
    inversion H.
  + simpl in H.
    inversion H.
    specialize (IHs l H2).
    rewrite IHs.
    simpl.
    destruct s0.
    * {
      replace (m2 (inl n)) with (inl terminal (Transf1_cat_nt non_terminal_2 n)) in H1.
      - replace (m1 a) with (inr (g_cat_nt non_terminal_1 non_terminal_2) a) in H1.
        + inversion H1.
        + rewrite Heqm1.
          change (inr a) with (terminal_lift (g_cat_nt non_terminal_1 non_terminal_2) a).
          reflexivity.
      - rewrite Heqm2.
        simpl.
        reflexivity.
      }
    * {
      replace (m2 (inr t)) with (inr (g_cat_nt non_terminal_1 non_terminal_2) t) in H1.
      - replace (m1 a) with (inr (g_cat_nt non_terminal_1 non_terminal_2) a) in H1.
        + inversion H1.
          replace (m3 t) with (inr non_terminal_1 t).
          * reflexivity.
          * rewrite Heqm3.
            change (inr t) with (terminal_lift non_terminal_1 t).
            reflexivity.
        + rewrite Heqm1.
          change (inr a) with (terminal_lift (g_cat_nt non_terminal_1 non_terminal_2) a).
          reflexivity.
      - rewrite Heqm2.
        simpl.
        reflexivity.
      }
Qed.

Lemma map_cat_4:
forall s: sentence,
forall l: list (non_terminal_2 + terminal),
map (@terminal_lift (@g_cat_nt non_terminal_1 non_terminal_2) terminal) s =
map (@g_cat_sf_lift2 non_terminal_1 non_terminal_2 terminal) l ->
l = map (@terminal_lift non_terminal_2 terminal) s.
Proof.
induction s.
- intros l H.
  simpl in H.
  symmetry in H.
  apply map_eq_nil in H.
  subst.
  simpl.
  reflexivity.
- intros l H.
  remember (terminal_lift (g_cat_nt non_terminal_1 non_terminal_2) (terminal:=terminal)) as m1.
  remember (g_cat_sf_lift2 non_terminal_1 (terminal:=terminal)) as m2.
  remember (terminal_lift non_terminal_2 (terminal:=terminal)) as m3.
  simpl in H.
  destruct l.
  + simpl in H.
    inversion H.
  + simpl in H.
    inversion H.
    specialize (IHs l H2).
    rewrite IHs.
    simpl.
    destruct s0.
    * {
      replace (m2 (inl n)) with (inl terminal (Transf2_cat_nt non_terminal_1 n)) in H1.
      - replace (m1 a) with (inr (g_cat_nt non_terminal_1 non_terminal_2) a) in H1.
        + inversion H1.
        + rewrite Heqm1.
          change (inr a) with (terminal_lift (g_cat_nt non_terminal_1 non_terminal_2) a).
          reflexivity.
      - rewrite Heqm2.
        simpl.
        reflexivity.
      }
    * {
      replace (m2 (inr t)) with (inr (g_cat_nt non_terminal_1 non_terminal_2) t) in H1.
      - replace (m1 a) with (inr (g_cat_nt non_terminal_1 non_terminal_2) a) in H1.
        + inversion H1.
          replace (m3 t) with (inr non_terminal_2 t).
          * reflexivity.
          * rewrite Heqm3.
            change (inr t) with (terminal_lift non_terminal_2 t).
            reflexivity.
        + rewrite Heqm1.
          change (inr a) with (terminal_lift (g_cat_nt non_terminal_1 non_terminal_2) a).
          reflexivity.
      - rewrite Heqm2.
        simpl.
        reflexivity.
      }
Qed.

End Concatenation_2.

Variable terminal: Type.

Notation sentence:= (list terminal).

Theorem l_cat_is_cfl:
forall l1 l2: lang terminal,
cfl l1 ->
cfl l2 ->
cfl (l_cat l1 l2).
Proof.
intros l1 l2 H1 H2.
unfold cfl.
unfold cfl in H1.
unfold cfl in H2.
unfold lang_eq.
unfold lang_eq in H1.
unfold lang_eq in H2.
unfold lang_of_g.
unfold lang_of_g in H1.
unfold lang_of_g in H2.
destruct H1 as [non_terminal_1 [g1 H1]].
destruct H2 as [non_terminal_2 [g2 H2]].
exists (g_cat_nt non_terminal_1 non_terminal_2), (g_cat g1 g2).
intros w.
split.
- intros H3.
  inversion H3.
  specialize (H1 s1).
  destruct H1 as [H1 _].
  specialize (H1 H).
  specialize (H2 s2).
  destruct H2 as [H2 _].
  specialize (H2 H0).
  unfold produces in H1.
  unfold produces in H2.
  unfold produces.
  rewrite map_app.
  rewrite <- map_cat_1.
  rewrite <- map_cat_2.
  apply g_cat_correct.
  exact (conj H1 H2).
- intros H4.
  apply g_cat_correct_inv in H4.
  destruct H4 as [H4 | H4].
  + destruct w.
    * simpl in H4.
      inversion H4.
    * simpl in H4.
      inversion H4.
  + destruct H4 as [s1 [s2 [H4 [H5 H6]]]].
    symmetry in H4.
    apply map_expand in H4.
    destruct H4 as [s1' [s2' [H7 [H8 H9]]]].
    rewrite H7.
    apply l_cat_app.
    * specialize (H1 s1').
      destruct H1 as [_ H1].
      apply H1.
      unfold produces.
      apply map_cat_3 in H8.
      rewrite H8 in H5.
      exact H5.
    * specialize (H2 s2').
      destruct H2 as [_ H2].
      apply H2.
      unfold produces.
      apply map_cat_4 in H9.
      rewrite H9 in H6.
      exact H6.
Qed.

Theorem l_cat_correct:
forall l1 l2: lang terminal,
forall s1 s2: sentence,
(l1 s1 /\ l2 s2) -> (l_cat l1 l2) (s1 ++ s2).
Proof.
intros l1 l2 s1 s2 [H1 H2].
apply l_cat_app.
- exact H1.
- exact H2.
Qed.

Theorem l_uni_correct_inv:
forall l1 l2: lang terminal,
forall s: sentence,
(l_cat l1 l2) s ->
exists s1 s2: sentence,
s = s1 ++ s2 /\ l1 s1 /\ l2 s2.
Proof.
intros l1 l2 s H.
inversion H.
exists s1, s2.
split.
- reflexivity.
- split.
  + exact H0.
  + exact H1.
Qed.


(**
https://www.jstage.jst.go.jp/article/jssst/34/2/34_2_64/_pdf

https://github.com/affeldt/mathcomp-intro
*)
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import fingroup.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** Sect. 5: Overview of Finite Groups *)

Local Open Scope group_scope.

Section sect5.

  Variable gT : finGroupType.
  Variables G : {group gT}.

  (* p.69 右 l.2 *)
  Variables g h : gT.
  Hypotheses (gG : g \in G) (hG : h \in G).
  Check g * h : gT.
  Check groupM gG hG : g * h \in G.
End sect5.

Section coset_bijection.

  Variable gT : finGroupType.
  Variables G H : {group gT}.               (* これが reprs の引数 *)
  Hypothesis HG : H \subset G.

  (** Sect. 6: Left-cosets are disjoint *)

(**
剰余群の任意のふたつの元は、まったく同じか、重ならない別のものである。
*)
  Lemma coset_disjoint L0 L1 :
    L0 \in lcosets H G ->
           L1 \in lcosets H G ->
                  L0 :&: L1 != set0 -> L0 = L1.
  Proof.
(*
    case/lcosetsP => g0 g0G -> {L0}.         (* p.69 右 l.14 *)
 *)
    Check @lcosetsP gT H G L0.
    move/(@lcosetsP gT H G L0).             (* move/lcosetsP *)
    case.                                   (* 前提が exists のときは case *)
    move=> g0.
    move=> g0G.
    move=> TMP.
    rewrite TMP.
    clear TMP.                              (* rewrite {TMP} *)
    clear L0.                               (* rewrite {L0} *)

    case/lcosetsP => g1 g1G -> {L1}.
    move=> g0_g1_disj.
    apply/lcoset_eqP.
    case/set0Pn : g0_g1_disj => /= g.
    rewrite in_setI => /andP[].
    rewrite 3!mem_lcoset => g_g0 g_g1.
    rewrite -(mul1g g0).
    rewrite -(mulgV g).
    rewrite 2!mulgA.
    rewrite -mulgA.
    rewrite groupM //.
    rewrite groupVl //.
    rewrite invMg.
      by rewrite invgK.
  Qed.

  (** Sect. 7: Injection into the set of left-cosets *)

  Lemma mem_repr_coset x : x \in G -> repr (x *: H) \in G.
  Proof.
    move=> xG.
    rewrite /repr.
    case: ifPn => // x1.
    case: pickP => /=.
    move=> g0.
    case/lcosetP => g1 g1H ->.
    rewrite groupM //.
      by move/subsetP : (HG); apply.
      move/(_ x).
        by rewrite lcoset_refl.
  Qed.

End coset_bijection.

Section coset_bijection2.

  Variable gT : finGroupType.

(**
repr は、 代表元 representative を求める関数である。
剰余群の元（剰余類）には重なりがないので、代表元から剰余類の関数は、単射である。

``reprs G H`` は、代表元を求める関数の剰余群 ``H \ G`` の像である。
つまり、剰余類からぞれぞれ代表元を取り出して集めたものになる。

「（剰余群の）元の代表元の集合」と呼ぶ。
*)
  Definition reprs (G H : {group gT}) := repr @: lcosets H G.  (* p.70 右 l.24 *)

  (* p.71 左 l.5 *)
  Lemma injective_coset (G H : {group gT}) :
    {in reprs G H &, injective (fun g => g *: H)}.
  Proof.
    move=> /= g g'.
    (* goal : *)
(**
g と g' が ``H \ G`` の元（剰余類）の代表元であるなら、剰余類を求める関数

``g |-> g *: H``

は単射である。
*)
    Check g \in reprs G H ->
                g' \in reprs G H ->
                       g *: H = g' *: H -> g = g'.

    move=> /(@imsetP (set_of_finType gT) gT repr (mem (lcosets H G)) g).
    Check (@imsetP (set_of_finType gT) gT repr (mem (lcosets H G)) g).
    move=> [] /=.

    (* goal : *)
    Check forall x : {set gT},
        x \in lcosets H G -> g = repr x ->
              g' \in reprs G H ->
                     g *: H = g' *: H -> g = g'.
    move=> L LHG gL.
    move=> /imsetP [] /= K KHG g'K.
    move=> abs.
  Admitted.

End coset_bijection2.

(** Sect. 8: Transitivity of the group index *)

Notation "#| G : H |" := #| lcosets H G |.

Section index.

  Variable gT : finGroupType.
  Variables G H K : {group gT}.
  Hypotheses (HG : H \subset G) (KG : K \subset G) (HK : K \proper H).

  Check reprs G H.                      (* G / H の元の代表元の集合 *)
  Check reprs H K.                      (* H / K の元の代表元の集合 *)

  (* p.71 右 l.24 *)
  Lemma index_trans : #| G : K | = (#| G : H | * #| H : K |)%N.
  Proof.
    rewrite /=.

    set calG := reprs G H.         (* G / H の元の代表元の集合 *)
    pose alpha := fun x => x *: H. (* から Hについての剰余類への関数α *)
    have calG_H_inj : {in calG &, injective alpha}. (* 関数αが単射である。 *)
      by apply: injective_coset.

    set calH := reprs H K.        (* H / K の元の代表元の集合 *)
    pose beta := fun x => x *: K. (* から Kについての剰余類への関数β *)
    have calH_K_inj : {in calH &, injective (fun x=> x *: K)} (* 関数βが単射である。 *)
      by apply: injective_coset.

    Check @proper_sub _ H K : H \proper K -> H \subset K.
    move/proper_sub : HK.                   (* K ⊆ H *)

    (* p.72 左 l.19 *)
    pose phi :=                   (* calG × calH から K についての剰余類への関数φ *)
      fun gh : gT * gT => let: (g, h) := gh in (g * h) *: K.
    have phi_injective : {in setX calG calH & , injective phi}. (* 関数φが単射である。 *)
    - case=> g h.
      rewrite inE /=.
      case=> g' h' /andP [gG hH].
      rewrite /phi inE /= => /andP [g'G h'H] ghK.

      (* p.72 左 l.30 *)
      have step1 : (g'^-1 * g * h) *: K = h' *: K.
      + move: ghK.
        (* よく使われるシノニム、congr に関数 f を渡す。 *)
        Check congr1                        (* f は、1変数関数 *)
          : forall (A B : Type) (f : A -> B) (x y : A), x = y -> f x = f y.
        Check congr2                        (* f は、2変数関数 *)
          : forall (A1 A2 B : Type) (f : A1 -> A2 -> B) (x1 y1 : A1) (x2 y2 : A2),
            x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2.
        move/(congr1 (fun X => g'^-1 *: X)).
          by rewrite -2!lcosetM !mulgA mulVg mul1g.
      + admit.
  Admitted.

End index.

(* Sect. 9: Lagrange Theorem *)

Section lagrange.

  Variable gT : finGroupType.
  Variables G H : {group gT}.
  Hypotheses (HG : H \subset G).

  Lemma coset1 g : g *: (1%G : {group gT}) = [set g].
  Proof.
    apply/eqP; rewrite eqEsubset; apply/andP; split; apply/subsetP => j.
    case/lcosetP => x.
    rewrite !inE => /eqP ->.
      by rewrite mulg1 => /eqP.
      rewrite in_set1 => /eqP ->.
      apply/lcosetP.
      exists 1 => //.
        by rewrite mulg1.
  Qed.

  Lemma lcosets1 (K : {group gT}) : lcosets 1%G K = (set1) @: K.
  Proof.
    apply/eqP; rewrite eqEsubset; apply/andP; split; apply/subsetP => i.
    case/lcosetsP => g gK ->{i}.
    apply/imsetP.
    exists g => //.
      by apply coset1.
      case/imsetP => g gK ->{i}.
      apply/lcosetsP.
      exists g => //.
        by rewrite coset1.
  Qed.

  (* p.73 左 l.11 *)
  (* 部分群の指数の推移関係の系である。 *)
  Theorem Lagrange : #| G | = (#| H | * #| G : H |)%N.
  Proof.
    (* {1} ⊂ H かどうかで場合分けする。  *)
(**
    case H1 : (1%G \proper H).
    でもよいが、boolP も覚えておくとよい。
*)
    case/boolP : (1%G \proper H) => H1.

    (* ``{1} ⊂ H`` の場合 *)
    - have G1 : 1%G \subset G.              (* {1} ⊆ H である。 *)
      + apply/subsetP => h.
          by rewrite inE => /eqP ->.

      (* K = {1} とすると推移律が成り立ち、そこからラグランジュの定理が成り立つ。 *)
      Check index_trans HG G1 H1 : #| G : 1%G | = (#| G : H | * #| H : 1%G |)%N.
      Check (card_imset G set1_inj).
      + move: (index_trans HG G1 H1).
        rewrite lcosets1 (card_imset G set1_inj).
        rewrite mulnC lcosets1 card_imset //.
        exact: set1_inj.

    (* ``〜 {1} ⊂ H`` の場合 *)
    - have -> : H = 1%G.                    (* {1} = H である。 *)
      + apply/trivGP.
        move: H1.
          by rewrite proper1G negbK => /eqP ->.

      (* 左剰余類は {1} となり、そこからラグランジュの定理が成り立つ。 *)
      Check #| G | = (#| 1%G | * #| G : 1%G |)%N.
      + rewrite cards1 mul1n lcosets1 // card_imset //.
        exact: set1_inj.
  Qed.

End lagrange.

(* END *)


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Exercise_Ten.

Coq < Require Import Classical.

Coq < Goal forall g h m t a:Prop, (((g /\ h) \/ (m /\ g)) /\ (g -> (t /\ a))) -> (a).
1 subgoal

  ============================
   forall g h m t a : Prop, (g /\ h \/ m /\ g) /\ (g -> t /\ a) -> a

Unnamed_thm < intros.
1 subgoal

  g : Prop
  h : Prop
  m : Prop
  t : Prop
  a : Prop
  H : (g /\ h \/ m /\ g) /\ (g -> t /\ a)
  ============================
   a

Unnamed_thm < elim H.
1 subgoal

  g : Prop
  h : Prop
  m : Prop
  t : Prop
  a : Prop
  H : (g /\ h \/ m /\ g) /\ (g -> t /\ a)
  ============================
   g /\ h \/ m /\ g -> (g -> t /\ a) -> a

Unnamed_thm < intro.
1 subgoal

  g : Prop
  h : Prop
  m : Prop
  t : Prop
  a : Prop
  H : (g /\ h \/ m /\ g) /\ (g -> t /\ a)
  H0 : g /\ h \/ m /\ g
  ============================
   (g -> t /\ a) -> a

Unnamed_thm < intro.
1 subgoal

  g : Prop
  h : Prop
  m : Prop
  t : Prop
  a : Prop
  H : (g /\ h \/ m /\ g) /\ (g -> t /\ a)
  H0 : g /\ h \/ m /\ g
  H1 : g -> t /\ a
  ============================
   a

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
firstorder .

Unnamed_thm is defined

Coq <
*)

Require Import Classical.
Section Exercise_10.
Goal forall g h m t a:Prop, (((g /\ h) \/ (m /\ g)) /\ (g -> (t /\ a))) -> (a).
intros.
elim H.
intro.
intro.
firstorder.
Qed.


Require UniMath.Algebra.IteratedBinaryOperations.
Require UniMath.Foundations.NaturalNumbers.
Require UniMath.Algebra.IteratedBinaryOperations.
Require UniMath.Combinatorics.FiniteSets.

Module Test_assoc.

  Import UniMath.Algebra.IteratedBinaryOperations.
  Import UniMath.Foundations.NaturalNumbers.

  (* verify that our associativity matches that of the parser, without an extra "1" *)

  Local Notation "[]" := Lists.nil (at level 0, format "[]").
  Local Infix "::" := cons.

  Section Test.
    Context (X:UU) (e:X) (op:binop X) (w x y z:X).
    Goal iterop_list e op [] = e. reflexivity. Qed.
    Goal iterop_list e op (x::[]) = x. reflexivity. Qed.
    Goal iterop_list e op (x::y::[]) = op x y. reflexivity. Qed.
    Goal iterop_list e op (w::x::y::z::[]) = op w (op x (op y z)). reflexivity. Qed.
  End Test.

  Local Open Scope stn.

  Open Scope multmonoid.

  Goal ∏ (M:monoid) (f:stn 3 -> M),
         iterop_seq_mon(3,,f) = f(●O) * f(●1%nat) * f(●2).
  Proof. reflexivity. Defined.

  Goal ∏ (M:monoid) (f:stn 3 -> Sequence M),
         iterop_seq_seq_mon(3,,f) =
                iterop_seq_mon (f(●0))
              * iterop_seq_mon (f(●1%nat))
              * iterop_seq_mon (f(●2)).
  Proof. reflexivity. Defined.

  (* demonstrate that the Coq parser is left-associative with "*" *)
  Goal ∏ (M:monoid) (x y z:M), x*y*z = (x*y)*z. Proof. reflexivity. Defined.
  Goal ∏ (M:monoid) (x y z:M), x*y*z = x*(y*z). Proof. apply assocax. Defined.

  (* demonstrate that the Coq parser is left-associative with "+" *)
  Local Open Scope addmonoid.
  Import UniMath.Algebra.Monoids.AddNotation.
  Goal ∏ (M:monoid) (x y z:M), x+y+z = (x+y)+z. Proof. reflexivity. Defined.
  Goal ∏ (M:monoid) (x y z:M), x+y+z = x+(y+z). Proof. apply assocax. Defined.

End Test_assoc.
(*
Local Variables:
compile-command: "make -C ../../.. TAGS UniMath/Foundations/Algebra/Tests.vo"
End:
*)