Require Import Definitions.

     (* spec    proof comments *)
     (*   24       40      632 pcp_cfg.v *)

(* Lemma list_prefix_double_inv X (x1 x2 : X) A A' B B' : *)
(*   ~ x1 el A -> ~ x1 el A' -> ~ x2 el A -> ~ x2 el A' -> A ++ x1 :: B = A' ++ x2 :: B' -> A = A' /\ B = B'. *)
(* Proof. *)
(*   intro. revert A' B B'. *)
(*   induction A; intros. *)
(*   - destruct A'; inv H3; firstorder. *)
(*   - destruct A';  inv H3. firstorder. *)
(*     eapply IHA in H6; try now firstorder. intuition congruence. *)
(* Qed. *)

(* Lemma list_prefix_inv X (x : X) A A' B B' : *)
(*   ~ x el A -> ~ x el A' -> A ++ x :: B = A' ++ x :: B' -> A = A' /\ B = B'. *)
(* Proof. *)
(*   intros. eapply list_prefix_double_inv; eauto. *)
(* Qed. *)

(* Lemma list_snoc_inv X (A : list X) : *)
(*   A = [] \/ exists x A', A = A' ++ [x]. *)
(* Proof. *)
(*   induction A. *)
(*   - firstorder. *)
(*   - destruct IHA as [-> | (? & ? & ->)]. right. now exists a, []. *)
(*     right. now exists x, (a :: x0). *)
(* Qed. *)

(* Lemma map_injective X Y (f : X -> Y) A B : *)
(*   (forall x y, f x = f y -> x = y) -> map f A = map f B -> A = B. *)
(* Proof. *)
(*   revert B. induction A; intros [] H H0; inv H0; firstorder congruence. *)
(* Qed. *)

Lemma in_concat_iff X (l : list (list X)) x :
  x el concat l <-> exists l', x el l' /\ l' el l.
Admitted.

Lemma concat_rev X (l : list (list X)) :
  concat (rev (map (@rev _) l)) = rev (concat l).
Proof.
  induction l.
  - reflexivity.
  - cbn. rewrite concat_app, IHl, rev_app_distr. cbn. now rewrite <- app_nil_end.
Qed.

Notation "f ∘ g" := (fun x => f (g x)) (at level 100).

Hint Rewrite concat_app map_app map_map : list.
Hint Rewrite <- map_rev  : list.
Hint Rewrite <- concat_rev : list.

Lemma list_split X A B C D E (x : X) :
  A ++ B ++ C = D ++ x :: E -> ~ x el A -> ~ x el C ->
  exists F G,
    D = A ++ F /\
    E = G ++ C /\
    B = F ++ x :: G.
Proof.
  revert B C D E.
  induction A; intros.
  - cbn in *. clear H0. revert B C E H H1. induction D; intros.
    + exists []. cbn in *. revert C E H H1. destruct B; cbn in *; intros; inv H; firstorder. eauto.
    + exists (a :: D). cbn in *. destruct B.
      * cbn in *. subst. destruct H1. right. eapply in_app_iff. firstorder.
      * cbn in *. inv H. eapply IHD in H3 as (? & ? & ? & ? & ?). subst. eauto. eauto.
  -  revert B C E H H1. induction D; intros.
     + cbn in H. inv H. firstorder.
     + cbn in H. inv H. edestruct IHA  as (? & ? & ? & ? & ?); eauto. subst.
       exists x0, x1. eauto.
Qed.

Lemma nil_app_nil X (A : list X) :
  A = [] ++ A ++ [].
Proof.
  now autorewrite with list.
Qed.

     (* spec    proof comments *)
     (*   29       27      638 pcp_cfg.v *)

Section CFGs.

  Notation sig := nat.
  Definition rule : Type := sig * list sig.
  Definition cfg : Type := sig * list rule.

  Definition rules (G : cfg) := snd G.
  Definition startsym (G : cfg) := fst G.

  Inductive rew_cfg : cfg -> list sig -> list sig -> Prop:=
  |rewR R x a y v : (a,v) el rules R -> rew_cfg R (x++[a]++y) (x++v++y).
  Hint Constructors rew_cfg.

  Lemma rewrite_sing R a x :
    (a, x) el rules R -> rew_cfg R [a] x.
  Proof.
    intros. rewrite nil_app_nil, (nil_app_nil [a]). now econstructor.
  Qed.

  Inductive rewt (S: cfg) (x: list sig) : list sig -> Prop :=
  |rewtRefl : rewt S x x
  |rewtRule y z : rewt S x y -> rew_cfg S y z -> rewt S x z.
  Hint Constructors rewt.

  Global Instance rewtTrans R :
    PreOrder (rewt R).
  Proof.
    split.
    - hnf. econstructor.
    - induction 2; eauto.
  Qed.

  Global Instance rewrite_proper R :
    Proper (rewt R ==> rewt R ==> rewt R) (@app sig).
  Proof.
    intros x1 y1 H1 x2 y2 H2.
    induction H1.
    - induction H2.
      + reflexivity.
      + rewrite IHrewt. inv H. eapply rewtRule.
        replace (x1 ++ x ++ [a] ++ y0) with ( (x1 ++ x) ++ [a] ++ y0) by now autorewrite with list.
        eauto. replace (x1 ++ x ++ v ++ y0) with ( (x1 ++ x) ++ v ++ y0) by now autorewrite with list. eauto.
    - rewrite IHrewt. inv H. autorewrite with list. eauto.
  Qed.

  Global Instance subrel R :
    subrelation (rew_cfg R) (rewt R).
  Proof.
    intros x y H. econstructor. reflexivity. eassumption.
  Qed.

  Definition terminal G x := ~ exists y, rew_cfg G x y.

  Lemma terminal_iff G x :
    terminal G x <-> forall s y, s el x -> ~ (s, y) el rules G.
  Proof.
    split.
    - intros H s y A B. apply H. destruct (@in_split _ _ _ A) as (l1 & l2 & ->).
      exists (l1 ++ y ++ l2). change (s :: l2) with ([s] ++ l2). now econstructor.
    - intros H1 [y H2]. inv H2. eapply (H1 _ v); eauto.
  Qed.

  Definition L (G : cfg) x := rewt G [startsym G] x /\ terminal G x.

  Definition PALIN (G : cfg) := exists x, L G x /\ x = List.rev x.

End CFGs.

      (* spec    proof comments *)
      (*  62      154      517 pcp_cfg.v *)

Section Reduction.

  Variable P : SRS.

  Definition Sigma := sym P.

  Notation "#" := (fresh Sigma).
  Definition Start := (fresh (# :: Sigma)).

  Definition enc x := fst x ++ [#] ++ snd x ++ [#].

  Definition G1 : cfg :=
    (Start, (Start, [Start]) ::
        (flat_map
           (fun x => [ (Start, (fst x) ++ [Start] ++ enc x);
                      (Start, (fst x) ++ [#] ++ enc x)]) P)).

  Definition G2  : cfg :=
    (Start, (Start, [Start]) ::
        (flat_map
           (fun x => [ (Start, (snd x) ++ [Start] ++ enc x);
                      (Start, (snd x) ++ [#] ++ enc x)]) P)).

  Definition inter_nonempty '(G1, G2) :=
    exists x, @L G1 x /\ L G2 x.

  Lemma in_rules1 x A :
    (x, A) el rules G1 -> x = Start /\ (A = [Start] \/ (exists x M, (M = [Start] \/ M = [#]) /\ ({H : x el P | A = (fst x) ++ M ++ enc x}))).
  Proof.
    cbn. intros [ | ].
    - inv H. intuition.
    - eapply in_flat_map in H as (? & ? & [H | [H | []]]); inv H.
      + intuition. right. exists x0, [Start]; firstorder.
      + intuition. right. exists x0, [#]; firstorder.
  Qed.

  Lemma terminal_G1 x :
    ~ Start el x <->
    terminal G1 x.
  Proof.
    rewrite terminal_iff. split.
    - now intros ? ? ? ? [-> ?] % in_rules1.
    - intros ? ?. eapply (H _ _ H0). now left.
  Qed.

  Lemma in_rules2 x A :
    (x, A) el rules G2 -> x = Start /\ (A = [Start] \/ (exists x M, (M = [Start] \/ M = [#]) /\ ({H : x el P | A = (snd x) ++ M ++ enc x}))).
  Proof.
    cbn. intros [ | ].
    - inv H. intuition.
    - eapply in_flat_map in H as (? & ? & [H | [H | []]]); inv H.
      + intuition. right. exists x0, [Start]; firstorder.
      + intuition. right. exists x0, [#]; firstorder.
  Qed.

  Lemma terminal_G2 x :
    ~ Start el x <->
    terminal G2 x.
  Proof.
    rewrite terminal_iff. split.
    - now intros ? ? ? ? [-> ?] % in_rules2.
    - intros ? ?. eapply (H _ _ H0). now left.
  Qed.

  Definition C1 := tau1.
  Definition C2 := tau2.

  Ltac list_simpl := (repeat (progress (cbn in *; autorewrite with list in *))); cbn in *.

  Lemma start_enc x y :
    x <<= Sigma -> y <<= Sigma ->
    ~ Start el enc (x/y).
  Proof.
    unfold enc. intros ? ? [ | [ [ | []] | [ | [ | [] ] ] % in_app_iff ] % in_app_iff ] % in_app_iff; cbn -[fresh] in *.
    - edestruct fresh_spec with (l := # :: Sigma); try reflexivity; eauto.
    - edestruct fresh_spec with (l := # :: Sigma); eauto.
    - edestruct fresh_spec with (l := # :: Sigma); try reflexivity; eauto.
    - edestruct fresh_spec with (l := # :: Sigma); eauto.
  Qed.

  Definition encoding A := flat_map enc (rev A).

  Lemma start_map_enc A : sym A <<= Sigma ->
    ~ Start el flat_map enc A.
  Proof.
    cbn. intros ? ([x y] & ? & [] % start_enc) % in_flat_map ? ?; eapply H.
    - eapply sym_word_l; eauto.
    - eapply sym_word_R; eauto.
  Qed.

  Hint Rewrite flat_map_concat_map : list.

  Opaque Start.

  Lemma G1_inv x :
    rewt G1 [Start] x -> exists A M, A <<= P /\ ((M = [Start] \/ (M = [#] /\ A <> [])) /\ x = (C1 A) ++ M ++ encoding A).
  Proof.
    unfold encoding. induction 1.
    - exists []. exists [Start]. cbn. firstorder.
    - destruct IHrewt as (A & M & Hsub & [-> | [-> ?]] & ->).
      + inv H0. eapply in_rules1 in H3 as (-> & [-> | (? & ? & [-> | ->] & ? & ->)]); try now firstorder.
        * exists A, [Start]. firstorder.
        * exists (A ++ [x0]), [Start]. assert (A ++ [x0] <<= P) by (intros ? [] % in_app_iff; firstorder subst; firstorder).
          firstorder. unfold C1. list_simpl.
          change (Start :: concat (map enc (rev A))) with
              ([Start] ++ concat (map enc (rev A))) in H1. eapply symmetry in H1.
          eapply list_split in H1 as (B1 & B2 & -> & -> & ?); eauto.
          destruct B1, B2; try destruct B1; try inv H1. cbn. destruct x0. now list_simpl.
          -- intros ? % tau1_sym.
          edestruct fresh_spec with (l := # :: Sigma); try reflexivity. right.
          eapply sym_mono. eassumption. rewrite sym_app. eauto.
          -- intros (? & ? & (? & <- & ?) % in_map_iff) % in_concat_iff. destruct x3. eapply start_enc; try eassumption; eapply in_rev in H3.
             ++ eapply sym_word_l in H3. intros ? ?.
                eapply sym_mono with (A := A);  firstorder.
             ++ eapply sym_word_R in H3. intros ? ?.
                eapply sym_mono with (A := A);  firstorder.
        *  exists (A ++ [x0]), [#]. assert (A ++ [x0] <<= P) by (intros ? [] % in_app_iff; firstorder subst; firstorder).
          firstorder. unfold C1. list_simpl.
          change (Start :: concat (map enc (rev A))) with
              ([Start] ++ concat (map enc (rev A))) in H1. eapply symmetry in H1.
          eapply list_split in H1 as (B1 & B2 & -> & -> & ?); eauto.
          destruct B1, B2; try destruct B1; try inv H1. cbn. destruct x0. now list_simpl.
          -- intros ? % tau1_sym.
          edestruct fresh_spec with (l := # :: Sigma); try reflexivity. right.
          eapply sym_mono. eassumption. rewrite sym_app. eauto.
          -- intros (? & ? & (? & <- & ?) % in_map_iff) % in_concat_iff. destruct x3. eapply start_enc; try eassumption; eapply in_rev in H3.
             ++ eapply sym_word_l in H3. intros ? ?.
                eapply sym_mono with (A := A);  firstorder.
             ++ eapply sym_word_R in H3. intros ? ?.
                eapply sym_mono with (A := A);  firstorder.
      + inv H0. assert (a el x ++ a :: y) by firstorder using in_app_iff.
        eapply in_rules1 in H4 as (-> & [-> | (? & ? & [-> | ->] & ? & ->)]).
        * exists A, [#]. firstorder.
        * exfalso. rewrite H2 in H0. eapply in_app_iff in H0 as [ | [ | ] ].
          -- edestruct (fresh_spec) with (l := # :: Sigma).
             right. eapply sym_mono. eauto. eapply tau1_sym. eassumption. reflexivity.
          -- symmetry in H0. edestruct fresh_spec; try exact H0. firstorder.
          -- eapply start_map_enc; eauto. eapply sym_mono. intros ? ? % in_rev; firstorder.
        * exfalso. rewrite H2 in H0. eapply in_app_iff in H0 as [ | [ | ] ].
          -- edestruct (fresh_spec) with (l := # :: Sigma).
             right. eapply sym_mono. eauto. eapply tau1_sym. eassumption. reflexivity.
          -- symmetry in H0. edestruct fresh_spec; try exact H0. firstorder.
          -- eapply start_map_enc; eauto. eapply sym_mono. intros ? ? % in_rev; firstorder.
  Qed.

  Lemma L1_inv P x :
    L (f1 P) x -> exists A, A <> nil /\ A <<= P /\ (x = embed_string (C1 A) ++ # :: encoding A).
  Proof.
    unfold encoding.
    intros [H1 H2]. eapply G1_inv in H1 as (A & M & Hsub & [ -> | [-> ? ] ] & ->).
    - eapply terminal_f1 in H2. destruct H2. eapply in_app_iff. firstorder.
    - exists A. cbn. eauto.
  Qed.

  Lemma G1_char P A (H : A <<= P) :
    rewt (f1 P) [Start] (embed_string (C1 A) ++ [Start] ++ encoding A).
  Proof.
    unfold encoding. induction A.
    - cbn. reflexivity.
    - assert (a el P) by firstorder.
      rewrite rewrite_sing at 1. Focus 2.
      right. eapply in_flat_map. eauto.
      rewrite IHA at 1.
      list_simpl. rewrite map_rev at 2. cbn. list_simpl. reflexivity. firstorder.
  Qed.

  Lemma L1_char P A (H : A <<= P) : A <> [] ->
    L (f1 P) (embed_string (C1 A) ++ # :: flat_map enc (rev A)).
  Proof.
    intros HA. destruct (list_snoc_inv A) as [-> | (x & A' & ->)]; try congruence. split.
    - cbn. erewrite G1_char with (A := A').
      assert (x el P) by firstorder.
      rewrite rewrite_sing. Focus 2. right. eapply in_flat_map.
      exists x. split. eauto. now right.
      unfold C1, embed_string, encoding. now list_simpl. firstorder.
    - eapply terminal_f1. intros [ [] % start_embed | [ | [] % start_map_enc] ] % in_app_iff. congruence.
  Qed.

  Lemma G2_inv P x :
    rewt (f2 P) [Start] x -> exists A M, A <<= P /\ ((M = [Start] \/ (M = [Hash] /\ A <> [])) /\ x = embed_string (C2 A) ++ M ++ encoding A).
  Proof.
    unfold encoding. induction 1.
    - exists []. exists [Start]. cbn. firstorder.
    - destruct IHrewt as (A & M & Hsub & [-> | [-> ?]] & ->).
      + inv H0. eapply in_rules2 in H3 as (-> & [-> | (? & ? & [-> | ->] & ? & ->)]); try now firstorder.
        * exists A, [Start]. firstorder.
        * exists (A ++ [x0]), [Start]. assert (A ++ [x0] <<= P) by (intros ? [] % in_app_iff; firstorder subst; firstorder).
          firstorder. unfold C2, embed_string. list_simpl.
          change (Start :: concat (map enc (rev A))) with
              ([Start] ++ concat (map enc (rev A))) in H1. eapply symmetry in H1.
          eapply list_split in H1 as (B1 & B2 & -> & -> & ?); eauto.
          destruct B1, B2; try destruct B1; try inv H1. cbn. now list_simpl.
          eapply start_embed. rewrite <- flat_map_concat_map. eapply start_map_enc.
        * exists (A ++ [x0]), [Hash]. assert (A ++ [x0] <<= P) by (intros ? [] % in_app_iff; firstorder subst; firstorder).
          firstorder. unfold C2, embed_string. list_simpl.
          change (Start :: concat (map enc (rev A))) with
              ([Start] ++ concat (map enc (rev A))) in H1. eapply symmetry in H1.
          eapply list_split in H1 as (B1 & B2 & -> & -> & ?); eauto.
          destruct B1, B2; try destruct B1; try inv H1. cbn. now list_simpl.
          eapply start_embed. rewrite <- flat_map_concat_map. eapply start_map_enc.
      + inv H0. assert (a el x ++ a :: y) by firstorder using in_app_iff.
        eapply in_rules2 in H4 as (-> & [-> | (? & ? & [-> | ->] & ? & ->)]); try now firstorder;
          rewrite H2 in H0; eapply in_app_iff in H0 as [ [] % start_embed | [ | [] % start_map_enc]]; congruence.
  Qed.

  Lemma L2_inv P x :
    L (f2 P) x -> exists A, A <> nil /\ A <<= P /\ (x = embed_string (C2 A) ++ # :: flat_map enc (rev A)).
  Proof.
    intros [H1 H2]. eapply G2_inv in H1 as (A & M & Hsub & [ -> | [-> ? ] ] & ->).
    - eapply terminal_f2 in H2. destruct H2. eapply in_app_iff. firstorder.
    - exists A. cbn. eauto.
  Qed.

  Lemma G2_char P A (H : A <<= P) :
    rewt (f2 P) [Start] (embed_string (C2 A) ++ [Start] ++ flat_map enc (rev A)).
  Proof.
    induction A.
    - cbn. reflexivity.
    - assert (a el P) by firstorder.
      rewrite rewrite_sing at 1. Focus 2. right. eapply in_flat_map. eauto.
      rewrite IHA at 1. list_simpl. rewrite map_rev at 2. cbn. now list_simpl.
      firstorder.
  Qed.

  Lemma L2_char P A (H : A <<= P) : A <> [] ->
    L (f2 P) (embed_string (C2 A) ++ # :: flat_map enc (rev A)).
  Proof.
    intros HA. destruct (list_snoc_inv A) as [-> | (x & A' & ->)]; try congruence. split.
    - cbn. erewrite G2_char with (A := A').
      assert (x el P) by firstorder.
      rewrite rewrite_sing. Focus 2. right. eapply in_flat_map.
      exists x. split. eauto. now right.
      unfold C2, embed_string, encoding. now list_simpl. firstorder.
    - eapply terminal_f2. intros [ [] % start_embed | [ | [] % start_map_enc] ] % in_app_iff. congruence.
  Qed.

  Lemma enc_inj A1 A2 :
    encoding A1 = encoding A2 -> A1 = A2.
  Proof.
    enough (forall A1 A2, flat_map enc A1 = flat_map enc A2 -> A1 = A2).
    unfold encoding. intros ? % H. now eapply rev_eq. clear.
    intros A1.  induction A1; intros.
    - destruct A2 as [ | [[]]]. reflexivity. inv H. inv H.
    - destruct a as (x, y). destruct A2. cbn in H. destruct x. inv H. inv H.
      cbn in H. destruct p as (x',y'). cbn in H. list_simpl.
      eapply list_prefix_inv in H as [? [] % list_prefix_inv].
      eapply map_injective in H; eapply map_injective in H0; try firstorder congruence. subst.
      f_equal. eapply IHA1. now rewrite H1, flat_map_concat_map.
      all: intros (? & ? & ?) % in_map_iff; congruence.
  Qed.

  Lemma reduction P :
    PCP P <-> inter_nonempty (f P).
  Proof.
    split.
    - intros (A & Hm & He & Hs).
      pose proof (L1_char He Hm).
      pose proof (L2_char He Hm).
      rewrite Hs in H. eexists. eauto.
    - intros (x & (A1 & H1 & Hs1 & ?) % L1_inv & (A2 & H2 & Hs2 & ->) % L2_inv).
      eapply list_prefix_inv in H as [].
      unfold embed_string in H. eapply map_injective in H; try firstorder congruence.
      eapply enc_inj in H0. subst.
      exists A1. repeat split. firstorder. firstorder. hnf. unfold C2 in H. now rewrite H.
      all : unfold embed_string; intros (? & ? & ?) % in_map_iff; congruence.
  Qed.

End Reduction.

Definition mapo X Y (f : X -> option Y) (A : list X) : list Y :=
  concat (map (fun x => match f x with None => [] | Some y => [y] end) A).

Lemma mapo_app X Y (f : X -> option Y) A B :
  mapo f (A ++ B) = mapo f A ++ mapo f B.
Proof.
  unfold mapo. now autorewrite with list.
Qed.
Hint Rewrite mapo_app : list.

Section TrivialLift.

  Variable Gamma' : finType.
  Variable Gamma : finType.

  Variable f : Gamma' -> Gamma.
  Variable g : Gamma -> option Gamma'.

  Hypothesis inv : forall x, g (f x) = Some x.
  Hypothesis tight : forall x y, g x = Some y -> f y = x.

  Definition up (G : cfg Gamma') : cfg Gamma :=
    (f (startsym G), map (fun '(x,A) => (f x, map f A) ) (rules G)).

  Lemma mapo_map x :
    mapo g  (map f x) = x.
  Proof.
    induction x.
    - reflexivity.
    - cbn. rewrite inv. now rewrite <- IHx at 2.
  Qed.

  Lemma up_rew1 G x y :
    rew_cfg G x y -> rew_cfg (up G) (map f x) (map f y).
  Proof.
    intros H. inv H. autorewrite with list.
    cbn [map]. econstructor.  eapply in_map_iff. exists (a, v). eauto.
  Qed.

  Lemma up_rew2 G x y :
    rew_cfg (up G) x y -> rew_cfg G (mapo g x) (mapo g y).
  Proof.
    intros H. inv H. cbn in H0.
    eapply in_map_iff in H0 as ([] & ? & ?). inv H. autorewrite with list.
    cbn [mapo concat map]. rewrite inv. change ([e] ++ []) with [e].
    econstructor. unfold mapo. autorewrite with list. erewrite map_ext with (g := fun x => [ x ]).
    enough (l = concat (map (fun x => [x]) l)) as <- by trivial.
    clear; induction l; cbn; congruence. intros; now rewrite inv.
  Qed.
 Lemma up_char1 G x y :
    rewt G x y -> rewt (up G) (map f x) (map f y).
  Proof.
    induction 1.
    - reflexivity.
    - rewrite IHrewt. econstructor. reflexivity. eapply up_rew1. eauto.
  Qed.

  Lemma up_char2 G x y :
    rewt (up G) x y -> rewt G (mapo g x) (mapo g y).
  Proof.
    induction 1.
    - reflexivity.
    - rewrite IHrewt. econstructor. reflexivity. eapply up_rew2. eauto.
  Qed.

  Lemma up_ter1 G x :
    terminal G x -> terminal (up G) (map f x).
  Proof.
    intros ? [? ?]. eapply H.
    exists (mapo g x0). eapply up_rew2 in H0. now rewrite mapo_map in *.
  Qed.

  Lemma up_ter2 G y :
    terminal (up G) y -> terminal G (mapo g y).
  Proof.
    intros H. rewrite terminal_iff in H.
    eapply terminal_iff. intros. unfold mapo in H0.
    eapply in_concat_iff in H0 as (? & ? & (? & ? & ?) % in_map_iff).
    destruct (g x0) eqn:E; subst; destruct H0. subst. intros ?.
    eapply (H _ (map f y0) H2). cbn. eapply in_map_iff.
    exists (s, y0). eapply tight in E. subst. eauto. destruct H0.
  Qed.

  Lemma up_char G x :
    rewt G [(startsym G)] x <-> rewt (up G) [(startsym (up G))] (map f x).
  Proof.
    split; intros H.
    - eapply up_char1 in H. eassumption.
    - eapply up_char2 in H. cbn in H. now rewrite mapo_map,  inv, app_nil_r in H.
  Qed.

End TrivialLift.

Module Hesselink.

Section ReductionHesselink.

  Variable Sigma' : Type.

  Variable P : pcp Sigma'.

  Inductive Sigma := embed (s : Sigma') | Start | hash.

  Definition embed_string (s : list Sigma') := map embed s.

  Notation "#" := hash.

  Definition f : pcp Sigma' -> cfg Sigma :=
    fun P =>
      (Start, (Start, [Start]) ::
        (flat_map
           (fun x => [ (Start, embed_string (fst x) ++ [Start] ++ embed_string (rev (snd x)));
                          (Start, embed_string (fst x) ++ [#] ++ embed_string (rev (snd x)))])
           P)).

  Lemma in_rules x A :
    (x, A) el rules (f P) -> x = Start /\ (A = [Start] \/ (exists x M, (M = Start \/ M = #) /\ x el P /\ A = embed_string (fst x) ++ [M] ++ embed_string (rev (snd x)))).
  Proof.
    unfold f. cbn. intros [ | (? & ? & [H | [H | []]]) % in_flat_map]; inv H.
    - intuition.
    - intuition. right. exists x0, Start; firstorder.
    - intuition. right. exists x0, #; firstorder.
  Qed.

  Lemma terminal_f x :
    ~ Start el x <->
    terminal (f P) x.
  Proof.
    rewrite terminal_iff. split.
    - now intros ? ? ? ? [-> ?] % in_rules.
    - intros ? ?. eapply (H _ _ H0). now left.
  Qed.

  Inductive L_ind (P : pcp Sigma') : list Sigma -> pcp Sigma' -> Prop :=
  | L_ind_stop x y : (x,y) el P -> L_ind P (embed_string x ++ [#] ++ embed_string (rev y)) [(x,y)]
  | L_ind_start : L_ind P [Start] []
  | L_ind_step x y z A : (x, y) el P -> L_ind P z A -> L_ind P (embed_string x ++ z ++ embed_string (rev y)) ((x,y)::A).
  Hint Constructors L_ind.

  Lemma L_ind_to x A :
    L_ind P x A -> rewt (f P) [Start] x.
  Proof.
    intros H.
    induction H.
      + rewrite rewrite_sing. reflexivity. right.
        eapply in_flat_map. exists (x, y). firstorder.
      + reflexivity.
      + rewrite rewrite_sing at 1. Focus 2.
        * right. eapply in_flat_map.
          exists (x, y). firstorder.
          rewrite IHL_ind. reflexivity.
  Qed.

  Lemma Start_embed_string x :
    ~ Start el embed_string x.
  Proof.
    unfold embed_string. intros [? ?] % in_map_iff. firstorder congruence.
  Qed.
  Hint Immediate Start_embed_string.

  Lemma L_ind_insert M :
    forall (A : list (list Sigma' * list Sigma')) (x0 : list Sigma' * list Sigma'),
      x0 el P -> (M = # \/ M = Start) ->
      forall x y0 : list Sigma,
        L_ind P (x ++ [Start] ++ y0) A ->
        L_ind P (x ++ (embed_string (fst x0) ++ M :: embed_string (rev (snd x0))) ++ y0) (A ++ [(fst x0, snd x0)]).
  Proof.
    intros A x0 H HM.
    induction A; intros x y0 H1; cbn in *; inv H1.
    * destruct x, y0; [ | try destruct x; inv H2..].
      rewrite app_nil_r. destruct x0. destruct HM; subst. now econstructor. cbn.
      change (Start :: map embed (rev l0)) with ([Start] ++ map embed (rev l0)). now econstructor.
    * cbn.
      enough (~ Start el embed_string x1 ++ # :: embed_string (rev y)).
      rewrite H0 in H1. destruct H1.
      eapply in_app_iff. firstorder. unfold embed_string.
      intros [[] % in_map_iff | [? | [] % in_map_iff]] % in_app_iff; firstorder congruence.
    * eapply list_split in H0 as (B1 & B2 & -> & -> & ->); eauto.
      replace (((embed_string x1 ++ B1) ++ (embed_string (fst x0) ++ M :: embed_string (rev (snd x0))) ++ B2 ++ embed_string (rev y))) with
          (embed_string x1 ++ (B1 ++ ((embed_string (fst x0) ++ M :: embed_string (rev (snd x0)))) ++ B2) ++ embed_string (rev y)) by now autorewrite with list. eauto.
  Qed.

  Lemma L_ind_char x :
    rewt (f P) [Start] x <-> exists A, L_ind P x A.
  Proof.
    split.
    - induction 1.
      + exists []. econstructor.
      + inv H0. destruct IHrewt as [A IH].
        apply in_rules in H1 as (-> & [-> | (? & ? & [-> | ->] & ? & ->)]); try now firstorder.
        * exists (A ++ [(fst x0, snd x0)]); eapply L_ind_insert; eauto.
        * exists (A ++ [(fst x0, snd x0)]); eapply L_ind_insert; eauto.
    - intros [A H]. eapply L_ind_to. eassumption.
  Qed.

  Lemma L_ind_char2 A :
    A <> nil /\ A <<= P <-> exists x, ~ startsym (f P) el x /\ L_ind P x A.
  Proof.
    split.
    - intros. induction A.
      + tauto.
      + destruct a as (x, y). destruct A.
        * exists (embed_string x ++ [#] ++ embed_string (rev y)). split.
          -- cbn. intros [ | [ | ] ] % in_app_iff; try congruence; eapply Start_embed_string; eauto.
          -- econstructor. firstorder.
        * destruct IHA as [z IH]; try firstorder congruence.
          exists (embed_string x ++ z ++ embed_string (rev y)). split.
          -- cbn in *. intros [ | [ | ] % in_app_iff ] % in_app_iff; try tauto; eapply Start_embed_string; eauto.
          -- econstructor; firstorder.
    - intros [x []]. split.
      + inv H0; firstorder.
      + clear H. induction H0; intuition.
  Qed.

  Ltac list_simpl := (repeat (progress (cbn; autorewrite with list))); cbn.

  Definition concat_map A B (f : A -> list B) x := concat (map f x).
  Lemma L_ind_inv x (A : pcp _) :
    L_ind P x A ->
    exists M, (M = Start \/ M = #) /\ x = embed_string (concat_map fst A) ++ [M] ++ embed_string (concat_map (@rev _ ∘ snd) (rev A)).
  Proof.
    induction 1.
    - exists #. list_simpl. firstorder.
    - exists Start. cbn. firstorder.
    - destruct IHL_ind as (M & [-> | ->] & ->).
      + exists Start. firstorder. unfold embed_string, concat_map. now list_simpl.
      + exists #. firstorder. unfold embed_string, concat_map. now list_simpl.
  Qed.

  Lemma L_ind_palindrome x A :
    L_ind P x A ->
    x = rev x <-> solution A.
  Proof.
    intros H. unfold solution.
    enough (exists M, (forall s, ~ M el embed_string s) /\ x = embed_string (concat_map fst A) ++ [M] ++ embed_string (concat_map (@rev _ ∘ snd) (rev A))) as (M & ? & ->).
    unfold embed_string, concat_map. list_simpl. split; intros E.
    - eapply list_prefix_inv in E as [E _]; firstorder.
      eapply map_injective in E; [|  intuition congruence].
      rewrite E. f_equal. eapply map_ext. intros; now list_simpl.
    - rewrite E. f_equal; [|f_equal].
      do 2 f_equal. eapply map_ext; intros; now list_simpl. f_equal.
      rewrite !map_rev. rewrite <- map_map. rewrite !concat_rev. rewrite <- E.
      rewrite <- map_map with (g := @rev _). now rewrite concat_rev.
    - eapply L_ind_inv in H as (? & [-> | ->] & ->); eexists; split; try reflexivity.
      firstorder using Start_embed_string. intros ? ?. unfold embed_string in H.
      eapply in_map_iff in H. firstorder congruence.
  Qed.

  Theorem PCP_CFG :
    PCP P <-> PALIN (f P).
  Proof.
    split.
    - intros [A (? & ? & H)].
      edestruct (L_ind_char2) as [ (? & ? & ?) _ ]. eauto.
      unfold PALIN. exists x. split. split.
      + eapply L_ind_char. eauto.
      + eapply terminal_f. exact H2.
      + eapply L_ind_palindrome; eauto.
    - intros (S & [[A H] % L_ind_char H2 % terminal_f] & Hr). unfold PCP.
      exists A. repeat split; [ eapply L_ind_char2; eauto.. | ].
      eapply L_ind_palindrome; eauto.
  Qed.

End ReductionHesselink.

Section Palindrome.

  Variable Gamma' : finType.
  Inductive Gamma := emb (x : Gamma') | StartG.

  Global Instance eq_dec_gamma : eq_dec Gamma.
  Proof.
    intros ? ?. hnf. decide equality.
    assert (H : eq_dec Gamma') by exact _. apply H.
  Defined.

  Global Instance fin_gamma : finTypeC (EqType Gamma).
  Proof.
    exists (StartG :: map emb (elem Gamma')).
    intros []; cbn. admit. edestruct notInZero. rewrite H. reflexivity.
    intros (? & ? & ?) % in_map_iff. congruence.
  Admitted.

  Definition emb_string := map emb.

  Definition palin_G : cfg Gamma :=
    (StartG, (StartG, []) ::
     flat_map (fun g => [ (StartG, [emb g]);  (StartG, [emb g; StartG; emb g]) ]) (elem Gamma')).

  Lemma G_left x :
    rewt palin_G [StartG] x -> rev x = x /\ count x StartG <= 1.
  Proof.
    induction 1.
    - firstorder.
    - destruct IHrewt as [IH Eq]. inv H0. cbn in H1. destruct H1.
      + inv H0. rewrite <- !countSplit in *. autorewrite with list in *. cbn in *. split; try omega.
        assert (count x StartG = 0) as H1 % notInZero by omega.
        assert (count y0 StartG = 0) as H2 % notInZero by omega.
        eapply list_prefix_inv in IH as [<- _]; try rewrite <- in_rev; eauto.
        now rewrite rev_involutive.
      + eapply in_flat_map in H0 as (? & ? & [ | [ | [] ]]).
        * inv H1. rewrite <- !countSplit in *. autorewrite with list in *. cbn in *. split; try omega.
          assert (count x StartG = 0) as H1 % notInZero by omega.
          assert (count y0 StartG = 0) as H2 % notInZero by omega.
          eapply list_prefix_inv in IH as [ <- _]; try rewrite <- in_rev; eauto.
          now rewrite rev_involutive.
        * inv H1. rewrite <- !countSplit in *. autorewrite with list in *. cbn in *. split; try omega.
          assert (count x StartG = 0) as H1 % notInZero by omega.
          assert (count y0 StartG = 0) as H2 % notInZero by omega.
          eapply list_prefix_inv in IH as [<- _]; try rewrite <- in_rev; eauto.
          now rewrite rev_involutive.
  Qed.

  Lemma listI : forall (A : Type) (P : list A -> Prop), P [] -> (forall x, P [x]) -> (forall (x : A) (y : A) (l : list A), P l -> P (x :: l ++ [y])) -> forall l : list A, P l.
  Proof.
    intros. pattern l. revert l. apply size_induction with (f := @length _). intros.
    destruct x.
    - auto.
    - revert H2. pattern x. revert x. apply rev_ind. auto.
      intros. apply H1. apply H3. cbn. rewrite app_length. omega.
  Qed.

  Lemma rev_palin x :
    x = rev x -> count x StartG <= 1 -> rewt palin_G [StartG] x.
  Proof.
    pattern x. revert x. apply listI; intros.
    - rewrite rewrite_sing. reflexivity. now left.
    - destruct x. rewrite rewrite_sing. reflexivity. right. eapply in_flat_map. eauto. reflexivity.
    - cbn in H0. autorewrite with  list in *. inv H0.
      cbn in H1. rewrite <- countSplit in H1.
      destruct y.
      + rewrite rewrite_sing with (x := [emb x] ++ [StartG] ++ [emb x]).
        rewrite H.
        * cbn. reflexivity.
        * now eapply app_inv_tail in H4.
        * cbn in *; omega.
        * right. eapply in_flat_map. cbn. eauto.
      + cbn in *. omega.
  Qed.

  Lemma emb_Start x :
    ~ StartG el emb_string x.
  Proof.
    intros ?. unfold emb_string in *. eapply in_map_iff in H. firstorder congruence.
  Qed.

  Lemma G_char (x : list Gamma') :
    x = rev x <-> L palin_G (emb_string x).
  Proof.
    split.
    - intros H. split.
      + assert (emb_string x = rev (emb_string x)). rewrite H. unfold emb_string. autorewrite with list. congruence.
        eapply rev_palin in H0. eassumption.
        enough (count (emb_string x) StartG = 0) by omega.
        eapply notInZero. eapply emb_Start.
      + intros [y Hy].
        inv Hy. destruct H2. inv H1.
        eapply emb_Start. rewrite <- H0. eapply in_app_iff. firstorder.
        eapply in_flat_map in H1 as (? & ? & [ | [ | [] ]]).
        * inv H2. eapply emb_Start. rewrite <- H0. eapply in_app_iff. firstorder.
        * inv H2.  eapply emb_Start. rewrite <- H0. eapply in_app_iff. firstorder.
    - intros [[] % G_left Ht]. unfold emb_string in *.
      autorewrite with list in *. eapply map_injective in H; intuition congruence.
  Qed.

  Definition rem_S x := mapo (fun x => match x with StartG => None | emb x => Some x end) x.

  Lemma rem_S_rev x :
    rev (rem_S x) = rem_S (rev x).
  Proof.
    induction x.
    - reflexivity.
    - cbn [rev]. unfold rem_S in *. rewrite mapo_app, <- IHx. unfold  mapo. cbn. destruct a; now autorewrite with list.
  Qed.

  Lemma rem_S_cons x0 x :
    rem_S (emb x0 :: x) = x0 :: rem_S x.
  Proof.
    cbn. reflexivity.
  Qed.

  Lemma rem_S_char x :
    ~ StartG el x -> emb_string (rem_S x) = x.
  Proof.
    induction x.
    - reflexivity.
    - intros. destruct a.
      + rewrite rem_S_cons. cbn. rewrite IHx. reflexivity. firstorder.
      + firstorder.
  Qed.

End Palindrome.

Hint Rewrite mapo_app : list.

Definition inter_nonempty X '(G1, G2) :=
  exists x, @L X G1 x /\ L G2 x.

Theorem intersect (Sigma : finType) (G : cfg Sigma) :
  exists f, PALIN G <-> @inter_nonempty (Gamma Sigma) (f G).
Proof.
  exists (fun G => (palin_G Sigma, up (@emb Sigma) G)). split; intros (? & ? & ?).
  - exists (emb_string x). rewrite <- G_char. intuition. destruct H. split.
    + eapply up_char1 in H. eapply H.
    + eapply up_ter1 with (g :=  fun x => match x with emb x => Some x | _ => None end) in H1.
      eapply H1. reflexivity.
  - destruct H. eapply G_left in H.
    exists (rem_S x). split. destruct H0. split.
    + eapply up_char2 in H0. unfold rem_S. now rewrite <- H0.
      tauto.
    + eapply up_ter2 with (g :=  fun x => match x with emb x => Some x | _ => None end) in H2.
      eapply H2. cbn. intros []; intuition congruence.
    + rewrite rem_S_rev. destruct H. now rewrite H.
Qed.

End Hesselink.


Require Import Basics.
Require Import Types.
Require Import Diagrams.Diagram.
Require Import Diagrams.DDiagram.
Require Import Diagrams.Span.
Require Import Diagrams.Cocone.
Require Import Colimits.Colimit.
Require Import Colimits.Colimit_Pushout.
Require Import Colimits.Colimit_Flattening.

(** * Pushout case *)

(** We show the flattening lemma in the case of the pushout. *)

Section POCase.
  Context `{Univalence} {A B C} {f: A -> B} {g: A -> C}.

  Context (A0 : A -> Type) (B0 : B -> Type) (C0 : C -> Type)
          (f0 : forall x, A0 x <~> B0 (f x)) (g0 : forall x, A0 x <~> C0 (g x)).

  Definition POCase_P : PO f g -> Type.
  Proof.
    simple refine (PO_rec Type B0 C0 _).
    cbn; intro x. eapply path_universe_uncurried.
    etransitivity.
    - symmetry. apply f0.
    - apply g0.
  Defined.

  Definition POCase_E : DDiagram (span f g).
  Proof.
    simple refine (Build_Diagram _ _ _); cbn.
    - intros [[] x]; revert x.
      + exact A0.
      + destruct b; assumption.
    - intros [[[]|[]] x] [[[]|[]] y]; cbn; intros [[] p].
      + exact (fun y => p # (f0 x y)).
      + exact (fun y => p # (g0 x y)).
  Defined.

  Global Instance POCase_HE : Equifibered POCase_E.
  Proof.
    apply Build_Equifibered.
    intros [[]|[]] [[]|[]] [] x; compute.
    - exact (equiv_isequiv (f0 x)).
    - exact (equiv_isequiv (g0 x)).
  Defined.

  Definition PO_flattening
    : PO (functor_sigma f f0) (functor_sigma g g0) <~> exists x, POCase_P x.
  Proof.
    assert (PO (functor_sigma f f0) (functor_sigma g g0)
            = Colimit (diagram_sigma POCase_E)). {
      unfold PO; apply ap.
      srapply path_diagram; cbn.
      - intros [|[]]; cbn. all: reflexivity.
      - intros [[]|[]] [[]|[]] [] x; cbn in *.
        all: reflexivity. }
    rewrite X; clear X.
    transitivity (exists x, E' (span f g) POCase_E POCase_HE x).
    - apply flattening_lemma.
    - apply equiv_functor_sigma_id.
      intro x.
      assert (E' (span f g) POCase_E POCase_HE x = POCase_P x). {
        unfold E', POCase_P, PO_rec.
        f_ap. srapply path_cocone.
        - intros [[]|[]] y; cbn.
          1: apply path_universe_uncurried; apply g0.
          all: reflexivity.
        - intros [[]|[]] [[]|[]] []; cbn.
          + intro y; simpl; hott_simpl.
            unfold path_universe.
            rewrite <- path_universe_V_uncurried.
            refine (path_universe_compose (f0 y)^-1 (g0 y))^.
          + intros; apply concat_Vp. }
      rewrite X. reflexivity.
  Defined.

End POCase.


Require Import List.
Require Import Arith.
Require Import Program.

Require Import Axioms.
Require Import TypeSyntax.
Require Import Semantics.
Require Import Shifting.
Require Import Substitution.
Require Import TypeSystem.

Set Implicit Arguments.

(********************************************************************************)
Fixpoint context_sem g (e:ty_environment g) (ctxt:context g) : Set :=
  match ctxt with
    | nil => unit
    | cons a ctxt => (context_sem e ctxt * ty_sem e a)%type
  end.

Definition lookup_ctxt : forall g i (ctxt:context g) ty, In i ctxt ty -> forall e, context_sem e ctxt -> ty_sem e ty.
intros g i ctxt ty i0. induction i0; intros.
 destruct H. apply t.
 destruct H. apply IHi0. apply c.
Defined.

Definition context_rel : forall g (e1 e2 : ty_environment g) ctxt, rel_environment e1 e2 -> context_sem e1 ctxt -> context_sem e2 ctxt -> Prop.
intros g e1 e2 ctxt re.
induction ctxt.
 exact (fun _ _ => True).
 intros [g1 a1] [g2 a2]. apply and.
  apply (IHctxt g1 g2).
  apply (ty_rel re a a1 a2).
Defined.

Lemma lookup_ctxt_rel : forall g i ctxt ty
  (e1 e2 : ty_environment g)
  (re : rel_environment e1 e2)
  (g1 : context_sem e1 ctxt)
  (g2 : context_sem e2 ctxt)
  (i0 : In i ctxt ty),
  context_rel ctxt re g1 g2 ->
  ty_rel re ty (lookup_ctxt i0 e1 g1) (lookup_ctxt i0 e2 g2).
induction i0; intros; simpl in *.
 destruct g1 as [g1 x1]. destruct g2 as [g2 x2]. destruct H. apply H0.
 destruct g1 as [g1 x1]. destruct g2 as [g2 x2]. apply IHi0. destruct H. apply H.
Defined.

Definition context_sem_shift1 : forall g (e : ty_environment g) ctxt A,
  context_sem e ctxt ->
  context_sem (A;:e) (context_shift1 ctxt).
induction ctxt; intros.
 simpl. trivial.
 simpl in *. destruct H. split.
  apply IHctxt. apply c.
  apply ty_sem_shift1. apply t.
Defined.

Definition context_rel_shift1 : forall g (e1 e2:ty_environment g) re ctxt A1 A2 R g1 g2,
  context_rel ctxt re g1 g2 ->
  context_rel (context_shift1 ctxt) (R;;re) (context_sem_shift1 e1 ctxt A1 g1) (context_sem_shift1 e2 ctxt A2 g2).
induction ctxt; intros.
 simpl. trivial.
 simpl in *. destruct g1. destruct g2. destruct H. split.
  apply IHctxt. apply H.
  apply ty_rel_shift1. apply H0.
Defined.

Lemma context_rel_diagonal : forall g (e:ty_environment g) ctxt s,
  context_rel ctxt (diagonal e) s s.
intros g e ctxt s. induction ctxt.
 simpl. trivial.
 simpl. destruct s. split.
  apply IHctxt.
  rewrite rel_diagonal. reflexivity.
Save.

Definition term_sem : forall g ctxt ty,
  term ctxt ty ->
  { x : forall (e : ty_environment g), context_sem e ctxt -> ty_sem e ty
    | forall (e1 e2 : ty_environment g) (re : rel_environment e1 e2)
             (g1:context_sem e1 ctxt) (g2:context_sem e2 ctxt),
      context_rel ctxt re g1 g2 -> ty_rel re ty (x e1 g1) (x e2 g2) }.
intros g ctxt ty tm.
induction tm.
 (* t_var *)
 exists (lookup_ctxt i0).
 auto using lookup_ctxt_rel.
 (* t_app *)
 destruct IHtm1 as [tm1_sem tm1_rel].
 destruct IHtm2 as [tm2_sem tm2_rel].
 exists (fun e s => tm1_sem e s (tm2_sem e s)).
 intros. apply tm1_rel. apply H. apply tm2_rel. apply H.
 (* t_abs *)
 destruct IHtm as [tm_sem tm_rel].
 exists (fun e s x => tm_sem e (s,x)).
 unfold ty_rel. simpl. intros.
 simpl. apply tm_rel. simpl. split; assumption.
 (* t_tyabs *)
 destruct IHtm as [tm_sem tm_rel].
 unfold ty_sem. simpl.
 unfold ty_rel in tm_rel.
 exists (fun e s =>
          exist (fun x => forall (A1 A2 : Set) (R : A1 -> A2 -> Prop), ty_rel (R;;diagonal e) ty (x A1) (x A2))
                (fun A => tm_sem (A;:e) (context_sem_shift1 e ctxt A s))
                (fun A1 A2 R => tm_rel (A1;:e) (A2;:e) (R;;diagonal e)
                                       (context_sem_shift1 e ctxt A1 s) (context_sem_shift1 e ctxt A2 s)
                                       (context_rel_shift1 (diagonal e) ctxt R s s (context_rel_diagonal e ctxt s)))).
 unfold ty_rel. simpl.
 intros. apply tm_rel. apply context_rel_shift1. assumption.
 (* t_tyapp *)
 destruct IHtm as [tm_sem tm_rel].
 unfold ty_sem in tm_sem. unfold ty_rel in *. simpl in *.
 exists (fun e s => type_subst1_sem ty1 ty2 e (projT1 (tm_sem e s) (ty_sem e ty2))).
 intros. apply type_subst1_rel. apply tm_rel. assumption.
Defined.


(* ---------------------------------------------------------------------
   This file contains definitions and proof scripts related to the
   correctness of simplification  algorithms for context-free grammars,
   namely empty rules elimination, unit rules elimination, useless symbol
   elimination and inaccessible symbol elimination.
   More information can be found in the paper "Formalization of
   simplification for context-free grammars", LSFA 2015.
   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - INACESSIBLE SYMBOLS                                  *)
(* --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.

Require Import misc_arith.
Require Import misc_list.
Require Import cfg useless.

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

Import ListNotations.
Open Scope list_scope.

Section Inaccessible.

Variables terminal non_terminal: Type.
Notation sf := (list (non_terminal + terminal)).
Notation sentence := (list terminal).
Notation nlist:= (list non_terminal).
Notation tlist:= (list terminal).

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - INACCESSIBLE SYMBOLS - DEFINITIONS                   *)
(* --------------------------------------------------------------------- *)

Definition accessible (g: cfg _ _) (s: non_terminal + terminal): Prop:=
exists s1 s2: sf, derives g [inl (start_symbol g)] (s1++s::s2).

Inductive g_acc_rules (g: cfg _ _): non_terminal -> sf -> Prop :=
| Lift_acc : forall left: non_terminal,
             forall right: sf,
             rules g left right -> accessible g (inl left) -> g_acc_rules g left right.

Lemma g_acc_finite:
forall g: cfg _ _,
exists n: nat,
exists ntl: nlist,
exists tl: tlist,
In (start_symbol g) ntl /\
forall left: non_terminal,
forall right: sf,
g_acc_rules g left right ->
(length right <= n) /\
(In left ntl) /\
(forall s: non_terminal, In (inl s) right -> In s ntl) /\
(forall s: terminal, In (inr s) right -> In s tl).
Proof.
intros g.
destruct (rules_finite g) as [n [ntl [tl H1]]].
exists n, ntl, tl.
split.
- destruct H1 as [H1 _].
  exact H1.
- destruct H1 as [_ H1].
  intros left right H2.
  inversion H2.
  subst.
  specialize (H1 left right H).
  destruct H1 as [H4 [H5 H6]].
  split.
  + exact H4.
  + split.
    * exact H5.
    * exact H6.
Qed.

Definition g_acc (g: cfg _ _): cfg _ _ := {|
start_symbol:= start_symbol g;
rules:= g_acc_rules g;
rules_finite:= g_acc_finite g
|}.

Definition has_no_inaccessible_symbols (g: cfg _ _): Prop:=
forall s: _, appears g s -> accessible g s.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - INACCESSIBLE SYMBOLS - LEMMAS AND THEOREMS           *)
(* --------------------------------------------------------------------- *)

Lemma accessible_g_g_acc:
forall g: cfg _ _,
forall s: non_terminal + terminal,
accessible g s -> accessible (g_acc g) s.
Proof.
intros g s H0.
unfold accessible in H0.
unfold accessible.
destruct H0 as [s1 [s2 H1]].
apply derives_sflist in H1.
destruct H1 as [l [H2 [H3 H4]]].
exists s1, s2.
simpl.
apply derives_sflist.
exists l.
split.
- assert (H5: length l >= 2 \/ length l < 2) by omega.
  destruct H5 as [H5 | H5].
  + assert (H5':=H5).
    apply sflist_rules with (g:=g) in H5.
    apply sflist_rules.
    * exact H5'.
    * intros i H6.
      destruct H5 as [H5 _].
      specialize (H5 H2 i H6).
      destruct H5 as [left [right [s3 [s' [H10 [H11 H12]]]]]].
      exists left, right, s3, s'.
      {
      split.
      - exact H10.
      - split.
        + exact H11.
        + simpl.
          apply Lift_acc.
          * exact H12.
          * exists s3, s'.
            rewrite <- (firstn_skipn (S i) l) in H2.
            apply sflist_app_r in H2.
            apply derives_sflist.
            exists (firstn (S i) l).
            {
            split.
            - exact H2.
            - split.
              + rewrite <- H3.
                rewrite hd_first.
                * reflexivity.
                * omega.
              + rewrite <- H10.
                apply last_first_nth.
                omega.
            }
      }
  + destruct l as [| s3 l].
    * apply sflist_empty.
    * {
      replace (s3::l) with ([s3]++l) in H5.
      - rewrite app_length in H5.
        simpl in H5.
        assert (H7: length l = 0) by omega.
        apply length_zero in H7.
        rewrite H7.
        apply sflist_start.
      - simpl.
        reflexivity.
      }
- split.
  + exact H3.
  + exact H4.
Qed.

Lemma sflist_g_acc_g:
forall g: cfg _ _,
forall l: list sf,
sflist (g_acc g) l -> sflist g l.
Proof.
intros g l H.
induction H.
- apply sflist_empty.
- apply sflist_start.
- apply sflist_step with (left:=left).
  exact IHsflist.
  exact H0.
  simpl in H1.
  inversion H1.
  exact H2.
Qed.

Lemma produces_g_acc_g:
forall g: cfg _ _,
forall s: sentence,
produces (g_acc g) s -> produces g s.
Proof.
unfold produces.
unfold generates.
intros g s H.
apply derives_sflist in H.
destruct H as [l [H1 [H2 H3]]].
simpl in H2.
apply derives_sflist.
exists l.
split.
- apply sflist_g_acc_g.
  exact H1.
- split.
  + exact H2.
  + exact H3.
Qed.

Lemma acc_step:
forall g: cfg _ _,
forall n: non_terminal,
forall right: sf,
accessible g (inl n) -> rules g n right ->
forall s: non_terminal + terminal,
In s right -> accessible g s.
Proof.
intros g n right H1 H2 s H3.
unfold accessible in H1.
unfold accessible.
destruct H1 as [s1 [s2 H4]].
apply derives_step with (right:=right) in H4.
- apply in_split in H3.
  destruct H3 as [l1 [l2 H5]].
  rewrite H5 in H4.
  rewrite <- app_assoc in H4.
  exists (s1++l1), (l2++s2).
  rewrite <- app_assoc.
  exact H4.
- exact H2.
Qed.

Lemma sflist_g_g_acc:
forall g: cfg _ _,
forall l: list sf,
sflist g l /\ hd [] l = [inl (start_symbol g)] -> sflist (g_acc g) l.
Proof.
intros g l [H1 H2].
assert (H3: length l >= 2 \/ length l < 2) by omega.
destruct H3 as [H3 | H3].
- assert (H3':=H3).
  apply sflist_rules with (g:=g) in H3.
  destruct H3 as [H3 _].
  specialize (H3 H1).
  apply sflist_rules.
  + exact H3'.
  + intros i H4.
    specialize (H3 i H4).
    destruct H3 as [left [right [s0 [s' [H5 [H6 H7]]]]]].
    exists left, right, s0, s'.
    split.
    * exact H5.
    * {
      split.
      - exact H6.
      - simpl.
        apply Lift_acc.
        + exact H7.
        + assert (H20: derives g [inl (start_symbol g)] (s0 ++ inl left :: s')).
            {
            apply derives_sflist.
            rewrite <- (firstn_skipn (S i) l) in H1.
            apply sflist_app_r in H1.
            exists (firstn (S i) l).
            split.
            - exact H1.
            - split.
              + rewrite hd_first.
                * exact H2.
                * omega.
              + rewrite <- H5.
                apply last_first_nth.
                omega.
            }
          exists s0, s'.
          exact H20.
      }
- destruct l as [| s l].
  + apply sflist_empty.
  + destruct l as [| s0 l].
    * apply sflist_start.
    * {
      replace (s :: s0 :: l) with ([s] ++ [s0] ++ l) in H3.
      - repeat rewrite app_length in H3.
        simpl in H3.
        repeat apply lt_S_n in H3.
        apply lt_n_0 in H3.
        contradiction.
      - simpl.
        reflexivity.
      }
Qed.

Lemma produces_g_g_acc:
forall g: cfg _ _,
forall s: sentence,
produces g s -> produces (g_acc g) s.
Proof.
unfold produces.
unfold generates.
intros g s H.
apply derives_sflist in H.
destruct H as [l [H1 [H2 H3]]].
apply derives_sflist.
exists l.
split.
- apply sflist_g_g_acc.
  split.
  + exact H1.
  + exact H2.
- split.
  + simpl.
    exact H2.
  + exact H3.
Qed.

Theorem g_equiv_acc:
forall g: cfg _ _,
g_equiv (g_acc g) g.
Proof.
unfold g_equiv.
intros g s.
split.
- apply produces_g_acc_g.
- apply produces_g_g_acc.
Qed.

Lemma g_acc_has_no_inaccessible_symbols:
forall g: cfg _ _,
has_no_inaccessible_symbols (g_acc g).
Proof.
unfold has_no_inaccessible_symbols.
intros g n H.
destruct n as [nt | t].
- inversion H.
  destruct H0 as [right [H1 H2]].
  destruct H2 as [H2 | H2].
  + subst.
    simpl in H1.
    inversion H1.
    subst.
    apply accessible_g_g_acc.
    exact H2.
  + subst.
    simpl in H1.
    inversion H1.
    apply accessible_g_g_acc.
    subst.
    apply acc_step with (s:=inl nt) (right:=right) in H3.
    * exact H3.
    * exact H0.
    * exact H2.
- inversion H.
  destruct H0 as [right [H1 H2]].
  simpl in H1.
  inversion H1.
  subst.
  apply acc_step with (s:=inr t) (right:=right) in H3.
  + apply accessible_g_g_acc.
    exact H3.
  + exact H0.
  + exact H2.
Qed.

Theorem g_acc_correct:
forall g: cfg _ _,
g_equiv (g_acc g) g /\
has_no_inaccessible_symbols (g_acc g).
Proof.
intro g.
split.
- apply g_equiv_acc.
- apply g_acc_has_no_inaccessible_symbols.
Qed.

End Inaccessible.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** This file provides a constructive form of indefinite description that
    allows to build choice functions; this is weaker than Hilbert's
    epsilon operator (which implies weakly classical properties) but
    stronger than the axiom of choice (which cannot be used outside
    the context of a theorem proof). *)

Require Import ChoiceFacts.

Set Implicit Arguments.

Axiom constructive_indefinite_description :
  forall (A : Type) (P : A->Prop),
    (exists x, P x) -> { x : A | P x }.

Lemma constructive_definite_description :
  forall (A : Type) (P : A->Prop),
    (exists! x, P x) -> { x : A | P x }.
Proof.
  intros; apply constructive_indefinite_description; firstorder.
Qed.

Lemma functional_choice :
  forall (A B : Type) (R:A->B->Prop),
    (forall x : A, exists y : B, R x y) ->
    (exists f : A->B, forall x : A, R x (f x)).
Proof.
  apply constructive_indefinite_descr_fun_choice.
  exact constructive_indefinite_description.
Qed.


Require Export fintype.
Require Export header_extensible.
Inductive tm (n_tm : nat) : Type :=
  | var_tm : forall _ : fin n_tm, tm n_tm
  | app : forall _ : tm n_tm, forall _ : tm n_tm, tm n_tm
  | lam : forall _ : tm (S n_tm), tm n_tm
  | pair : forall _ : tm n_tm, forall _ : tm n_tm, tm n_tm
  | matchpair : forall _ : tm n_tm, forall _ : tm (S (S n_tm)), tm n_tm.
Lemma congr_app {m_tm : nat} {s0 : tm m_tm} {s1 : tm m_tm} {t0 : tm m_tm}
  {t1 : tm m_tm} (H0 : eq s0 t0) (H1 : eq s1 t1) :
  eq (app m_tm s0 s1) (app m_tm t0 t1).
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => app m_tm x s1) H0))
                (ap (fun x => app m_tm t0 x) H1)).
Qed.
Lemma congr_lam {m_tm : nat} {s0 : tm (S m_tm)} {t0 : tm (S m_tm)}
  (H0 : eq s0 t0) : eq (lam m_tm s0) (lam m_tm t0).
Proof.
exact (eq_trans eq_refl (ap (fun x => lam m_tm x) H0)).
Qed.
Lemma congr_pair {m_tm : nat} {s0 : tm m_tm} {s1 : tm m_tm} {t0 : tm m_tm}
  {t1 : tm m_tm} (H0 : eq s0 t0) (H1 : eq s1 t1) :
  eq (pair m_tm s0 s1) (pair m_tm t0 t1).
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => pair m_tm x s1) H0))
                (ap (fun x => pair m_tm t0 x) H1)).
Qed.
Lemma congr_matchpair {m_tm : nat} {s0 : tm m_tm} {s1 : tm (S (S m_tm))}
  {t0 : tm m_tm} {t1 : tm (S (S m_tm))} (H0 : eq s0 t0) (H1 : eq s1 t1) :
  eq (matchpair m_tm s0 s1) (matchpair m_tm t0 t1).
Proof.
exact (eq_trans
                (eq_trans eq_refl (ap (fun x => matchpair m_tm x s1) H0))
                (ap (fun x => matchpair m_tm t0 x) H1)).
Qed.
Definition upRen_tm_tm {m : nat} {n : nat} (xi : forall _ : fin m, fin n) :
  forall _ : fin (S m), fin (S n) := up_ren xi.
Definition upRen_list_tm_tm (p : nat) {m : nat} {n : nat}
  (xi : forall _ : fin m, fin n) :
  forall _ : fin (plus p m), fin (plus p n) := upRen_p p xi.
Fixpoint ren_tm {m_tm : nat} {n_tm : nat}
(xi_tm : forall _ : fin m_tm, fin n_tm) (s : tm m_tm) : tm n_tm :=
  match s with
  | var_tm _ s0 => var_tm n_tm (xi_tm s0)
  | app _ s0 s1 => app n_tm (ren_tm xi_tm s0) (ren_tm xi_tm s1)
  | lam _ s0 => lam n_tm (ren_tm (upRen_tm_tm xi_tm) s0)
  | pair _ s0 s1 => pair n_tm (ren_tm xi_tm s0) (ren_tm xi_tm s1)
  | matchpair _ s0 s1 =>
      matchpair n_tm (ren_tm xi_tm s0)
        (ren_tm (upRen_tm_tm (upRen_tm_tm xi_tm)) s1)
  end.
Definition up_tm_tm {m : nat} {n_tm : nat}
  (sigma : forall _ : fin m, tm n_tm) : forall _ : fin (S m), tm (S n_tm) :=
  scons (var_tm (S n_tm) var_zero) (funcomp (ren_tm shift) sigma).
Definition up_list_tm_tm (p : nat) {m : nat} {n_tm : nat}
  (sigma : forall _ : fin m, tm n_tm) :
  forall _ : fin (plus p m), tm (plus p n_tm) :=
  scons_p p (funcomp (var_tm (plus p n_tm)) (zero_p p))
    (funcomp (ren_tm (shift_p p)) sigma).
Fixpoint subst_tm {m_tm : nat} {n_tm : nat}
(sigma_tm : forall _ : fin m_tm, tm n_tm) (s : tm m_tm) : tm n_tm :=
  match s with
  | var_tm _ s0 => sigma_tm s0
  | app _ s0 s1 => app n_tm (subst_tm sigma_tm s0) (subst_tm sigma_tm s1)
  | lam _ s0 => lam n_tm (subst_tm (up_tm_tm sigma_tm) s0)
  | pair _ s0 s1 => pair n_tm (subst_tm sigma_tm s0) (subst_tm sigma_tm s1)
  | matchpair _ s0 s1 =>
      matchpair n_tm (subst_tm sigma_tm s0)
        (subst_tm (up_tm_tm (up_tm_tm sigma_tm)) s1)
  end.
Definition upId_tm_tm {m_tm : nat} (sigma : forall _ : fin m_tm, tm m_tm)
  (Eq : forall x, eq (sigma x) (var_tm m_tm x)) :
  forall x, eq (up_tm_tm sigma x) (var_tm (S m_tm) x) :=
  fun n =>
  match n with
  | Some fin_n => ap (ren_tm shift) (Eq fin_n)
  | None => eq_refl
  end.
Definition upId_list_tm_tm {p : nat} {m_tm : nat}
  (sigma : forall _ : fin m_tm, tm m_tm)
  (Eq : forall x, eq (sigma x) (var_tm m_tm x)) :
  forall x, eq (up_list_tm_tm p sigma x) (var_tm (plus p m_tm) x) :=
  fun n =>
  scons_p_eta (var_tm (plus p m_tm))
    (fun n => ap (ren_tm (shift_p p)) (Eq n)) (fun n => eq_refl).
Fixpoint idSubst_tm {m_tm : nat} (sigma_tm : forall _ : fin m_tm, tm m_tm)
(Eq_tm : forall x, eq (sigma_tm x) (var_tm m_tm x)) (s : tm m_tm) :
eq (subst_tm sigma_tm s) s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (idSubst_tm sigma_tm Eq_tm s0) (idSubst_tm sigma_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam (idSubst_tm (up_tm_tm sigma_tm) (upId_tm_tm _ Eq_tm) s0)
  | pair _ s0 s1 =>
      congr_pair (idSubst_tm sigma_tm Eq_tm s0)
        (idSubst_tm sigma_tm Eq_tm s1)
  | matchpair _ s0 s1 =>
      congr_matchpair (idSubst_tm sigma_tm Eq_tm s0)
        (idSubst_tm (up_tm_tm (up_tm_tm sigma_tm))
           (upId_tm_tm _ (upId_tm_tm _ Eq_tm)) s1)
  end.
Definition upExtRen_tm_tm {m : nat} {n : nat} (xi : forall _ : fin m, fin n)
  (zeta : forall _ : fin m, fin n) (Eq : forall x, eq (xi x) (zeta x)) :
  forall x, eq (upRen_tm_tm xi x) (upRen_tm_tm zeta x) :=
  fun n =>
  match n with
  | Some fin_n => ap shift (Eq fin_n)
  | None => eq_refl
  end.
Definition upExtRen_list_tm_tm {p : nat} {m : nat} {n : nat}
  (xi : forall _ : fin m, fin n) (zeta : forall _ : fin m, fin n)
  (Eq : forall x, eq (xi x) (zeta x)) :
  forall x, eq (upRen_list_tm_tm p xi x) (upRen_list_tm_tm p zeta x) :=
  fun n => scons_p_congr (fun n => eq_refl) (fun n => ap (shift_p p) (Eq n)).
Fixpoint extRen_tm {m_tm : nat} {n_tm : nat}
(xi_tm : forall _ : fin m_tm, fin n_tm)
(zeta_tm : forall _ : fin m_tm, fin n_tm)
(Eq_tm : forall x, eq (xi_tm x) (zeta_tm x)) (s : tm m_tm) :
eq (ren_tm xi_tm s) (ren_tm zeta_tm s) :=
  match s with
  | var_tm _ s0 => ap (var_tm n_tm) (Eq_tm s0)
  | app _ s0 s1 =>
      congr_app (extRen_tm xi_tm zeta_tm Eq_tm s0)
        (extRen_tm xi_tm zeta_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (extRen_tm (upRen_tm_tm xi_tm) (upRen_tm_tm zeta_tm)
           (upExtRen_tm_tm _ _ Eq_tm) s0)
  | pair _ s0 s1 =>
      congr_pair (extRen_tm xi_tm zeta_tm Eq_tm s0)
        (extRen_tm xi_tm zeta_tm Eq_tm s1)
  | matchpair _ s0 s1 =>
      congr_matchpair (extRen_tm xi_tm zeta_tm Eq_tm s0)
        (extRen_tm (upRen_tm_tm (upRen_tm_tm xi_tm))
           (upRen_tm_tm (upRen_tm_tm zeta_tm))
           (upExtRen_tm_tm _ _ (upExtRen_tm_tm _ _ Eq_tm)) s1)
  end.
Definition upExt_tm_tm {m : nat} {n_tm : nat}
  (sigma : forall _ : fin m, tm n_tm) (tau : forall _ : fin m, tm n_tm)
  (Eq : forall x, eq (sigma x) (tau x)) :
  forall x, eq (up_tm_tm sigma x) (up_tm_tm tau x) :=
  fun n =>
  match n with
  | Some fin_n => ap (ren_tm shift) (Eq fin_n)
  | None => eq_refl
  end.
Definition upExt_list_tm_tm {p : nat} {m : nat} {n_tm : nat}
  (sigma : forall _ : fin m, tm n_tm) (tau : forall _ : fin m, tm n_tm)
  (Eq : forall x, eq (sigma x) (tau x)) :
  forall x, eq (up_list_tm_tm p sigma x) (up_list_tm_tm p tau x) :=
  fun n =>
  scons_p_congr (fun n => eq_refl) (fun n => ap (ren_tm (shift_p p)) (Eq n)).
Fixpoint ext_tm {m_tm : nat} {n_tm : nat}
(sigma_tm : forall _ : fin m_tm, tm n_tm)
(tau_tm : forall _ : fin m_tm, tm n_tm)
(Eq_tm : forall x, eq (sigma_tm x) (tau_tm x)) (s : tm m_tm) :
eq (subst_tm sigma_tm s) (subst_tm tau_tm s) :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (ext_tm sigma_tm tau_tm Eq_tm s0)
        (ext_tm sigma_tm tau_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (ext_tm (up_tm_tm sigma_tm) (up_tm_tm tau_tm) (upExt_tm_tm _ _ Eq_tm)
           s0)
  | pair _ s0 s1 =>
      congr_pair (ext_tm sigma_tm tau_tm Eq_tm s0)
        (ext_tm sigma_tm tau_tm Eq_tm s1)
  | matchpair _ s0 s1 =>
      congr_matchpair (ext_tm sigma_tm tau_tm Eq_tm s0)
        (ext_tm (up_tm_tm (up_tm_tm sigma_tm)) (up_tm_tm (up_tm_tm tau_tm))
           (upExt_tm_tm _ _ (upExt_tm_tm _ _ Eq_tm)) s1)
  end.
Definition up_ren_ren_tm_tm {k : nat} {l : nat} {m : nat}
  (xi : forall _ : fin k, fin l) (zeta : forall _ : fin l, fin m)
  (rho : forall _ : fin k, fin m)
  (Eq : forall x, eq (funcomp zeta xi x) (rho x)) :
  forall x,
  eq (funcomp (upRen_tm_tm zeta) (upRen_tm_tm xi) x) (upRen_tm_tm rho x) :=
  up_ren_ren xi zeta rho Eq.
Definition up_ren_ren_list_tm_tm {p : nat} {k : nat} {l : nat} {m : nat}
  (xi : forall _ : fin k, fin l) (zeta : forall _ : fin l, fin m)
  (rho : forall _ : fin k, fin m)
  (Eq : forall x, eq (funcomp zeta xi x) (rho x)) :
  forall x,
  eq (funcomp (upRen_list_tm_tm p zeta) (upRen_list_tm_tm p xi) x)
    (upRen_list_tm_tm p rho x) := up_ren_ren_p Eq.
Fixpoint compRenRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(xi_tm : forall _ : fin m_tm, fin k_tm)
(zeta_tm : forall _ : fin k_tm, fin l_tm)
(rho_tm : forall _ : fin m_tm, fin l_tm)
(Eq_tm : forall x, eq (funcomp zeta_tm xi_tm x) (rho_tm x)) (s : tm m_tm) :
eq (ren_tm zeta_tm (ren_tm xi_tm s)) (ren_tm rho_tm s) :=
  match s with
  | var_tm _ s0 => ap (var_tm l_tm) (Eq_tm s0)
  | app _ s0 s1 =>
      congr_app (compRenRen_tm xi_tm zeta_tm rho_tm Eq_tm s0)
        (compRenRen_tm xi_tm zeta_tm rho_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (compRenRen_tm (upRen_tm_tm xi_tm) (upRen_tm_tm zeta_tm)
           (upRen_tm_tm rho_tm) (up_ren_ren _ _ _ Eq_tm) s0)
  | pair _ s0 s1 =>
      congr_pair (compRenRen_tm xi_tm zeta_tm rho_tm Eq_tm s0)
        (compRenRen_tm xi_tm zeta_tm rho_tm Eq_tm s1)
  | matchpair _ s0 s1 =>
      congr_matchpair (compRenRen_tm xi_tm zeta_tm rho_tm Eq_tm s0)
        (compRenRen_tm (upRen_tm_tm (upRen_tm_tm xi_tm))
           (upRen_tm_tm (upRen_tm_tm zeta_tm))
           (upRen_tm_tm (upRen_tm_tm rho_tm))
           (up_ren_ren _ _ _ (up_ren_ren _ _ _ Eq_tm)) s1)
  end.
Definition up_ren_subst_tm_tm {k : nat} {l : nat} {m_tm : nat}
  (xi : forall _ : fin k, fin l) (tau : forall _ : fin l, tm m_tm)
  (theta : forall _ : fin k, tm m_tm)
  (Eq : forall x, eq (funcomp tau xi x) (theta x)) :
  forall x, eq (funcomp (up_tm_tm tau) (upRen_tm_tm xi) x) (up_tm_tm theta x) :=
  fun n =>
  match n with
  | Some fin_n => ap (ren_tm shift) (Eq fin_n)
  | None => eq_refl
  end.
Definition up_ren_subst_list_tm_tm {p : nat} {k : nat} {l : nat} {m_tm : nat}
  (xi : forall _ : fin k, fin l) (tau : forall _ : fin l, tm m_tm)
  (theta : forall _ : fin k, tm m_tm)
  (Eq : forall x, eq (funcomp tau xi x) (theta x)) :
  forall x,
  eq (funcomp (up_list_tm_tm p tau) (upRen_list_tm_tm p xi) x)
    (up_list_tm_tm p theta x) :=
  fun n =>
  eq_trans (scons_p_comp' _ _ _ n)
    (scons_p_congr (fun z => scons_p_head' _ _ z)
       (fun z =>
        eq_trans (scons_p_tail' _ _ (xi z)) (ap (ren_tm (shift_p p)) (Eq z)))).
Fixpoint compRenSubst_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(xi_tm : forall _ : fin m_tm, fin k_tm)
(tau_tm : forall _ : fin k_tm, tm l_tm)
(theta_tm : forall _ : fin m_tm, tm l_tm)
(Eq_tm : forall x, eq (funcomp tau_tm xi_tm x) (theta_tm x)) (s : tm m_tm) :
eq (subst_tm tau_tm (ren_tm xi_tm s)) (subst_tm theta_tm s) :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (compRenSubst_tm xi_tm tau_tm theta_tm Eq_tm s0)
        (compRenSubst_tm xi_tm tau_tm theta_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (compRenSubst_tm (upRen_tm_tm xi_tm) (up_tm_tm tau_tm)
           (up_tm_tm theta_tm) (up_ren_subst_tm_tm _ _ _ Eq_tm) s0)
  | pair _ s0 s1 =>
      congr_pair (compRenSubst_tm xi_tm tau_tm theta_tm Eq_tm s0)
        (compRenSubst_tm xi_tm tau_tm theta_tm Eq_tm s1)
  | matchpair _ s0 s1 =>
      congr_matchpair (compRenSubst_tm xi_tm tau_tm theta_tm Eq_tm s0)
        (compRenSubst_tm (upRen_tm_tm (upRen_tm_tm xi_tm))
           (up_tm_tm (up_tm_tm tau_tm)) (up_tm_tm (up_tm_tm theta_tm))
           (up_ren_subst_tm_tm _ _ _ (up_ren_subst_tm_tm _ _ _ Eq_tm)) s1)
  end.
Definition up_subst_ren_tm_tm {k : nat} {l_tm : nat} {m_tm : nat}
  (sigma : forall _ : fin k, tm l_tm)
  (zeta_tm : forall _ : fin l_tm, fin m_tm)
  (theta : forall _ : fin k, tm m_tm)
  (Eq : forall x, eq (funcomp (ren_tm zeta_tm) sigma x) (theta x)) :
  forall x,
  eq (funcomp (ren_tm (upRen_tm_tm zeta_tm)) (up_tm_tm sigma) x)
    (up_tm_tm theta x) :=
  fun n =>
  match n with
  | Some fin_n =>
      eq_trans
        (compRenRen_tm shift (upRen_tm_tm zeta_tm) (funcomp shift zeta_tm)
           (fun x => eq_refl) (sigma fin_n))
        (eq_trans
           (eq_sym
              (compRenRen_tm zeta_tm shift (funcomp shift zeta_tm)
                 (fun x => eq_refl) (sigma fin_n)))
           (ap (ren_tm shift) (Eq fin_n)))
  | None => eq_refl
  end.
Definition up_subst_ren_list_tm_tm {p : nat} {k : nat} {l_tm : nat}
  {m_tm : nat} (sigma : forall _ : fin k, tm l_tm)
  (zeta_tm : forall _ : fin l_tm, fin m_tm)
  (theta : forall _ : fin k, tm m_tm)
  (Eq : forall x, eq (funcomp (ren_tm zeta_tm) sigma x) (theta x)) :
  forall x,
  eq
    (funcomp (ren_tm (upRen_list_tm_tm p zeta_tm)) (up_list_tm_tm p sigma) x)
    (up_list_tm_tm p theta x) :=
  fun n =>
  eq_trans (scons_p_comp' _ _ _ n)
    (scons_p_congr (fun x => ap (var_tm (plus p m_tm)) (scons_p_head' _ _ x))
       (fun n =>
        eq_trans
          (compRenRen_tm (shift_p p) (upRen_list_tm_tm p zeta_tm)
             (funcomp (shift_p p) zeta_tm) (fun x => scons_p_tail' _ _ x)
             (sigma n))
          (eq_trans
             (eq_sym
                (compRenRen_tm zeta_tm (shift_p p)
                   (funcomp (shift_p p) zeta_tm) (fun x => eq_refl) (sigma n)))
             (ap (ren_tm (shift_p p)) (Eq n))))).
Fixpoint compSubstRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(sigma_tm : forall _ : fin m_tm, tm k_tm)
(zeta_tm : forall _ : fin k_tm, fin l_tm)
(theta_tm : forall _ : fin m_tm, tm l_tm)
(Eq_tm : forall x, eq (funcomp (ren_tm zeta_tm) sigma_tm x) (theta_tm x))
(s : tm m_tm) :
eq (ren_tm zeta_tm (subst_tm sigma_tm s)) (subst_tm theta_tm s) :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (compSubstRen_tm sigma_tm zeta_tm theta_tm Eq_tm s0)
        (compSubstRen_tm sigma_tm zeta_tm theta_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (compSubstRen_tm (up_tm_tm sigma_tm) (upRen_tm_tm zeta_tm)
           (up_tm_tm theta_tm) (up_subst_ren_tm_tm _ _ _ Eq_tm) s0)
  | pair _ s0 s1 =>
      congr_pair (compSubstRen_tm sigma_tm zeta_tm theta_tm Eq_tm s0)
        (compSubstRen_tm sigma_tm zeta_tm theta_tm Eq_tm s1)
  | matchpair _ s0 s1 =>
      congr_matchpair (compSubstRen_tm sigma_tm zeta_tm theta_tm Eq_tm s0)
        (compSubstRen_tm (up_tm_tm (up_tm_tm sigma_tm))
           (upRen_tm_tm (upRen_tm_tm zeta_tm)) (up_tm_tm (up_tm_tm theta_tm))
           (up_subst_ren_tm_tm _ _ _ (up_subst_ren_tm_tm _ _ _ Eq_tm)) s1)
  end.
Definition up_subst_subst_tm_tm {k : nat} {l_tm : nat} {m_tm : nat}
  (sigma : forall _ : fin k, tm l_tm) (tau_tm : forall _ : fin l_tm, tm m_tm)
  (theta : forall _ : fin k, tm m_tm)
  (Eq : forall x, eq (funcomp (subst_tm tau_tm) sigma x) (theta x)) :
  forall x,
  eq (funcomp (subst_tm (up_tm_tm tau_tm)) (up_tm_tm sigma) x)
    (up_tm_tm theta x) :=
  fun n =>
  match n with
  | Some fin_n =>
      eq_trans
        (compRenSubst_tm shift (up_tm_tm tau_tm)
           (funcomp (up_tm_tm tau_tm) shift) (fun x => eq_refl) (sigma fin_n))
        (eq_trans
           (eq_sym
              (compSubstRen_tm tau_tm shift (funcomp (ren_tm shift) tau_tm)
                 (fun x => eq_refl) (sigma fin_n)))
           (ap (ren_tm shift) (Eq fin_n)))
  | None => eq_refl
  end.
Definition up_subst_subst_list_tm_tm {p : nat} {k : nat} {l_tm : nat}
  {m_tm : nat} (sigma : forall _ : fin k, tm l_tm)
  (tau_tm : forall _ : fin l_tm, tm m_tm) (theta : forall _ : fin k, tm m_tm)
  (Eq : forall x, eq (funcomp (subst_tm tau_tm) sigma x) (theta x)) :
  forall x,
  eq (funcomp (subst_tm (up_list_tm_tm p tau_tm)) (up_list_tm_tm p sigma) x)
    (up_list_tm_tm p theta x) :=
  fun n =>
  eq_trans (scons_p_comp' (funcomp (var_tm (plus p l_tm)) (zero_p p)) _ _ n)
    (scons_p_congr
       (fun x => scons_p_head' _ (fun z => ren_tm (shift_p p) _) x)
       (fun n =>
        eq_trans
          (compRenSubst_tm (shift_p p) (up_list_tm_tm p tau_tm)
             (funcomp (up_list_tm_tm p tau_tm) (shift_p p))
             (fun x => eq_refl) (sigma n))
          (eq_trans
             (eq_sym
                (compSubstRen_tm tau_tm (shift_p p) _
                   (fun x => eq_sym (scons_p_tail' _ _ x)) (sigma n)))
             (ap (ren_tm (shift_p p)) (Eq n))))).
Fixpoint compSubstSubst_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(sigma_tm : forall _ : fin m_tm, tm k_tm)
(tau_tm : forall _ : fin k_tm, tm l_tm)
(theta_tm : forall _ : fin m_tm, tm l_tm)
(Eq_tm : forall x, eq (funcomp (subst_tm tau_tm) sigma_tm x) (theta_tm x))
(s : tm m_tm) :
eq (subst_tm tau_tm (subst_tm sigma_tm s)) (subst_tm theta_tm s) :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (compSubstSubst_tm sigma_tm tau_tm theta_tm Eq_tm s0)
        (compSubstSubst_tm sigma_tm tau_tm theta_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (compSubstSubst_tm (up_tm_tm sigma_tm) (up_tm_tm tau_tm)
           (up_tm_tm theta_tm) (up_subst_subst_tm_tm _ _ _ Eq_tm) s0)
  | pair _ s0 s1 =>
      congr_pair (compSubstSubst_tm sigma_tm tau_tm theta_tm Eq_tm s0)
        (compSubstSubst_tm sigma_tm tau_tm theta_tm Eq_tm s1)
  | matchpair _ s0 s1 =>
      congr_matchpair (compSubstSubst_tm sigma_tm tau_tm theta_tm Eq_tm s0)
        (compSubstSubst_tm (up_tm_tm (up_tm_tm sigma_tm))
           (up_tm_tm (up_tm_tm tau_tm)) (up_tm_tm (up_tm_tm theta_tm))
           (up_subst_subst_tm_tm _ _ _ (up_subst_subst_tm_tm _ _ _ Eq_tm)) s1)
  end.
Definition rinstInst_up_tm_tm {m : nat} {n_tm : nat}
  (xi : forall _ : fin m, fin n_tm) (sigma : forall _ : fin m, tm n_tm)
  (Eq : forall x, eq (funcomp (var_tm n_tm) xi x) (sigma x)) :
  forall x,
  eq (funcomp (var_tm (S n_tm)) (upRen_tm_tm xi) x) (up_tm_tm sigma x) :=
  fun n =>
  match n with
  | Some fin_n => ap (ren_tm shift) (Eq fin_n)
  | None => eq_refl
  end.
Definition rinstInst_up_list_tm_tm {p : nat} {m : nat} {n_tm : nat}
  (xi : forall _ : fin m, fin n_tm) (sigma : forall _ : fin m, tm n_tm)
  (Eq : forall x, eq (funcomp (var_tm n_tm) xi x) (sigma x)) :
  forall x,
  eq (funcomp (var_tm (plus p n_tm)) (upRen_list_tm_tm p xi) x)
    (up_list_tm_tm p sigma x) :=
  fun n =>
  eq_trans (scons_p_comp' _ _ (var_tm (plus p n_tm)) n)
    (scons_p_congr (fun z => eq_refl)
       (fun n => ap (ren_tm (shift_p p)) (Eq n))).
Fixpoint rinst_inst_tm {m_tm : nat} {n_tm : nat}
(xi_tm : forall _ : fin m_tm, fin n_tm)
(sigma_tm : forall _ : fin m_tm, tm n_tm)
(Eq_tm : forall x, eq (funcomp (var_tm n_tm) xi_tm x) (sigma_tm x))
(s : tm m_tm) : eq (ren_tm xi_tm s) (subst_tm sigma_tm s) :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (rinst_inst_tm xi_tm sigma_tm Eq_tm s0)
        (rinst_inst_tm xi_tm sigma_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (rinst_inst_tm (upRen_tm_tm xi_tm) (up_tm_tm sigma_tm)
           (rinstInst_up_tm_tm _ _ Eq_tm) s0)
  | pair _ s0 s1 =>
      congr_pair (rinst_inst_tm xi_tm sigma_tm Eq_tm s0)
        (rinst_inst_tm xi_tm sigma_tm Eq_tm s1)
  | matchpair _ s0 s1 =>
      congr_matchpair (rinst_inst_tm xi_tm sigma_tm Eq_tm s0)
        (rinst_inst_tm (upRen_tm_tm (upRen_tm_tm xi_tm))
           (up_tm_tm (up_tm_tm sigma_tm))
           (rinstInst_up_tm_tm _ _ (rinstInst_up_tm_tm _ _ Eq_tm)) s1)
  end.
Lemma rinstInst_tm {m_tm : nat} {n_tm : nat}
  (xi_tm : forall _ : fin m_tm, fin n_tm) :
  eq (ren_tm xi_tm) (subst_tm (funcomp (var_tm n_tm) xi_tm)).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun x => rinst_inst_tm xi_tm _ (fun n => eq_refl) x)).
Qed.
Lemma instId_tm {m_tm : nat} : eq (subst_tm (var_tm m_tm)) id.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun x => idSubst_tm (var_tm m_tm) (fun n => eq_refl) (id x))).
Qed.
Lemma rinstId_tm {m_tm : nat} : eq (@ren_tm m_tm m_tm id) id.
Proof.
exact (eq_trans (rinstInst_tm (id _)) instId_tm).
Qed.
Lemma varL_tm {m_tm : nat} {n_tm : nat}
  (sigma_tm : forall _ : fin m_tm, tm n_tm) :
  eq (funcomp (subst_tm sigma_tm) (var_tm m_tm)) sigma_tm.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun x => eq_refl)).
Qed.
Lemma varLRen_tm {m_tm : nat} {n_tm : nat}
  (xi_tm : forall _ : fin m_tm, fin n_tm) :
  eq (funcomp (ren_tm xi_tm) (var_tm m_tm)) (funcomp (var_tm n_tm) xi_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun x => eq_refl)).
Qed.
Lemma renRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : forall _ : fin m_tm, fin k_tm)
  (zeta_tm : forall _ : fin k_tm, fin l_tm) (s : tm m_tm) :
  eq (ren_tm zeta_tm (ren_tm xi_tm s)) (ren_tm (funcomp zeta_tm xi_tm) s).
Proof.
exact (compRenRen_tm xi_tm zeta_tm _ (fun n => eq_refl) s).
Qed.
Lemma renRen'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : forall _ : fin m_tm, fin k_tm)
  (zeta_tm : forall _ : fin k_tm, fin l_tm) :
  eq (funcomp (ren_tm zeta_tm) (ren_tm xi_tm))
    (ren_tm (funcomp zeta_tm xi_tm)).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun n => renRen_tm xi_tm zeta_tm n)).
Qed.
Lemma compRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : forall _ : fin m_tm, tm k_tm)
  (zeta_tm : forall _ : fin k_tm, fin l_tm) (s : tm m_tm) :
  eq (ren_tm zeta_tm (subst_tm sigma_tm s))
    (subst_tm (funcomp (ren_tm zeta_tm) sigma_tm) s).
Proof.
exact (compSubstRen_tm sigma_tm zeta_tm _ (fun n => eq_refl) s).
Qed.
Lemma compRen'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : forall _ : fin m_tm, tm k_tm)
  (zeta_tm : forall _ : fin k_tm, fin l_tm) :
  eq (funcomp (ren_tm zeta_tm) (subst_tm sigma_tm))
    (subst_tm (funcomp (ren_tm zeta_tm) sigma_tm)).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun n => compRen_tm sigma_tm zeta_tm n)).
Qed.
Lemma renComp_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : forall _ : fin m_tm, fin k_tm)
  (tau_tm : forall _ : fin k_tm, tm l_tm) (s : tm m_tm) :
  eq (subst_tm tau_tm (ren_tm xi_tm s)) (subst_tm (funcomp tau_tm xi_tm) s).
Proof.
exact (compRenSubst_tm xi_tm tau_tm _ (fun n => eq_refl) s).
Qed.
Lemma renComp'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : forall _ : fin m_tm, fin k_tm)
  (tau_tm : forall _ : fin k_tm, tm l_tm) :
  eq (funcomp (subst_tm tau_tm) (ren_tm xi_tm))
    (subst_tm (funcomp tau_tm xi_tm)).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun n => renComp_tm xi_tm tau_tm n)).
Qed.
Lemma compComp_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : forall _ : fin m_tm, tm k_tm)
  (tau_tm : forall _ : fin k_tm, tm l_tm) (s : tm m_tm) :
  eq (subst_tm tau_tm (subst_tm sigma_tm s))
    (subst_tm (funcomp (subst_tm tau_tm) sigma_tm) s).
Proof.
exact (compSubstSubst_tm sigma_tm tau_tm _ (fun n => eq_refl) s).
Qed.
Lemma compComp'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : forall _ : fin m_tm, tm k_tm)
  (tau_tm : forall _ : fin k_tm, tm l_tm) :
  eq (funcomp (subst_tm tau_tm) (subst_tm sigma_tm))
    (subst_tm (funcomp (subst_tm tau_tm) sigma_tm)).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun n => compComp_tm sigma_tm tau_tm n)).
Qed.

Arguments var_tm {n_tm}.

Arguments app {n_tm}.

Arguments lam {n_tm}.

Arguments pair {n_tm}.

Arguments matchpair {n_tm}.

Global Instance Subst_tm { m_tm : nat } { n_tm : nat } : Subst1 ((fin) (m_tm) -> tm (n_tm)) (tm (m_tm)) (tm (n_tm)) := @subst_tm (m_tm) (n_tm) .

Global Instance Ren_tm { m_tm : nat } { n_tm : nat } : Ren1 ((fin) (m_tm) -> (fin) (n_tm)) (tm (m_tm)) (tm (n_tm)) := @ren_tm (m_tm) (n_tm) .

Global Instance VarInstance_tm { m_tm : nat } : Var ((fin) (m_tm)) (tm (m_tm)) := @var_tm (m_tm) .

Notation "x '__tm'" := (var_tm x) (at level 5, format "x __tm") : subst_scope.

Notation "x '__tm'" := (@ids (_) (_) VarInstance_tm x) (at level 5, only printing, format "x __tm") : subst_scope.

Notation "'var'" := (var_tm) (only printing, at level 1) : subst_scope.

Class Up_tm X Y := up_tm : X -> Y.

Notation "↑__tm" := (up_tm) (only printing) : subst_scope.

Notation "↑__tm" := (up_tm_tm) (only printing) : subst_scope.

Global Instance Up_tm_tm { m : nat } { n_tm : nat } : Up_tm (_) (_) := @up_tm_tm (m) (n_tm) .

Notation "s [ sigmatm ]" := (subst_tm sigmatm s) (at level 7, left associativity, only printing) : subst_scope.

Notation "[ sigmatm ]" := (subst_tm sigmatm) (at level 1, left associativity, only printing) : fscope.

Notation "s ⟨ xitm ⟩" := (ren_tm xitm s) (at level 7, left associativity, only printing) : subst_scope.

Notation "⟨ xitm ⟩" := (ren_tm xitm) (at level 1, left associativity, only printing) : fscope.

Ltac auto_unfold := repeat unfold subst1,  subst2,  Subst1,  Subst2,  ids,  ren1,  ren2,  Ren1,  Ren2,  Subst_tm,  Ren_tm,  VarInstance_tm.

Tactic Notation "auto_unfold" "in" "*" := repeat unfold subst1,  subst2,  Subst1,  Subst2,  ids,  ren1,  ren2,  Ren1,  Ren2,  Subst_tm,  Ren_tm,  VarInstance_tm in *.

Ltac asimpl' := repeat first [progress rewrite ?instId_tm| progress rewrite ?compComp_tm| progress rewrite ?compComp'_tm| progress rewrite ?rinstId_tm| progress rewrite ?compRen_tm| progress rewrite ?compRen'_tm| progress rewrite ?renComp_tm| progress rewrite ?renComp'_tm| progress rewrite ?renRen_tm| progress rewrite ?renRen'_tm| progress rewrite ?varL_tm| progress rewrite ?varLRen_tm| progress (unfold up_ren, upRen_tm_tm, upRen_list_tm_tm, up_tm_tm, up_list_tm_tm)| progress (cbn [subst_tm ren_tm])| fsimpl].

Ltac asimpl := repeat try unfold_funcomp; auto_unfold in *; asimpl'; repeat try unfold_funcomp.

Tactic Notation "asimpl" "in" hyp(J) := revert J; asimpl; intros J.

Tactic Notation "auto_case" := auto_case (asimpl; cbn; eauto).

Tactic Notation "asimpl" "in" "*" := auto_unfold in *; repeat first [progress rewrite ?instId_tm in *| progress rewrite ?compComp_tm in *| progress rewrite ?compComp'_tm in *| progress rewrite ?rinstId_tm in *| progress rewrite ?compRen_tm in *| progress rewrite ?compRen'_tm in *| progress rewrite ?renComp_tm in *| progress rewrite ?renComp'_tm in *| progress rewrite ?renRen_tm in *| progress rewrite ?renRen'_tm in *| progress rewrite ?varL_tm in *| progress rewrite ?varLRen_tm in *| progress (unfold up_ren, upRen_tm_tm, upRen_list_tm_tm, up_tm_tm, up_list_tm_tm in *)| progress (cbn [subst_tm ren_tm] in *)| fsimpl in *].

Ltac substify := auto_unfold; try repeat (erewrite rinstInst_tm).

Ltac renamify := auto_unfold; try repeat (erewrite <- rinstInst_tm).


Require Import
  Coq.Program.Program
  Coq.Program.Tactics
  Coq.omega.Omega
  Coq.Lists.List.

Require Export
  Eff
  Comp
  Choice.

Import ListNotations.

Generalizable All Variables.

Fixpoint InT `(a : A) (l : list A) : Type :=
  match l with
  | [] => False
  | b :: m => (b = a) + InT a m
  end.

Program Instance Union_Computes {s} :
  (forall eff, InT eff effs -> Computes s eff) -> Computes s (Union effs) := {
  computes := fun _ u v => _
}.
Next Obligation.
  induction effs; intros.
    now inversion v.
  inversion v; subst; clear v.
    refine (computes u X1 X X0).
    apply H.
    now left.
  apply IHeffs; auto.
  intros.
  apply H.
  now right.
Defined.

Section Relate.

Variable s : Type.
Variable effs : list (Type -> Type).
Variable a : Type.

Hypothesis Hcomputes : forall eff, InT eff effs -> Computes s eff.

Inductive relate : s -> Eff effs a -> s -> a -> Prop :=
  | RelatePure :
      forall st v, relate st (Pure v) st v

  | RelateImpure :
      forall st st' st'' v x u (k : x -> Eff effs a),
        forall i, computes st u st' i ->
        relate st' (k i) st'' v ->
        relate st (Impure u k) st'' v.

Definition refine (st : s) (old new : Eff effs a) : Prop :=
  forall (st' : s) v, relate st new st' v -> relate st old st' v.

Require Import
  Hask.Control.Monad
  RWS.

End Relate.

Program Instance Choice_Computes {s} : Computes s Choice := {
  computes := fun _ st '(Pick P) st' v => P v /\ st = st'
}.

Program Instance State_Computes {s} : Computes s (State s) := {
  computes := fun _ st a st' v => State_func a st = (st', v)
}.

Lemma choice_and_state_computes :
  forall eff : Type -> Type,
    InT eff [Choice; State (nat : Type)] -> Computes nat eff.
Proof.
  intros.
  destruct X; subst.
    apply Choice_Computes.
  destruct i; subst.
    apply State_Computes.
  inversion i.
Defined.

Example relate_ex :
  relate _ _ _ choice_and_state_computes
    0
    (send (Put 10) ;;
     x <- send Get ;
     y <- send (Pick (fun x => x <= 10));
     pure (x + y))
    10
    15.
Proof.
  simpl.
  repeat (eapply RelateImpure; eauto; try reflexivity).
    instantiate (1 := 5).       (* here the Pick is resolved *)
    simpl.
    unfold eq_rect_r, eq_rect, eq_sym; simpl.
    split.
      omega.
    reflexivity.
  constructor.
Qed.

Example refine_works :
  refine _ _ _ choice_and_state_computes
    10
    (send (Put 10) ;;
     x <- send Get ;
     y <- send (Pick (fun x => 0 <= x <= 10));
     pure (x + y))
    (y <- send (Pick (fun x => 10 <= x <= 20));
     pure y).
Proof.
  simpl.
  repeat intro.
  inversion H; subst; clear H.
  apply inj_pair2 in H4; subst.
  apply inj_pair2 in H1; subst.
  inversion H6; subst; clear H6.
  inversion H7; subst; clear H7.
  econstructor.
    simpl.
    unfold eq_rect_r, eq_rect, eq_sym; simpl.
    reflexivity.
  econstructor.
    simpl.
    unfold eq_rect_r, eq_rect, eq_sym; simpl.
    reflexivity.
  econstructor.
    simpl.
    unfold eq_rect_r, eq_rect, eq_sym; simpl.
    split.
      instantiate (1 := v - 10).
      omega.
    reflexivity.
  replace (10 + (v - 10)) with v by omega.
  constructor.
Qed.


Require Import Coq.Reals.Reals.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Reals.ROrderedType.
Open Scope R_scope.

Lemma Rge_3_0: 3 >= 0.
Proof.
  unfold IZR. unfold IPR. unfold IPR_2.
  assert (R0 = R0 + R0). { ring. } rewrite H.
  apply Rplus_ge_compat.
  - apply Rle_ge. apply Rle_0_1.
  - rewrite H.
    apply Rplus_ge_compat.
    apply Rle_ge. apply Rle_0_1.
    apply Rle_ge. apply Rle_0_1. Qed.

Lemma Rle_0_2: 0 <= 2.
  unfold IZR. unfold IPR. unfold IPR_2.
  assert (R0 = R0 + R0). { ring. } rewrite H.
  apply Rplus_le_compat.
  - apply Rle_0_1.
  - apply Rle_0_1. Qed.

Lemma Rle_0_4: 0 <= 4.
Proof.
  unfold IZR. unfold IPR. unfold IPR_2.
  assert (R0 = R0 * R0). { ring. } rewrite H.
  apply Rmult_le_compat.
  - right. ring.
  - right. ring.
  - apply Rle_0_2.
  - apply Rle_0_2. Qed.

Lemma lt_n_SSn: forall n : nat, (n < S (S n))%nat.
Proof.
  intros.
  induction n.
  - auto.
  - apply le_n_S.
    trivial. Qed.

Lemma eq01_False: 0 = 1 -> False.
Proof.
  unfold IZR. unfold IPR.
  intros.
  symmetry in H.
  apply Req_le in H.
  apply Rle_lt_trans with (r3:=R1) in H.
  - apply Rlt_irrefl in H.
    destruct H.
  - apply Rlt_0_1. Qed.

Tactic Notation "toR01" :=
  unfold IZR;
  unfold IPR;
  unfold IPR_2.

Lemma le21_False: 2 <= 1 -> False.
Proof.
  intros.
  apply Rle_lt_trans with (r3:=2) in H.
  + apply Rlt_irrefl in H.
    destruct H.
  + apply Rplus_lt_reg_l with (r:=-1).
    assert (-1 + 1 = 0). { apply Rplus_opp_l. } rewrite H0.
    assert (-1 + 2 = 1). { ring. } rewrite H1.
    apply Rlt_0_1.
    Qed.

Lemma le10_False: 1 <= 0 -> False.
Proof.
  intros.
  apply Rle_lt_trans with (r3:=1) in H.
  - apply Rlt_irrefl in H.
    destruct H.
  - apply Rlt_0_1. Qed.

Lemma eq0m1_False: 0 = -1 -> False.
Proof.
  intros.
  apply Req_le in H.
  apply Rle_lt_trans with (r3:=0) in H.
  - apply Rlt_irrefl in H.
    destruct H.
  - apply Rplus_lt_reg_r with (r:=1).
    assert (-1 + 1 = 0). { apply Rplus_opp_l. } rewrite H0.
    assert (0 + 1 = 1). { ring. } rewrite H1.
    apply Rlt_0_1. Qed.

Lemma forall_iff_expand: forall (X : Type) (P Q : X -> Prop),
  (forall x : X, P x <-> Q x) -> ((forall x : X, P x) <-> (forall x : X, Q x)).
Proof.
  intros.
  split.
  - intros.
    apply H.
    apply H0.
  - intros.
    apply H.
    apply H0. Qed.
Lemma imp_expand: forall (P Q R : Prop), (P -> (Q -> R)) -> ((P -> Q) -> (P -> R)).
Proof.
  intros.
  apply H.
  - trivial.
  - apply H0.
    apply H1. Qed.
Lemma forall_and_expand: forall (X : Type) (P Q : X -> Prop),
  (forall x : X, P x /\ Q x) <-> ((forall x : X, P x) /\ (forall x : X, Q x)).
Proof.
  split.
  - split.
    + apply H.
    + apply H.
  - split.
    + apply H.
    + apply H. Qed.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli & Mark Bickford

*)

Require Export approx_props2.
Require Export sequents_tacs.
Require Export sequents_tacs2.
Require Export per_props_equality.
Require Export sequents_equality.
Require Export per_props_nat.
Require Export per_can.
Require Export per_props_top.
Require Export computation_arith.

Lemma computes_to_integer_member_int {o} :
   forall lib (z : Z) (t : CTerm),
   computes_to_valc lib t (mkc_integer z) -> member lib t (@mkc_int o).
Proof.
      unfold member, equality; sp.
      exists (@equality_of_int o lib);sp; [apply equality_of_int_xxx| exists z; sp; spcast; auto].
Qed.

Lemma member_int_iff {o} :
   forall lib  (t : CTerm),
   member lib t (@mkc_int o) <-> Cast {z : Z $  computes_to_valc lib t (mkc_integer z)}.
Proof. intros; split; intro.
      - unfold member in H. apply equality_in_int in H. unfold equality_of_int in H.
        exrepnd. unfold ccomputes_to_valc in H0. destruct H0; exrepnd.
        constructor. exists k; auto.
      - destruct H. exrepnd. apply computes_to_integer_member_int in X0. auto.
Qed.

Lemma  cequiv_member_int {o} :
  forall lib (z :Z) (a b : CTerm),
   cequivc lib a b ->
   computes_to_valc lib a (mkc_integer z) ->
   tequality lib (mkc_member a (@mkc_int o)) (mkc_member b (@mkc_int o)).
Proof. introv ceq compa.

  pose proof (cequivc_integer lib a b z).
  assert (computes_to_valc lib b (mkc_integer z)) as compb by auto.
  clear X.
  rw (@tequality_mkc_member o); sp.
  apply tequality_int.
  apply computes_to_integer_member_int in compa.
  apply computes_to_integer_member_int in compb.
  split; auto.
  unfold ccequivc; right; auto.
Qed.

Lemma tequality_member_int {o} :
  forall lib (t1 t2: CTerm),
  tequality lib (mkc_member t1 mkc_int)
                (mkc_member t2 (@mkc_int o)) ->
    member lib t1 mkc_int ->
   equality_of_int lib t1 t2.
Proof. introv teq mem. apply equality_in_int. apply tequality_mkc_member in teq.
       exrepnd. repndors; auto.
       apply cequiv_stable in teq.
      apply equality_respects_cequivc; auto.
Qed.

Lemma  computes_to_value_arithop {o} :
  forall lib op (a b : (@NTerm o)) i j,
   (a =v>(lib) (mk_integer i))->
   (b =v>(lib)  (mk_integer j))->
   ((mk_arithop op a b) =v>(lib) (mk_integer (get_arith_op op i j))).
Proof. introv ai bj. allunfold @computes_to_value; exrepnd; split; eauto 3 with slow.
    apply reduces_to_arithop; auto.
Qed.

Lemma  computes_to_valc_arithop {o} :
  forall lib op (a b : (@CTerm o)) i j,
   computes_to_valc lib a (mkc_integer i)->
   computes_to_valc lib b (mkc_integer j)->
  computes_to_valc lib (mkc_arithop op a b) (mkc_integer (get_arith_op op i j)).
Proof. introv ai bj. allunfold @computes_to_valc.
       destruct a. destruct b. allsimpl.
       apply computes_to_value_arithop; auto.
Qed.

Lemma  ccomputes_to_valc_arithop {o} :
  forall lib op (a b : (@CTerm o)) i j,
   a ===>( lib)(mkc_integer i)->
   b ===>( lib)(mkc_integer j)->
  (mkc_arithop op a b) ===>( lib)(mkc_integer (get_arith_op op i j)).
Proof.
  unfold ccomputes_to_valc; introv ai bj.
  destruct ai. destruct bj. constructor.
  apply computes_to_valc_arithop; auto.
Qed.

Lemma equality_of_int_arithop {o} :
  forall lib op (a b c d: (@CTerm o)),
   equality_of_int lib a b ->
   equality_of_int lib c d ->
   equality_of_int lib (mkc_arithop op a c) (mkc_arithop op b d).
Proof.
    introv ab cd. allunfold @equality_of_int. exrepnd.
    exists (get_arith_op op k0 k); split; apply ccomputes_to_valc_arithop; auto.
Qed.

Lemma equality_of_int_mkc_integer {o} :
  forall lib  i j,
  equality_of_int lib (mkc_integer i) (@mkc_integer o j) <-> i = j.
Proof.  intros; split; introv H.
  - unfold equality_of_int in H; exrepnd; spcast.
    allunfold @computes_to_valc. allunfold @get_cterm. allunfold @mkc_integer.
    allunfold @computes_to_value. sp. allapply @integer_reduces_to; subst; auto.
  - subst. unfold equality_of_int. exists j; split; spcast; apply computes_to_valc_refl;
    apply iscvalue_mkc_integer.
Qed.
(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)