(*---------------------------------- Descriptions ---------------------------------------

In this file we define the idea of graph isomorphism. This is done by defining following
predicates:

Definition iso (G G': @UG A) :=
     exists (f: A->A), (forall x, f (f x) = x) /\ (nodes G') = (img f G) /\
                 (forall x y, edg G x y = edg G' (f x) (f y)).

Definition iso_using (f: A->A)(G G': @UG A) :=
     (forall x, f (f x) = x) /\
     (nodes G') = (img f G) /\
     (forall x y, edg G x y = edg G' (f x) (f y)).

When we say (iso_using f G1 G2), we mean f is the function establishing the isomorphism
between G1 and G2. We also prove that this relation is symmetric.
Note that the self invertible nature of f makes it one_one on both G1 and G2.
Following are some useful property of f:

 Lemma fx_is_one_one (l: list A)(f: A->A): (forall x, f (f x) = x) -> one_one_on l f.
 Lemma img_of_img (l: list A)(f: A->A)(Hl: IsOrd l):
    (forall x, f (f x) = x)-> img f (img f l) = l.

 Lemma iso_sym1 (G G': @UG A)(f: A-> A): iso_using f G G' -> iso_using f G' G.
 Lemma iso_sym (G G': @UG A): iso G G' -> iso G' G.

 Lemma iso_one_one1 (G G': @UG A)(f: A-> A): iso_using f G G' -> one_one_on G f.
 Lemma iso_using_G' (G G': @UG A)(f: A-> A): iso_using f G G' -> nodes G' = (img f G).
 Lemma iso_one_one (G G': @UG A)(f: A-> A)(l: list A): iso_using f G G'-> one_one_on l f.
 Lemma iso_cardinal (G G': @UG A)(f: A-> A): iso_using f G G' -> |G|=|G'|.
 Lemma iso_sub_cardinal (G G': @UG A)(X: list A)(f: A->A): iso_using f G G' ->
                                                           NoDup X -> |X|= | img f X |.
 Lemma iso_edg1  (G G': @UG A)(f: A-> A)(x y:A): iso_using f G G' ->
                                                (edg G x y = edg G' (f x) (f y)).
 Lemma iso_edg2  (G G': @UG A)(f: A-> A)(x y: A): iso_using f G G' ->
                                                (edg G' x y = edg G (f x) (f y)).
-------------------------------------------------------------------------------------

 Stable Set, Cliq and Coloring of graphs has exact counterpart in the isomorphic Graphs.
 These results of existence of counterparts are summarized below:

 Lemma iso_cliq_in (G G': @UG A)(f: A-> A)(K: list A): iso_using f G G' ->
                                                      Cliq_in G K -> Cliq_in G' (img f K).
 Lemma iso_cliq_in1 (G G': @UG A)(K: list A): iso G G' -> Cliq_in G K ->
                                              (exists K', Cliq_in G' K' /\ |K|=|K'|).
 Lemma max_K_in_G' (G G': @UG A)(f: A-> A)(K: list A): iso_using f G G' ->
                                                    Max_K_in G K -> Max_K_in G' (img f K).

Lemma iso_stable (G G': @UG A)(f: A-> A)(I: list A): iso_using f G G' ->
                                                     Stable G I -> Stable G' (img f I).
Lemma iso_stable_in (G G': @UG A)(f: A-> A)(I: list A): iso_using f G G'->
                                                Stable_in G I -> Stable_in G' (img f I).
Lemma max_I_in_G' (G G': @UG A)(f: A-> A)(I: list A): iso_using f G G' ->
                                                  Max_I_in G I -> Max_I_in G' (img f I).

Lemma cliq_num_G' (G G': @UG A)(n: nat): iso G G' -> cliq_num G n -> cliq_num G' n.
Lemma i_num_G' (G G': @UG A)(n: nat):  iso G G' -> i_num G n -> i_num G' n.
Lemma chrom_num_G' (G G': @UG A)(n:nat): iso G G' -> chrom_num G n -> chrom_num G' n.

Lemma nice_G' (G G': @UG A): iso G G' -> Nice G -> Nice G'.
Lemma iso_subgraphs (G G' H: @UG A)(f: A->A):  iso_using f G G' -> Ind_subgraph H G ->
                                      (exists H', Ind_subgraph H' G' /\ iso_using f H H').
Lemma perfect_G' (G G': @UG A): iso G G' -> Perfect G -> Perfect G'.

------------------------------------------------------------------------------------------*)

Require Export MoreDecUG.

Set Implicit Arguments.

Section GraphIsomorphism.

  Context { A: ordType }.

   Definition iso (G G': @dG A) :=
     exists (f: A->A), (forall x, f (f x) = x) /\ (nodes G') = (img f G) /\
                 (forall x y, In x G-> In y G-> edg G x y = edg G' (f x) (f y)).

   Definition iso_using (f: A->A)(G G': @dG A) :=
     (forall x, f (f x) = x) /\ (nodes G') = (img f G) /\
     (forall x y, In x G-> In y G-> edg G x y = edg G' (f x) (f y)).

   (*--------------------- properties of bijective function for isomorphism----------------*)

   Lemma f_is_one_one (f: A->A): (forall x, f (f x) = x) -> one_one f.
   Proof.  { intros H. unfold one_one. intros x y  Hxy HC. absurd (x=y).
               auto. replace y with (f (f y)). rewrite <- HC. symmetry;auto. auto. } Qed.

  Lemma fx_is_one_one (l: list A)(f: A->A): (forall x, f (f x) = x) -> one_one_on l f.
  Proof. { intros H. unfold one_one_on. intros x y Hx Hy Hxy HC. absurd (x=y).
           auto. replace y with (f (f y)). rewrite <- HC. symmetry;auto. auto. } Qed.

  Lemma img_of_img (l: list A)(f: A->A)(Hl: IsOrd l):
    (forall x, f (f x) = x)-> img f (img f l) = l.
  Proof. { intro H.
         assert (H1: Equal (img f (img f l)) l).
         { unfold Equal. split.
           { unfold Subset. intros a H1.
             assert (H2: exists b, In b (img f l) /\ a = f b); auto.
             destruct H2 as [b H2]. destruct H2 as [H2a H2b].
             assert (H3: exists x, In x l /\ b = f x ); auto.
             destruct H3 as [x H3]. destruct H3 as [H3a H3b].
             subst a. subst b. replace (f (f x)) with x. auto. symmetry;auto. }
           { unfold Subset. intros a H1.
             assert (H2: In (f a) (img f l)). auto.
             assert (H2a: In (f (f a)) (img f (img f l))). auto.
             replace (f (f a)) with a in H2a. auto. symmetry;auto. } }
         auto. } Qed.

   Lemma img_of_img1 (l: list A)(f: A->A)(Hl: IsOrd l):
     (forall x, f (f x) = x)-> l= img f (img f l).
   Proof. intros. symmetry. auto using img_of_img. Qed.

   Hint Resolve f_is_one_one fx_is_one_one img_of_img img_of_img1: core.

   (* ---------------------- Isomorphism is commutative ------------------*)
  Lemma iso_sym1 (G G': @dG A)(f: A-> A): iso_using f G G' -> iso_using f G' G.
    Proof. { intro H. destruct H as [Ha H]; destruct H as [Hb H].
           split.
           { auto. }
           split.
           { rewrite Hb;  auto. }
           { intros; symmetry.
             replace (edg G' x y) with ( edg G' (f (f x)) (f (f y))).
             assert (H2: In (f x) G).
             { rewrite Hb in H0.
               assert (h1: exists x0, In x0 G /\ x = f x0). auto.
               destruct h1 as [x0 h1]. destruct h1 as [h1 h2].
               subst x. specialize (Ha x0) as Hx0. rewrite Hx0. auto. }
             assert (H3: In (f y) G).
              { rewrite Hb in H1.
               assert (h1: exists y0, In y0 G /\ y = f y0). auto.
               destruct h1 as [y0 h1]. destruct h1 as [h1 h2].
               subst y. specialize (Ha y0) as Hy0. rewrite Hy0. auto. }
             auto. replace (f (f x)) with x. replace (f (f y)) with y.
             auto. all: symmetry;auto. } } Qed.

  Lemma iso_elim1 (G G': @dG A)(f: A->A)(x:A): iso_using f G G'-> In x G-> In (f x) G'.
   Proof. intros H Hx. replace (nodes G') with (img f G). auto. symmetry; apply H. Qed.

  Lemma iso_elim2 (G G': @dG A)(f: A->A)(x:A): iso_using f G G'-> In x G'-> In (f x) G.
  Proof. intros H Hx. replace (nodes G) with (img f G'). auto. symmetry.
         apply iso_sym1 in H as Ha. apply Ha. Qed.

  Lemma iso_sym (G G': @dG A): iso G G' -> iso G' G.
  Proof. { intro H. destruct H as [f H].  exists f. apply iso_sym1. auto. } Qed.

  Lemma iso_using_iso (G G':@dG A)(f: A->A): iso_using f G G' -> iso G G'.
  Proof. intros h. exists f. auto. Qed.

  Lemma iso_using_iso1 (G G':@dG A)(f: A->A): iso_using f G G' -> iso G' G.
  Proof. intro h. apply iso_sym. eapply iso_using_iso. eauto. Qed.

  Hint Immediate iso_sym1 iso_sym iso_elim1 iso_elim2: core.

  Hint Resolve iso_using_iso iso_using_iso1: core.

  Lemma iso_one_one1 (G G': @dG A)(f: A-> A): iso_using f G G' -> one_one_on G f.
  Proof.  intro H; apply fx_is_one_one; apply H. Qed.

  Lemma iso_one_one2 (G G': @dG A)(f: A-> A): iso_using f G G' -> one_one_on G' f.
  Proof. intro H; apply fx_is_one_one; apply H. Qed.

  Lemma iso_using_G' (G G': @dG A)(f: A-> A): iso_using f G G' -> nodes G' = (img f G).
  Proof.  intro H;apply H. Qed.

  Lemma iso_using_G (G G': @dG A)(f: A-> A): iso_using f G G' -> nodes G = (img f G').
  Proof. intro H0. cut (iso_using f G' G). intro H;apply H. auto. Qed.

  Lemma iso_one_one (G G': @dG A)(f: A-> A)(l: list A):
    iso_using f G G'-> one_one_on l f.
  Proof. intro H; apply fx_is_one_one; apply H. Qed.

  Lemma iso_f_one_one (G G': @dG A)(f: A-> A): iso_using f G G'-> one_one f.
    Proof. intro H; apply f_is_one_one; apply H. Qed.

    Hint Immediate iso_one_one1 iso_one_one2 iso_one_one iso_f_one_one
         iso_using_G iso_using_G': core.

  Lemma iso_cardinal (G G': @dG A)(f: A-> A): iso_using f G G' -> |G|=|G'|.
  Proof. { intro H.  apply iso_one_one1 in H as H1.
           replace (nodes G') with (img f G). auto.
           symmetry; auto using iso_using_G'. } Qed.
  Lemma iso_sub_cardinal (G G': @dG A)(X: list A)(f: A->A):
    iso_using f G G' -> NoDup X -> |X|= | img f X |.
  Proof. { intros H H0.
         assert (H2: one_one_on G f). eauto.
         assert (H2a: one_one_on X f). eauto. auto. } Qed.

  Lemma iso_edg1  (G G': @dG A)(f: A-> A)(x y:A): iso_using f G G' -> In x G -> In y G->
                                                (edg G x y = edg G' (f x) (f y)).
  Proof. intro H;apply H. Qed.

  Lemma iso_edg2  (G G': @dG A)(f: A-> A)(x y: A): iso_using f G G' -> In x G'-> In y G'->
                                                (edg G' x y = edg G (f x) (f y)).
  Proof. intro H0. cut (iso_using f G' G). intro H;apply H. auto. Qed.

  Hint Immediate iso_cardinal iso_sub_cardinal iso_edg1 iso_edg2: core.

  Lemma iso_edg3(G G': @dG A)(f: A-> A)(x y:A): iso_using f G G' -> In x G -> In y G->
                                                edg G x y -> edg G' (f x) (f y).
  Proof.  intros; replace (edg G' (f x) (f y)) with (edg G x y); auto.  Qed.

  Lemma iso_edg4  (G G': @dG A)(f: A-> A)(x y: A): iso_using f G G' -> In x G -> In y G->
                                                ~ edg G x y -> ~ edg G' (f x) (f y).
  Proof. intros ; replace (edg G' (f x) (f y)) with (edg G x y); auto. Qed.

  Hint Immediate iso_edg3 iso_edg4: core.

  (* ------------- Isomorphism preserves Cliques and Cliq_num for a graph-----------------*)

  Lemma iso_cliq (G G': @dG A)(f: A-> A)(K: list A):
    iso_using f G G' -> K [<=] G-> Cliq G K -> Cliq G' (img f K).
  Proof. {  unfold Cliq. intros H H1 h1.  intros x y Hx Hy.
          assert (H2: exists x0, In x0 K /\ x = f x0). auto.
          destruct H2 as [x0 H2]. destruct H2 as [H2a H2b].
          assert (H3: exists y0, In y0 K /\ y = f y0). auto.
          destruct H3 as [y0 H3]. destruct H3 as [H3a H3b].
          replace x with (f x0). replace y with (f y0).
          assert (H2:  x0 = y0 \/ edg G x0 y0). auto.
          destruct H2.
          { left. subst x0. auto. }
          { right. replace (edg G' (f x0) (f y0)) with (edg G x0 y0).
            auto. apply H. all: auto. }  }  Qed.

   Lemma iso_cliq1 (G G': @dG A)(K: list A): iso G G' -> K [<=] G -> Cliq G K -> NoDup K ->
                                           (exists K', Cliq G' K' /\ |K|=|K'|).
  Proof. { intros H h1 H1 H2. destruct H as [f H].
         exists (img f K). split. eauto using iso_cliq.
         assert (H3: one_one_on K f). eauto.
         auto. } Qed.

  Lemma iso_cliq_in (G G': @dG A)(f: A-> A)(K: list A):
    iso_using f G G' -> Cliq_in G K -> Cliq_in G' (img f K).
  Proof. { intros H H1.
         destruct H1 as [H1a H1]. destruct H1 as [H1b H1c].
         split.
         { destruct H as [Ha H]. destruct H as [Hb Hc]. rewrite Hb; auto. }
         split.
         { auto. }
         { eauto using iso_cliq. }  } Qed.

  Lemma iso_cliq_in1 (G G': @dG A)(K: list A): iso G G' -> Cliq_in G K ->
                                              (exists K', Cliq_in G' K' /\ |K|=|K'|).
  Proof. { intros H H1. destruct H as [f H].
         exists (img f K). split. eauto using iso_cliq_in.
         assert (H3: one_one_on K f). eauto.
         destruct H1 as [H1a H1]. destruct H1 as [H1b H1c]. auto. } Qed.

  Hint Immediate iso_cliq iso_cliq1 iso_cliq_in iso_cliq_in1: core.

  Lemma max_K_in_G' (G G': @dG A)(f: A-> A)(K: list A):
    iso_using f G G' -> Max_K_in G K -> Max_K_in G' (img f K).
  Proof. { intros H H1. assert (H0: iso_using f G' G); auto.
         apply  Max_K_in_intro.
         { cut (Cliq_in G K); eauto. }
         { intros Y H2.
           replace (|Y|) with (|img f Y|).
           replace (|img f K|) with (|K|).
            assert (H3: Cliq_in G (img f Y)). eauto.
           eauto using Max_K_in_elim. eapply iso_sub_cardinal;eauto.
           symmetry. eapply iso_sub_cardinal; eauto. } } Qed.

  Lemma cliq_num_G' (G G': @dG A)(n: nat):
    iso G G' -> cliq_num G n -> cliq_num G' n.
  Proof. { intros H H1. destruct H as [f H]. destruct H1 as [K H1].
         destruct H1 as [H1 H1b]. exists (img f K).
         split. eauto using max_K_in_G'. replace n with (|K|).
         symmetry. eapply iso_sub_cardinal;eauto. } Qed.

  Hint Immediate max_K_in_G' cliq_num_G': core.

  (*---------- Isomorphism preserves Stable set and i_num ----------------------------*)

   Lemma iso_stable (G G': @dG A)(f: A-> A)(I: list A):
    iso_using f G G' -> I [<=] G-> Stable G I -> Stable G' (img f I).
  Proof. {  unfold Stable. intros H h1 H1.  intros x y Hx Hy.
          assert (H2: exists x0, In x0 I /\ x = f x0). auto.
          destruct H2 as [x0 H2]. destruct H2 as [H2a H2b].
          assert (H3: exists y0, In y0 I /\ y = f y0). auto.
          destruct H3 as [y0 H3]. destruct H3 as [H3a H3b].
          replace x with (f x0). replace y with (f y0).
          assert (H2: edg G x0 y0 = false). auto.
          replace (edg G' (f x0) (f y0)) with (edg G x0 y0).
            auto. apply H. all: auto. } Qed.

   Lemma iso_stable1 (G G': @dG A)(I: list A): iso G G' -> I [<=] G-> Stable G I -> NoDup I ->
                                           (exists I', Stable G' I' /\ |I|=|I'|).
  Proof. { intros H h1 H1 H2. destruct H as [f H].
         exists (img f I). split. eauto using iso_stable.
         assert (H3: one_one_on I f). eauto.
         auto. } Qed.

  Lemma iso_stable_in (G G': @dG A)(f: A-> A)(I: list A):
    iso_using f G G' -> Stable_in G I -> Stable_in G' (img f I).
  Proof. { intros H H1.
         destruct H1 as [H1a H1]. destruct H1 as [H1b H1c].
         split.
         { destruct H as [Ha H]. destruct H as [Hb Hc]. rewrite Hb; auto. }
         split.
         { auto. }
         { eauto using iso_stable. }  } Qed.

  Lemma iso_stable_in1 (G G': @dG A)(I: list A): iso G G' -> Stable_in G I ->
                                              (exists I', Stable_in G' I' /\ |I|=|I'|).
  Proof. { intros H H1. destruct H as [f H].
         exists (img f I). split. eauto using iso_stable_in.
         assert (H3: one_one_on I f). eauto.
         destruct H1 as [H1a H1]. destruct H1 as [H1b H1c]. auto. } Qed.

  Hint Immediate iso_stable iso_stable1 iso_stable_in iso_stable_in1: core.

  Lemma max_I_in_G' (G G': @dG A)(f: A-> A)(I: list A):
    iso_using f G G' -> Max_I_in G I -> Max_I_in G' (img f I).
  Proof. { intros H H1. assert (H0: iso_using f G' G); auto.
         apply  Max_I_in_intro.
         { cut (Stable_in G I); eauto. }
         { intros Y H2.
           replace (|Y|) with (|img f Y|).
           replace (|img f I|) with (|I|).
           assert (H3: Stable_in G (img f Y)). eauto.
           eauto using Max_I_in_elim. eapply iso_sub_cardinal;eauto.
           symmetry. eapply iso_sub_cardinal; eauto. } } Qed.

  Lemma i_num_G' (G G': @dG A)(n: nat):
    iso G G' -> i_num G n -> i_num G' n.
  Proof. { intros H H1. destruct H as [f H]. destruct H1 as [I H1].
         destruct H1 as [H1 H1b]. exists (img f I).
         split. eauto using max_I_in_G'. replace n with (|I|).
         symmetry. eapply iso_sub_cardinal;eauto. } Qed.

  Hint Immediate max_I_in_G' i_num_G': core.

  (*----------- Isomorphism , graph coloring and chromatic number-------------------------*)

  Lemma iso_coloring (G G': @dG A)(f: A->A)(C: A->nat):
    iso_using f G G' -> Coloring_of G C -> Coloring_of G' (fun (x:A) => C (f x)).
  Proof. { intros H H1. assert (Ha: iso_using f G' G);auto. unfold Coloring_of.
           intros x y Hx Hy H2. assert (H3: edg G (f x) (f y)). eauto. apply H1; eauto. } Qed.

  Lemma iso_same_clrs (G G': @dG A)(f: A->A)(C: A->nat):
    iso_using f G G' -> Coloring_of G C -> (clrs_of C G) = clrs_of (fun (x:A) => C (f x)) G'.
  Proof. { intros H H1. assert (Ha: iso_using f G' G). auto.
         assert (H2: (nodes G) = img f G'). auto. unfold clrs_of; rewrite H2; auto. } Qed.

  Lemma best_coloring_of_G' (G G': @dG A)(f: A-> A)(C: A->nat):
    iso_using f G G' -> Best_coloring_of G C -> Best_coloring_of G' (fun (x:A) => C (f x)).
  Proof. { unfold Best_coloring_of. intros H H1.
         assert (H0: iso_using f G' G). auto.
         destruct H1 as [H1 H2].
         split. { eauto using iso_coloring. }
                { intros C' H3.
                  assert (H4: (clrs_of C G) = clrs_of (fun (x:A) => C (f x)) G').
                  auto using iso_same_clrs. rewrite <- H4.
                  assert (H5: (clrs_of C' G') = clrs_of (fun (x:A) => C' (f x)) G).
                  auto using iso_same_clrs. rewrite H5.
                  apply H2. eauto using iso_coloring. } } Qed.

  Lemma chrom_num_G' (G G': @dG A)(n:nat):
    iso G G' -> chrom_num G n -> chrom_num G' n.
  Proof. { intros H H1. destruct H as [f H]. destruct H1 as [C H1].
         destruct H1 as [H1 H2].
         exists (fun (x:A) => C (f x)). split. eauto using best_coloring_of_G'.
         subst n. replace (clrs_of (fun x : A => C (f x)) G') with (clrs_of C G).
         auto. destruct H1 as [H1 H2]. auto using iso_same_clrs. } Qed.

  Hint Resolve iso_coloring iso_same_clrs best_coloring_of_G': core.
  Hint Immediate chrom_num_G': core.

  (*------------Isomorphism , nice graphs and perfect graph--------------------------------*)

  Lemma nice_G' (G G': @dG A): iso G G' -> Nice G -> Nice G'.
  Proof. { intro H.  assert (H0: iso G' G). auto.
         unfold Nice. intros H1 n H2.
         cut (chrom_num G n). eauto. cut (cliq_num G n); eauto. } Qed.

  Lemma iso_subgraphs (G G' H: @dG A)(f: A->A):
    iso_using f G G' -> Ind_subgraph H G -> (exists H', Ind_subgraph H' G' /\ iso_using f H H').
  Proof.  { intros F1 F2.
            assert (F0: iso_using f G' G). auto.
            assert (Nk: IsOrd (img f H)). auto.
            pose H' := (Ind_at (img f H) G').
            exists H'.
            assert (h0: H' [<=] G').
            { replace (nodes G') with (img f G). simpl.
              cut (img f H [<=] img f G). auto.
              eapply img_subset. apply F2. symmetry. auto. }
            assert (h1: img f H [<=] G').
            { replace (nodes G') with (img f G).
                cut (H [<=] G). auto. apply F2.  symmetry.
                assert(F3: iso_using f G G'). auto. apply F3. }
            assert (h2: img f H = inter (img f H) G').
            { apply set_equal; auto. }
            split.
            (* Ind_subgraph H' G' *)
            {  unfold Ind_subgraph. split.
               { auto. }
               { unfold H'. simpl. intros. symmetry. auto. } }

            {  (* iso_using f H H' *)
              unfold iso_using.
              split.
              { apply F1. }
              split.
              { simpl. symmetry. auto.  }
              { (* forall x y : A, edg H x y = edg (Ind_at Nk G') (f x) (f y) *)
                simpl. intros x y Hx Hy.
                replace (edg H x y) with (edg G x y).
                cut (In y G). cut (In x G). auto.
                apply F2; auto. apply F2; auto. symmetry; auto. } } } Qed.

  Lemma perfect_G' (G G': @dG A): iso G G' -> Perfect G -> Perfect G'.
  Proof. { intro F.  assert (F0: iso G' G). auto.
         unfold Perfect. destruct F0 as [f F0].
         intros F1 H' F2.
         assert (F3: exists H, Ind_subgraph H G /\ iso_using f H' H).
         { eapply iso_subgraphs. apply F0. auto. }
         destruct F3 as [H F3]. destruct F3 as [F3 F4].
         cut (Nice H).
         { cut (iso H H'). eauto using nice_G'.
           exists f. cut (iso_using f H H'); auto. } auto.  } Qed.

  Hint Immediate nice_G' induced_fact1 iso_subgraphs perfect_G': core.

End GraphIsomorphism.

Hint Resolve f_is_one_one fx_is_one_one img_of_img img_of_img1: core.

Hint Immediate iso_sym1 iso_sym iso_elim1 iso_elim2: core.
 Hint Resolve iso_using_iso iso_using_iso1: core.
Hint Immediate iso_one_one1 iso_one_one2: core.
Hint Immediate iso_one_one iso_f_one_one iso_using_G iso_using_G': core.

Hint Immediate iso_cardinal iso_sub_cardinal iso_edg1 iso_edg2: core.
Hint Immediate iso_edg3 iso_edg4: core.

Hint Immediate iso_cliq iso_cliq1 iso_cliq_in iso_cliq_in1: core.
Hint Immediate max_K_in_G' cliq_num_G': core.

Hint Immediate iso_stable iso_stable1 iso_stable_in iso_stable_in1: core.
Hint Immediate max_I_in_G' i_num_G': core.

Hint Resolve iso_coloring iso_same_clrs best_coloring_of_G': core.
Hint Immediate chrom_num_G': core.

Hint Immediate nice_G' iso_subgraphs perfect_G': core.


Require Import Arith.
Require Import List.

Definition iota (n:nat) : list nat :=
  (fix f (p:nat)(l:(list nat)){struct p}:list nat :=
       match p with
       | 0 => l
       | S q => f q ((S q)::l)
       end)
   n nil.

(** Test:
Compute  (iota 7).

= 1 :: 2 :: 3 :: 4 :: 5 :: 6 :: 7 :: nil
     : list nat
*)


From Coq Require Import ssreflect ssrfun ssrbool.
From PolyAI Require Export TotalMap ssrZ ssrstring Tactic.
Require Export Coq.Sets.Ensembles.
Require Export Coq.ZArith.BinInt.

Require Import String.
Local Open Scope string_scope.
Local Open Scope Z_scope.

(* An affine function *)

Inductive Aff :=
| AConst (c: Z)
| AVar (v: string)
| APlus (a1 a2: Aff)
| AMinus (a1 a2: Aff)
| AMul (c: Z) (a: Aff).

(* Check if a variable is used in an affine function *)

Fixpoint used_in_aff (a: Aff) (v: string) :=
  match a with
  | AConst _ => true
  | AVar v' => (v == v')
  | APlus a1 a2 => used_in_aff a1 v || used_in_aff a2 v
  | AMinus a1 a2 => used_in_aff a1 v || used_in_aff a2 v
  | AMul c a' => used_in_aff a' v
  end.

(* Evaluate an affine function given values for each variable *)

Fixpoint eval_aff (a: Aff) (m: string -> Z) :=
  match a with
  | AConst c => c
  | AVar v => m v
  | APlus a1 a2 => (eval_aff a1 m) + (eval_aff a2 m)
  | AMinus a1 a2 => (eval_aff a1 m) - (eval_aff a2 m)
  | AMul c a => c * (eval_aff a m)
  end.

(* Implementation of a Presburger set / pw_aff library *)

Class PresburgerImpl (PMap PSet PwAff: eqType) :=
  {
    eval_pset : PSet -> (string -> Z) -> bool;

    empty_set : PSet;
    empty_set_spec : forall x, ~~(eval_pset empty_set x);

    universe_set : PSet;
    universe_set_spec : forall x, eval_pset universe_set x;

    union_set : PSet -> PSet -> PSet;
    union_set_spec : forall p1 p2 x,
        eval_pset (union_set p1 p2) x = eval_pset p1 x || eval_pset p2 x;

    intersect_set : PSet -> PSet -> PSet;
    intersect_set_spec : forall p1 p2 x,
        eval_pset (intersect_set p1 p2) x = eval_pset p1 x && eval_pset p2 x;

    subtract_set : PSet -> PSet -> PSet;
    subtract_set_spec : forall p1 p2 x,
        eval_pset (subtract_set p1 p2) x = eval_pset p1 x && ~~ (eval_pset p2 x);

    is_subset : PSet -> PSet -> bool;
    is_subset_spec : forall p1 p2, is_subset p1 p2 <->
                              forall x, eval_pset p1 x -> eval_pset p2 x;

    set_project_out : PSet -> string -> PSet;
    set_project_out_spec : forall p d (m: total_map), eval_pset (set_project_out p d) m <->
                                    exists v, eval_pset p (d !-> v; m);

    eval_pmap : PMap -> (string -> Z) -> (string -> Z) -> bool;

    empty_map : PMap;
    empty_map_spec : forall x y, ~~(eval_pmap empty_map x y);

    universe_map : PMap;
    universe_map_spec : forall x y, eval_pmap universe_map x y;

    id_map : PMap;
    id_map_spec : forall (x y: total_map), eval_pmap id_map x y = (x == y);

    union_map : PMap -> PMap -> PMap;
    union_map_spec : forall p1 p2 x y,
        eval_pmap (union_map p1 p2) x y = eval_pmap p1 x y || eval_pmap p2 x y;

    intersect_map : PMap -> PMap -> PMap;
    intersect_map_spec : forall p1 p2 x y,
        eval_pmap (intersect_map p1 p2) x y = eval_pmap p1 x y && eval_pmap p2 x y;

    is_subset_map : PMap -> PMap -> bool;
    is_subset_map_spec : forall p1 p2, is_subset_map p1 p2 <->
                                  forall (x y: total_map), eval_pmap p1 x y -> eval_pmap p2 x y;

    map_project_out_in : PMap -> string -> PMap;
    map_project_out_in_spec : forall p d (m_in: total_map) m_out, eval_pmap (map_project_out_in p d) m_in m_out <->
                                                             exists v, eval_pmap p (d !-> v; m_in) m_out;

    map_project_out_out : PMap -> string -> PMap;
    map_project_out_out_spec : forall p d m_in (m_out: total_map), eval_pmap (map_project_out_out p d) m_in m_out <->
                                                              exists v, eval_pmap p m_in (d !-> v; m_out);

    map_apply_range : PMap -> PMap -> PMap;
    map_apply_range_spec : forall a1 a2 m_in m_out, eval_pmap (map_apply_range a1 a2) m_in m_out <-> exists (m_mid: total_map), eval_pmap a1 m_in m_mid /\ eval_pmap a2 m_mid m_out;

    map_apply_range_bot : forall a, map_apply_range a empty_map = empty_map;

    transitive_closure_map : PMap -> PMap;
    transitive_closure_map_ge_step : forall a, is_subset_map a (transitive_closure_map a);
    transitive_closure_map_ge_id : forall a, is_subset_map id_map (transitive_closure_map a);
    transitive_closure_map_eq_compose : forall a, is_subset_map (map_apply_range (transitive_closure_map a) a) (transitive_closure_map a);

    eval_pw_aff : PwAff -> (string -> Z) -> option Z;

    pw_aff_from_aff : Aff -> PwAff;
    pw_aff_from_aff_spec : forall a x, eval_pw_aff (pw_aff_from_aff a) x = Some (eval_aff a x);

    empty_pw_aff : PwAff;
    empty_pw_aff_spec : forall x, eval_pw_aff empty_pw_aff x = None;

    intersect_domain : PwAff -> PSet -> PwAff;
    intersect_domain_spec : forall p s x, eval_pw_aff (intersect_domain p s) x =
                                     if eval_pset s x then
                                       eval_pw_aff p x
                                     else
                                       None;

    union_pw_aff : PwAff -> PwAff -> PwAff;
    union_pw_aff_spec : forall p1 p2 x, eval_pw_aff (union_pw_aff p1 p2) x =
                                   match eval_pw_aff p1 x with
                                   | None => eval_pw_aff p2 x
                                   | r => r
                                   end;

    add_pw_aff : PwAff -> PwAff -> PwAff;
    add_pw_aff_spec : forall p1 p2 x, eval_pw_aff (add_pw_aff p1 p2) x =
                                 match (eval_pw_aff p1 x, eval_pw_aff p2 x) with
                                 | (Some v1, Some v2) => Some (v1 + v2)
                                 | _ => None
                                 end;

    eq_set : PwAff -> PwAff -> PSet;
    eq_set_spec : forall p1 p2 x, eval_pset (eq_set p1 p2) x =
                                          match (eval_pw_aff p1 x, eval_pw_aff p2 x) with
                                          | (Some v1, Some v2) => v1 == v2
                                          | _ => false
                                          end;

    ne_set : PwAff -> PwAff -> PSet;
    ne_set_spec : forall p1 p2 x, eval_pset (ne_set p1 p2) x =
                                          match (eval_pw_aff p1 x, eval_pw_aff p2 x) with
                                          | (Some v1, Some v2) => (v1 != v2)
                                          | _ => false
                                          end;

    le_set : PwAff -> PwAff -> PSet;
    le_set_spec : forall p1 p2 x, eval_pset (le_set p1 p2) x =
                             match (eval_pw_aff p1 x, eval_pw_aff p2 x) with
                             | (Some v1, Some v2) => v1 <=? v2
                             | _ => false
                             end;

    indicator_function : PSet -> PwAff;
    indicator_function_spec : forall s x, eval_pw_aff (indicator_function s) x =
                                     if eval_pset s x then
                                       Some 1
                                     else
                                       Some 0;

    eq_map : PwAff -> PwAff -> PwAff -> PwAff -> PMap;
    eq_map_spec : forall p1 p2 p1' p2' x y, eval_pmap (eq_map p1 p2 p1' p2') x y =
                                       match (eval_pw_aff p1 x, eval_pw_aff p2 y, eval_pw_aff p1' x, eval_pw_aff p2' y) with
                                       | (Some v1, Some v2, Some v1', Some v2') => v1 + v2 == v1' + v2'
                                       | _ => false
                                       end;

    ne_map : PwAff -> PwAff -> PwAff -> PwAff -> PMap;
    ne_map_spec : forall p1 p2 p1' p2' x y, eval_pmap (ne_map p1 p2 p1' p2') x y =
                                       match (eval_pw_aff p1 x, eval_pw_aff p2 y, eval_pw_aff p1' x, eval_pw_aff p2' y) with
                                       | (Some v1, Some v2, Some v1', Some v2') => v1 + v2 != v1' + v2'
                                       | _ => false
                                       end;

    pw_aff_involves_dim : PwAff -> string -> bool;
    pw_aff_involves_dim_spec :
      forall p s, pw_aff_involves_dim p s <-> forall (x: total_map) v, eval_pw_aff p x = eval_pw_aff p (s !-> v ; x);

    get_involved_dim : PwAff -> seq string;
    get_involved_dim_spec :
      forall p s, s \in get_involved_dim p = pw_aff_involves_dim p s;

    pullback_dims : PwAff -> seq (string * PwAff) -> PwAff;
    pullback_dims_spec :
      forall p l (x: total_map),
        let l_option_Z := [seq (v.1, eval_pw_aff v.2 x) | v <- l] in
        eval_pw_aff (pullback_dims p l) x =
        if all (fun x => x.2 != None) l_option_Z then
          let l_Z := [seq (v.1, if v.2 is Some z then z else 0) | v <- l_option_Z] in
          eval_pw_aff p (t_update_multiple x l_Z)
        else
          None;
  }.

Section PresburgerTheorems.

  Context {PMap PSet PwAff: eqType}
          {PI: PresburgerImpl PMap PSet PwAff}.

  Theorem empty_set_spec_rw :
    forall x, eval_pset empty_set x = false.
  Proof.
    move => x.
      by rewrite (negbTE (empty_set_spec _)).
  Qed.

  Theorem empty_map_spec_rw :
    forall x y, eval_pmap empty_map x y = false.
  Proof.
    move => x y.
      by rewrite (negbTE (empty_map_spec _ _)).
  Qed.

  Theorem is_subset_refl :
    forall p, is_subset p p.
  Proof.
    move => p.
      by apply is_subset_spec.
  Qed.

  Theorem is_subset_map_refl :
    forall p, is_subset_map p p.
  Proof.
    move => p.
      by apply is_subset_map_spec.
  Qed.

  Theorem is_subset_trans :
    forall p1 p2 p3, is_subset p1 p2 ->
                is_subset p2 p3 ->
                is_subset p1 p3.
  Proof.
    move => p1 p2 p3.
    rewrite !is_subset_spec.
      by auto.
  Qed.

  Theorem is_subset_map_trans :
    forall p1 p2 p3, is_subset_map p1 p2 ->
                is_subset_map p2 p3 ->
                is_subset_map p1 p3.
  Proof.
    move => p1 p2 p3.
    rewrite !is_subset_map_spec.
    by auto.
  Qed.

  Theorem is_subset_union_l :
    forall p1 p2, is_subset p1 (union_set p1 p2).
  Proof.
    move => p1 p2.
    rewrite is_subset_spec => x Hp1.
      by rewrite union_set_spec Hp1.
  Qed.

  Theorem is_subset_union_r :
    forall p1 p2, is_subset p2 (union_set p1 p2).
  Proof.
    move => p1 p2.
    rewrite is_subset_spec => x Hp2.
      by rewrite union_set_spec Hp2 orbT.
  Qed.

End PresburgerTheorems.

Hint Rewrite @empty_set_spec_rw @universe_set_spec @union_set_spec @intersect_set_spec
     @subtract_set_spec @map_apply_range_spec
     @empty_map_spec_rw @universe_map_spec @id_map_spec @union_map_spec @intersect_map_spec
     @pw_aff_from_aff_spec @intersect_domain_spec @union_pw_aff_spec @eq_set_spec @ne_set_spec @le_set_spec @indicator_function_spec
     @add_pw_aff_spec
     @eq_map_spec @ne_map_spec @empty_pw_aff_spec
  using by first [liassr | autossr ] : prw.

Hint Resolve @is_subset_spec @is_subset_map_spec @is_subset_refl @is_subset_map_refl @set_project_out_spec @is_subset_map_spec : core.

Ltac simpl_presburger_ := repeat (autorewrite with prw; simpl_map).
Ltac simpl_presburger := reflect_ne_in simpl_presburger_.

Ltac auto_presburger := intros ; simpl_presburger; autossr.


(** * Lógica Computacional 1 - 2021-2 *)
(** ** Equivalência entre o Princípio da Indução Matemática (PIM) e o Princípio da Indução Forte (PIF) *)

Require Import Arith.

(** Seja [P] uma propriedade sobre os números naturais. O PIM pode ser enunciado da seguinte forma: *)

Definition PIM :=
  forall P: nat -> Prop,
    (P 0) ->
    (forall n, P n -> P (S n)) ->
    forall n, P n.

(** Seja [Q] uma propriedade sobre os números naturais. O PIF pode ser enunciado da seguinte forma:  *)

Definition PIF :=
  forall Q: nat -> Prop,
    (forall n, (forall m, m<n -> Q m) -> Q n) ->
    forall n, Q n.

(** Prove que PIM e PIF são equivalentes, ou seja, prove os lemas e o teorema a seguir: *)

Lemma PIF_to_PIM: PIF -> PIM.
Proof.
(* Substitua esta linha pela sua prova*) Admitted.

Lemma PIM_to_PIF: PIM -> PIF.
Proof.
(* Substitua esta linha pela sua prova*) Admitted.

Theorem PIM_equiv_PIF: PIM <-> PIF.
Proof.
  (* Substitua esta linha pela sua prova*) Admitted.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(** ** Binomial theorem *)

Require Import Arith Omega.

Require Import utils_tac gcd.

Set Implicit Arguments.

Section factorial.

  Fixpoint fact n := match n with 0 => 1 | S n => (S n) * fact n end.

  Fact fact_0 : fact 0 = 1.
  Proof. trivial. Qed.

  Fact fact_S n : fact (S n) = (S n)*fact n.
  Proof. trivial. Qed.

  Fact fact_gt_0 n : 0 < fact n.
  Proof.
    unfold lt; simpl.
    induction n as [ | n IHn ]; simpl; auto.
    generalize (n*fact n); intros; omega.
  Qed.

End factorial.

Section binomial.

  Infix "<d" := divides (at level 70, no associativity).

  Hint Resolve divides_refl.

  Let fact_neq_0 n : fact n <> 0.
  Proof. generalize (fact_gt_0 n); omega. Qed.

  Fixpoint binomial n p :=
    match n, p with
      | n, 0     => 1
      | 0, S _   => 0
      | S n, S p => binomial n p + binomial n (S p)
    end.

  Fact binomial_n0 n : binomial n 0 = 1.
  Proof. destruct n; auto. Qed.

  Fact binomial_SS n p : binomial (S n) (S p) = binomial n p + binomial n (S p).
  Proof. auto. Qed.

  Fact binomial_n1 n : 1 <= n -> binomial n 1 = n.
  Proof.
    destruct n as [ | n ]; try omega; intros _.
    induction n as [ | n IHn ]; auto.
    rewrite binomial_SS, IHn, binomial_n0; omega.
  Qed.

  Fact binomial_gt n : forall p, n < p -> binomial n p = 0.
  Proof.
    induction n as [ | n IHn ]; intros [|] ?; simpl; auto; try omega.
    do 2 (rewrite IHn; try omega).
  Qed.

  Fact binomial_nn n : binomial n n = 1.
  Proof.
    induction n; auto; rewrite binomial_SS, binomial_gt with (p := S _); omega.
  Qed.

  Theorem binomial_thm n p : p <= n -> fact n = binomial n p * fact p * fact (n-p).
  Proof.
    intros H.
    replace n with (n-p+p) at 1 2 by omega.
    generalize (n-p); clear n H; intros n.
    induction on n p as IH with measure (n+p).
    revert n p IH; intros [ | n ] [ | p ] IH; simpl plus; auto.
    + rewrite binomial_nn; simpl; omega.
    + rewrite Nat.add_0_r, binomial_n0; simpl; omega.
    + rewrite fact_S, binomial_SS.
      replace (S (n+S p)) with (S p+S n) by omega.
      do 3 rewrite Nat.mul_add_distr_r; f_equal.
      * replace (n+S p) with (S n+p) by omega.
        rewrite fact_S, IH; try omega; ring.
      * rewrite (fact_S n), IH; try omega; ring.
  Qed.

  Fact binomial_le n p : p <= n -> binomial n p = div (fact n) (fact p * fact (n-p)).
  Proof.
    intros H.
    symmetry; apply div_prop with (r := 0).
    + rewrite binomial_thm with (p := p); auto; ring.
    + red; change 1 with (1*1); apply mult_le_compat; apply fact_gt_0.
  Qed.

  Fact binomial_sym n p : p <= n -> binomial n p = binomial n (n-p).
  Proof.
    intros H; do 2 (rewrite binomial_le; try omega).
    rewrite mult_comm; do 3 f_equal; omega.
  Qed.

  Fact binomial_spec n p : p <= n -> fact n = binomial n p * fact p * fact (n-p).
  Proof. apply binomial_thm. Qed.

  Fact binomial_0n n : 0 < n -> binomial 0 n = 0.
  Proof. intros; rewrite binomial_gt; auto; simpl. Qed.

  Theorem binomial_pascal n p : binomial (S n) (S p) = binomial n p + binomial n (S p).
  Proof. auto. Qed.

End binomial.


(* This module defines Tarjan's variant of Ackermann's function,
   and establishes some of its properties. *)

From iris_time.union_find.math Require Import LibNatExtra LibFunOrd
  LibIter LibRewrite.

(* -------------------------------------------------------------------------- *)

(* Tarjan's definition, formulated in terms of [iter]. *)

Definition Abase :=
  fun x => 1 + x.

Definition Astep :=
  fun Ak x => iter (1 + x) Ak x.

Definition A k :=
  iter k Astep Abase.

(* -------------------------------------------------------------------------- *)

(* Tarjan's characteristic equations are satisfied. *)

Lemma Abase_eq:
  forall x,
  A 0 x = 1 + x.
Proof using.
  reflexivity.
Qed.

Lemma Astep_eq:
  forall k x,
  A (1 + k) x = iter (1 + x) (A k) x.
Proof using.
  reflexivity.
Qed.

(* -------------------------------------------------------------------------- *)

(* Closed forms for [A 1] and [A 2], from Cormen et al. *)

Lemma A_1_eq:
  forall x,
  A 1 x = 2 * x + 1.
Proof using.
  assert (fact: forall x y, iter x (A 0) y = x + y).
    induction x; intros; simpl.
    auto.
    rewrite IHx. auto.
  intro x.
  rewrite Astep_eq.
  rewrite fact.
  lia.
Qed.

Lemma iter_A_1_eq:
  forall i x,
  iter i (A 1) x =
  2^i * (1 + x) - 1.
Proof using.
  Opaque plus. (* TEMPORARY ugly *)
  induction i; simpl; intros.
  lia.
  rewrite A_1_eq. rewrite IHi.
  (* Now for some pain... *)
  assert (0 < 2^i). { eauto using power_positive. }
  assert (0 < 1+x). { lia. }
  generalize dependent (2^i); intro n; intros.
  generalize dependent (1+x); intro y; intros.
  assert (0 < n * y). { eauto using mult_positive. }
  rewrite <- Mult.mult_assoc.
  generalize dependent (n * y); intros ny; intros.
  lia. (* phew! *)
  Transparent plus.
Qed.

Lemma A_2_eq:
  forall x,
  A 2 x = 2^(1 + x) * (1 + x) - 1.
Proof using.
  intros. rewrite Astep_eq. eapply iter_A_1_eq.
Qed.

(* -------------------------------------------------------------------------- *)

(* Every [A k] is inflationary. That is, [x <= A k x] holds. *)

Local Notation everywhere :=
  (fun _ => True).

Local Notation inflationary_ :=
  (inflationary everywhere le).

Lemma inflationary_Abase:
  inflationary_ Abase.
Proof using.
  unfold inflationary, Abase. intros. lia.
Qed.

Lemma preserves_inflationary_Astep:
  preserves inflationary_ Astep.
Proof using.
  unfold preserves, within, inflationary, Astep. intros.
  eapply iter_inflationary with (okA := everywhere);
    unfold preserves, within;
    eauto using Nat.le_trans.
Qed.

Lemma Ak_inflationary:
  forall k,
  inflationary_ (A k).
Proof using.
  intro. unfold A.
  eapply iter_invariant.
    eapply inflationary_Abase.
    eapply preserves_inflationary_Astep.
Qed.

Lemma iter_Ak_inflationary:
  forall n k x,
  x <= iter n (A k) x.
Proof using.
  intros.
  (* Kind of reproving the same thing again... *)
  eapply iter_inflationary with (okA := everywhere);
    unfold preserves, within;
    eauto using Nat.le_trans, Ak_inflationary.
Qed.

(* -------------------------------------------------------------------------- *)

(* [Astep] is inflationary. That is, for every inflationary function [Ak],
   [Ak <= Astep Ak] holds -- this is a pointwise inequality. *)

Lemma inflationary_Astep:
  inflationary inflationary_ (pointwise everywhere le) Astep.
Proof using.
  unfold inflationary, pointwise, Astep. intros.
  simpl. rewrite iter_iter_1.
  eapply iter_inflationary with (okA := everywhere);
    unfold preserves, within; eauto using Nat.le_trans.
Qed.

(* -------------------------------------------------------------------------- *)

(* The function [A] is monotonic. (That is, it is monotonic in its first
   argument [k], and the results, which are functions, are compared using
   pointwise inequality.) *)

Lemma A_monotonic:
  monotonic le (pointwise everywhere le) A.
Proof using.
  unfold A.
  (* We must prove that [iter k Astep Abase] is monotonic with respect to [k].
     Because the lemma [inflationary_Astep] has an inflation hypothesis, we
     must carry the information that [A k] is inflationary. This is done by
    picking an appropriate [okA]. *)
  eapply iter_monotonic_in_n_specialized with (okA := inflationary_);
    unfold pointwise; eauto using Nat.le_trans, inflationary_Abase,
    preserves_inflationary_Astep, inflationary_Astep.
Qed.

(* As a corollary, the function [fun k => A k x] is monotonic. In other
   words, Ackermann's function is monotonic in its first argument. *)

Lemma Akx_monotonic_in_k:
  forall x,
  monotonic le le (fun k => A k x).
Proof using.
  (* Forgetting [x], it suffices to argue that [A] is monotonic. *)
  intro.
  eapply monotonic_pointwise_specialize with (okB := everywhere);
    eauto using A_monotonic.
Qed.

Hint Resolve Akx_monotonic_in_k : monotonic typeclass_instances.

(* Example. *)

Goal
  forall k1 k2 x, k1 <= k2 -> A k1 x <= A k2 x.
Proof using.
  eauto with monotonic. (* cool *)
Qed.

(* -------------------------------------------------------------------------- *)

(* The function [fun x => A k x] is monotonic. In other words, Ackermann's
   function is monotonic in its second argument. *)

Lemma monotonic_Abase:
  monotonic le le Abase.
Proof using.
  unfold monotonic, Abase. intros. lia.
Qed.

Lemma preserves_monotonic_Astep:
  forall f,
  inflationary_ f ->
  monotonic le le f ->
  monotonic le le (Astep f).
Proof using.
  intros. intros x1 x2 ?. unfold Astep.
  eapply Nat.le_trans; [ | eapply iter_monotonic_in_x; eauto ].
  eapply iter_monotonic_in_n with (okA := everywhere);
    unfold preserves, within; eauto using Nat.le_trans.
  lia.
Qed.

Lemma Akx_monotonic_in_x:
  forall k,
  monotonic le le (A k).
Proof using.
  (* Because the lemma [preserves_monotonic_Astep] has an inflation
     hypothesis, we argue simultaneously that [A k] is inflationary
     and monotonic. This is a little redundant, but seems acceptable. *)
  cut (forall k, inflationary_ (A k) /\ monotonic le le (A k)).
    { intro h. eapply h. }
  intro. unfold A.
  eapply iter_invariant; split; simpl in *;
  intuition eauto using inflationary_Abase, monotonic_Abase,
    preserves_inflationary_Astep, preserves_monotonic_Astep.
Qed.

Hint Resolve Akx_monotonic_in_x Akx_monotonic_in_k : monotonic typeclass_instances.

(* Example. *)

Goal
  forall k x1 x2, x1 <= x2 -> A k x1 <= A k x2.
Proof using.
  eauto with monotonic. (* cool *)
Qed.

(* -------------------------------------------------------------------------- *)

(* The power function [pow] can be defined in terms of [iter]. *)

Lemma pow_iter:
  forall x y,
  x ^ y = iter y (fun a => x * a) 1.
Proof using.
  induction y; simpl; eauto.
Qed.

(* [2 ^ x <= A 2 x]. *)

Lemma A_2_lower_bound:
  forall x,
  2 ^ x <= A 2 x.
Proof using.
  (* Tarjan's course notes claim a strict inequality, but in fact there
     is equality when [x] is zero. *)
  intro.
  rewrite pow_iter.
  rewrite Astep_eq.
  rewrite iter_iter_1p.
  rewrite A_1_eq.
  (* We are now comparing two applications of [iter]. It suffices to
     exploit the fact that [iter n f x] is monotonic in [f] and [x]. *)
  eapply Nat.le_trans; [ eapply iter_monotonic_in_f | eapply iter_monotonic_in_x ].
    (* from [iter_monotonic_in_f] *)
    eauto.
    eauto using Nat.le_trans.
    split.
      eauto with monotonic.
      unfold pointwise. intros. rewrite A_1_eq. lia.
    (* from [iter_monotonic_in_x] *)
    eauto with monotonic.
    lia.
Qed.

(* A slightly more powerful version of the previous lemma. It is not a
   direct consequence of the previous lemma, because [2 ^ (log2 n)] is
   in general less than or equal to [n]. *)

Lemma A_2_log2_lower_bound:
  forall n,
  n <= A 2 (log2 n).
Proof using.
  (* It is somewhat miraculous that this auxiliary assertion holds. *)
  assert (forall b n, n <= 2 * iter (log2 n) (A 1) b + 1).
  { intros. eapply (log2_induction (fun k n => n <= 2 * iter k (A 1) b + 1)). lia. lia.
    intros. simpl. rewrite A_1_eq. eauto with div2. }
  intros. rewrite Astep_eq. simpl. rewrite A_1_eq. eauto.
  (* An alternative proof would consist in using [A_2_eq] together
     with the fact that [2^(1 + log2 n)] is at least [n + 1]. *)
Qed.

(* [2 ^ (2 ^ ( ... 2)) { x + 1 times } <= A 3 x]. *)

Lemma A_3_lower_bound:
  forall x,
  iter (1 + x) (fun a => 2 ^ a) 0 <= A 3 x.
Proof using.
  intro.
  rewrite Astep_eq.
  (* We are now comparing two applications of [iter]. It suffices to
     exploit the fact that [iter n f x] is monotonic in [f] and [x]. *)
  eapply Nat.le_trans; [ eapply iter_monotonic_in_f | eapply iter_monotonic_in_x ].
    (* from [iter_monotonic_in_f] *)
    eauto.
    eauto using Nat.le_trans.
    split.
      eauto with monotonic.
      unfold pointwise. eauto using A_2_lower_bound.
    (* from [iter_monotonic_in_x] *)
    eauto with monotonic.
    lia.
Qed.

(* -------------------------------------------------------------------------- *)

From iris_time.union_find.math Require Import Filter.
From iris_time.union_find.math Require Import FilterTowardsInfinity.

(* For every [k], the function [fun x => A k x] tends towards infinity. *)

Lemma Akx_tends_to_infinity_along_x:
  forall k,
  limit towards_infinity towards_infinity (fun x => A k x).
Proof using.
  intro.
  eapply prove_tends_towards_infinity.
  (* It suffices to exploit the fact that [A k] is inflationary,
     i.e. [x <= A k x] holds. *)
  intros. exists y. intros ? h.
  rewrite h. eapply Ak_inflationary; eauto.
Qed.

(* For every [x] greater than zero, the function [fun k => A k x] tends
   towards infinity. We prove this via a very weak lower bound, namely
   [k <= A k x]. *)

Lemma Ax_inflationary:
  forall x,
  x > 0 ->
  inflationary_ (fun k => A k x).
Proof using.
  unfold inflationary.
  intros x ? k _.
  induction k; intros; simpl.
  (* Base. *)
  lia.
  (* Step. *)
  rewrite Astep_eq.
  (* [1 + x] is at least 2, and [iter] is monotonic in [n]. *)
  transitivity (iter 2 (A k) x).
    2: eapply iter_monotonic_in_n_specialized with (okA := everywhere);
         unfold preserves, within;
         eauto using Nat.le_trans, Ak_inflationary
                with lia.
  (* Unfold [iter], and exploit the induction hypothesis (which is
     possible because [A k] is monotonic). *)
  simpl.
  transitivity (A k k).
    2: eauto with monotonic.
  (* Now, [A k k] is at least [A 0 k]. *)
  transitivity (A 0 k).
    2: eauto with monotonic lia.
  (* And [A 0 k] is precisely [1 + k]. *)
  rewrite Abase_eq at 1.
  lia.
Qed.

Lemma Akx_tends_to_infinity_along_k:
  forall x,
  x > 0 ->
  limit towards_infinity towards_infinity (fun k => A k x).
Proof using.
  intros.
  eapply prove_tends_towards_infinity.
  intros. exists y. intros.
  rewrite Ax_inflationary by eauto.
  eauto with monotonic.
Qed.

Hint Resolve Akx_tends_to_infinity_along_k : monotonic typeclass_instances.
  (* exploited in [InverseAckermann.v] *)

(* -------------------------------------------------------------------------- *)

(* Every [A k] is strictly inflationary. That is, [x < A k x] holds. *)

Lemma Ak_strictly_inflationary:
  forall k x,
  x < A k x.
Proof using.
  (* [A 0] is strictly inflationary already, and [A k] is no less than
     [A 0]. The result follows by transitivity. *)
  intros.
  assert (x < A 0 x).
    { rewrite Abase_eq. lia. }
  assert (A 0 x <= A k x).
    { eauto with monotonic lia. }
  lia.
Qed.

(* For every [n] other than zero, [iter n (A k)] is strictly inflationary. *)

Lemma iter_Ak_strictly_inflationary:
  forall n k x,
  n > 0 ->
  x < iter n (A k) x.
Proof using.
  intros. destruct n; [ lia | ]. simpl.
  assert (x < A k x).
    { eapply Ak_strictly_inflationary. }
  assert (A k x <= A k (iter n (A k) x)).
    { eauto using iter_Ak_inflationary with monotonic. }
  lia.
Qed.

(* -------------------------------------------------------------------------- *)

(* The function [fun k => A k x] is strictly monotonic in [k]. *)

Lemma Akx_strictly_monotonic_in_k_step:
  forall k x,
  x > 0 ->
  A k x < A (1 + k) x.
Proof using.
  intros. rewrite Astep_eq. simpl. rewrite iter_iter_1.
  eauto using iter_Ak_strictly_inflationary.
Qed.

Lemma Akx_strictly_monotonic_in_k:
  forall x,
  x > 0 ->
  monotonic lt lt (fun k => A k x).
Proof using.
  intros. intros k1 k2 ?.
  assert (A k1 x < A (1 + k1) x).
    { eauto using Akx_strictly_monotonic_in_k_step. }
  assert (A (1 + k1) x <= A k2 x).
    { eauto with monotonic lia. }
  lia.
Qed.

Hint Resolve Akx_strictly_monotonic_in_k : monotonic typeclass_instances.

(* -------------------------------------------------------------------------- *)

(* The orbit of a strictly inflationary function goes to infinity. *)

Lemma iter_strictly_inflationary_tends_to_infinity:
  forall f x,
  (forall x, x < f x) ->
  limit towards_infinity towards_infinity (fun i => iter i f x).
Proof using.
  (* This lemma has nothing to do with Ackermann's function and could
     be placed in a separate file. *)
  (* A strictly inflationary function grows by at least one at each
     iteration, so we can give a linear lower bound for it. This
     implies that iterating over and over takes us to infinity. *)
  intros f x hinfl.
  assert (bound: forall i, x + i <= iter i f x).
  { intro. eapply iter_indexed_invariant; [ | lia ]. intros j y ?.
    generalize (hinfl y). lia. }
  (* Manual proof. *)
  eapply prove_tends_towards_infinity.
  intro y. exists y. intros z ?.
  generalize (bound z). lia.
Qed.

(* The orbit of [A k] out of [x] goes to infinity. *)

Lemma iter_i_Akx_tends_to_infinity_along_i:
  forall k x,
  limit towards_infinity towards_infinity (fun i => iter i (A k) x).
Proof using.
  eauto using iter_strictly_inflationary_tends_to_infinity, Ak_strictly_inflationary.
Qed.

(* Iterating [i] times an inflationary function [f] yields a monotonic function
   of [i]. *)

Lemma iter_inflationary_monotonic:
  forall f x,
  (forall x, x <= f x) ->
  monotonic le le (fun i => iter i f x).
Proof using.
  intros f x hinfl i j ?.
  replace j with ((j - i) + i) by lia.
  rewrite iter_iter.
  generalize (iter i f x). intro y.
  eapply iter_inflationary with (okA := everywhere);
    unfold preserves, within, inflationary; eauto using Nat.le_trans.
Qed.

(* [fun i => iter i (A k) x] is monotonic. *)

Lemma iter_Ak_monotonic_in_i:
  forall k x,
  monotonic le le (fun i => iter i (A k) x).
Proof using.
  intros.
  eapply iter_inflationary_monotonic.
  intro. eapply Ak_inflationary. tauto.
Qed.


Require Import Arith.

Fixpoint div3 (n:nat): nat :=
  match n with
    | 0 | 1 | 2 => 0
    | S (S (S p)) => S (div3 p)
  end.

Lemma nat_ind3 (P : nat -> Prop) :
  P 0 -> P 1 -> P 2 ->
  (forall i:nat, P i -> P (3 + i)) ->
  forall n:nat, P n.
Proof.
 intros H0 H1 H2 HS n.
 assert (H :P n /\ P (S n) /\ P (S (S n))).
 induction n.
 split;auto.
 destruct IHn as [Hn [HSn HSSn]];repeat split;auto.
 - apply HS;auto.
 -  tauto.
Qed.

Lemma div3_le : forall n, div3 n <= n.
Proof.
induction n using nat_ind3; auto.
 - simpl; apply le_trans with (S n);auto with arith.
Qed.


Require Import PeanoNat.
Local Open Scope nat_scope.

Inductive Var := x | y | result.

Fixpoint var_eq (v1 v2 : Var) :=
  match v1, v2 with
  | x, x => true
  | y, y => true
  | result,result =>true
  | _, _ => false
  end.

Inductive AExp :=

| anum : nat -> AExp
| avar : Var -> AExp
| aplus : AExp -> AExp -> AExp
| amul : AExp -> AExp -> AExp
| aminus : AExp -> AExp -> AExp
| adivision : AExp -> AExp -> AExp
| amodulo : AExp->AExp->AExp.

Notation "A +' B" := (aplus A B) (at level 50).
Notation "A *' B" := (amul A B) (at level 46).
Notation "A -' B" := (aminus A B) (at level 50).
Notation "A /' B " := (adivision A B) (at level 45).
Notation "A %' B" := (amodulo A B) (at level 35).

Coercion anum : nat >-> AExp.
Coercion avar : Var >-> AExp.

Definition State := Var -> nat.
(* lookup:  *)
Definition sigma0 : State := fun n => 0.
Check sigma0.
Compute (sigma0 x).
Compute (sigma0 y).

(* update *)
Definition update (sigma : State)
           (v : Var) (val : nat) : State :=
  fun v' => if (var_eq v v')
            then val
            else (sigma v').
Definition sigma1 := (update sigma0 x 10).
Compute (sigma1 x).

Reserved Notation "A =[ S ]=> N" (at level 60).

Inductive aeval : AExp -> State -> nat -> Prop :=
| aconst : forall n st, anum n =[ st ]=> n
| alookup : forall v st, avar v =[ st ]=> (st v)
| aadd : forall a1 a2 i1 i2 st n,
    a1 =[ st ]=> i1 ->
    a2 =[ st ]=> i2 ->
    n = i1 + i2 ->
    a1 +' a2 =[ st ]=> n
| atimes : forall a1 a2 i1 i2 st n,
    a1 =[ st ]=> i1 ->
    a2 =[ st ]=> i2 ->
    n = i1 * i2 ->
    a1 *' a2 =[ st ]=> n
| aminusRule : forall a1 a2 i1 i2 st n,
    a1 =[ st ]=> i1 ->
    a2 =[ st ]=> i2 ->
    n = i1 -i2 ->
    i1 > i2 ->
    a1 -' a2 =[ st ]=> n
| adivisionRule : forall a1 a2 i1 i2 st n,
    a1 =[ st ]=> i1 ->
    a2 =[ st ]=> i2 ->
    n = i1 / i2 ->
    i2 <> 0 ->
    a1 /' a2 =[ st ]=> n
| amoduloRule : forall a1 a2 i1 i2 st n,
    a1 =[ st ]=> i1 ->
    a2 =[ st ]=> i2 ->
    i2 <> 0 ->
    n = i1 mod i2 ->
    a1 %' a2 =[ st ]=> n
where "A =[ S ]=> N" := (aeval A S N).

Example e1 :
  2 +' x =[ sigma1 ]=> 2 + 10.
Proof.
  apply aadd with
      (i1 := 2)(i2 := 10); auto.
  - apply aconst.
  - apply alookup.
Qed.

Example e2 :
  2 +' x =[ sigma1 ]=> 12.
Proof.
  apply aadd with
      (i1 := 2)(i2 := 10); auto.
  - apply aconst.
  - apply alookup.
Qed.

Example e2' :
  2 +' x =[ sigma1 ]=> 12.
Proof.
  eapply aadd.
  - apply aconst.
  - apply alookup.
  - auto.
Qed.

(*
Lemma aeval_is_deterministic:
  forall aexp st n n',
    aexp =[ st ]=> n ->
    aexp =[ st ]=> n' ->
    n = n'.
Proof.
  induction aexp; intros;
    inversion H; inversion H0;
      subst; auto.
  - assert (IH1: i1 = i0).
    eapply IHaexp1; eauto.
    assert (IH2 : i2 = i3).
    eapply IHaexp2; eauto.
    subst.
    reflexivity.
  - assert (IH1: i1 = i0).
    eapply IHaexp1; eauto.
    assert (IH2 : i2 = i3).
    eapply IHaexp2; eauto.
    subst.
    reflexivity.
Qed.
*)

Fixpoint aeval_fun (a : AExp) (sigma : State):=
  match a with
  | anum n => n
  | avar v => sigma v
  | a1 +' a2 => (aeval_fun a1 sigma) +
                (aeval_fun a2 sigma)
  | a1 *' a2 => (aeval_fun a1 sigma) *
                (aeval_fun a2 sigma)
  | a1 -' a2 => (aeval_fun a1 sigma) -
               (aeval_fun a2 sigma)
  | a1 /' a2 => (aeval_fun a1 sigma) /
                 (aeval_fun a2 sigma)
  | a1 %' a2=> (aeval_fun a1 sigma) mod
                (aeval_fun a2 sigma)
  end.

Compute (aeval_fun (2 +' 3)).
Compute (aeval_fun (12/'10)).
Example e3 :
  2 +' (4 *' 3) /' 3 =[ sigma1 ]=> 6.
Proof.
  eapply aadd.
    -apply aconst.
    -eapply adivisionRule.
      +eapply atimes.
        *apply aconst.
        *apply aconst.
        * eauto.
     +apply aconst.
      +eauto.
      +eauto.
      -eauto.
Qed.

Example e4:
  2 +' (4 *' x) /' x =[ sigma1 ]=> 6.
 Proof.
 eapply aadd.
  -apply aconst.
  -eapply adivisionRule.
    +eapply atimes.
      *apply aconst.
      *eapply alookup.
      *eauto
    +eauto.
    +intros.
    eapply alookup.

 Qed.

(*
Lemma equiv :
  forall a st,
    a =[ st ]=> (aeval_fun a st).
Proof.
  induction a; intros; simpl.
  - apply aconst.
  - apply alookup.
  - eapply aadd; eauto.
  - eapply atimes; eauto.
Qed.
*)


Require Export D.

(** **** Problem #21 : 3 stars, optional (double_induction)  *)
(** Prove the following principle of induction over two naturals. *)

Theorem double_induction: forall (P : nat -> nat -> Prop),
  P 0 0 ->
  (forall m, P m 0 -> P (S m) 0) ->
  (forall n, P 0 n -> P 0 (S n)) ->
  (forall m n, P m n -> P (S m) (S n)) ->
  forall m n, P m n.
Proof.
  intros. generalize dependent n. induction m. induction n. apply H. apply H1. apply IHn.
  induction n. apply H0. apply IHm.
  apply H2. apply IHm.

Qed.


(* ========================================================================== *]
 SIMPLE PROOFS IN COQ
[* ========================================================================== *)
Require Import Nat List Lia.

(* -------------------------------------------------------------------------- *]
 To specify a property we are trying to prove we use the keyword `Lemma` or
 `Theorem`.

 To start writting the proof we use the keyword `Proof` and end it with the
 `Qed` keyword. This opens up the tactics environment.
[* -------------------------------------------------------------------------- *)

(*
Lemma trivial_things (a : nat) (b : nat) (H0 : a = 1) (H1 : b = 2) :
    a + b = 3.
Proof.
    (* But how do we write proofs??? *)
Qed.
*)

(* -------------------------------------------------------------------------- *]
 The tactics language in which we write proofs has a wide array of tools to
 use. We will focus on the essentials so that we can quickly get to more
 interesting examples.

 `assumption`
    We have a hypothesis that matches what we want to prove

 `reflexivity`
    It holds because `=` is reflexive, and our goal is to prove something along the lines of `x = x`

 `contradiction`
    We have a contradiction in our hypotheses (and from that we are able to
    show anything).
[* -------------------------------------------------------------------------- *)

Lemma assumption_showcase (a : nat) (H0 : a = 1) :
    a = 1.
Proof.
    admit.
Qed.

Lemma reflexivity_showcase (a : nat) :
    a = a.
Proof.
    admit.
Qed.

(* We use a variable `P` for any proposition (like we often do in logic). *)
Lemma contradiction_showcase (P : Prop) (p_holds : P) (p_doesnt_hold : ~P):
    False. (* Can we prove that `False` is true?! *)
Proof.
    admit.
Qed.

(* -------------------------------------------------------------------------- *]
 The above tactics complete proofs. But we also require tactics that transform
 proofs.

 `simpl`
    simplifies the terms in the goal /

 `unfold t`
    substitutes the term `t` with its definition (useful with functions)

 `rewrite H`
    if hypothesis `H` is of form `x = y` it replaces all occurencess of `x`
    with `y`

 NOTE: All of these tactics can also be used as `rewrite H0 in H1`, which uses
       the tactic in a hypothesis instead of our goal.

[* -------------------------------------------------------------------------- *)

Definition double x := x + x.

Lemma calculate_this (x y z : nat) (H0 : x = y + z) (H1 : double z = y):
    x = z + z + z.
Proof.
    admit.
Qed.

(* -------------------------------------------------------------------------- *]
 Since the propositions we are trying to prove are writen in a logic, it is
 necessary to know at least some of the tactics for working with the logic.

 LOGIC IN GOALS

 `split`
    Transforms the goal `A /\ B` into two separate goals for `A` and `B`.

 `left / right`
    Transforms the goal `A \/ B` into `A` (or `B`) as it suffices to prove
    one side of an `or` statement.

 `intros`
    Transforms the goal `A -> B -> C -> ... -> P` into `P` but adds `A`, `B`,
    `C`, ... to the hypotheses.
 `intros name1 name2 ...`
    You can (and often should) name the new hypotheses.

 `revert H`
    The opposite of `intros` where we take a hypothesis `H` and transform the
    goal of `A` back to `H -> A`.

 LOGIC IN HYPOTHESES

 `destruct`
    For `H : A /\ B` it separates the hypotheses into two new hypotheses, one
    for `A` and one for `B`.

    For `H : A \/ B` it splits the proof into two goals. In the first case
    you have the hypothesis for `A` and in the second one for `B`.

 `apply H`
   If you have a `H : A -> B` and need to prove `B`, then by applying the
   implication it suffices to show `A`.

 `apply H0 in H1 as H2`
   For `H0 : A -> B` and `H1 : A` it generates a new hypothesis `H2 : B`.
   The naming part can be dropped in which case `H1 : A` is replaced with
   `H1 : B`.

 Since we now have tactics that also split our goals into multiple goals,
 we can use `+`, '-', or '*' as bullet points to focus each case separately
 (reduces visualclutter).

[* -------------------------------------------------------------------------- *)

Lemma example_for_logic (P Q R : Prop):
    (P \/ R) /\ (P \/ Q) -> ~P -> Q /\ R.
Proof.
    admit.
Qed.

(* -------------------------------------------------------------------------- *]
 For data types we also have some additional tactics.

 `discriminate`
    One of our hypotheses equates something that cannot be equal (more
    specifically equates two values that have different constructors, such
    as `0 = 1` or `nil = 1 :: nil`).

 `inversion`
    For `H : x :: xs = y :: ys` we can use `inversion H` to get `x = y` and
    `xs = ys`. It also does a rewrite of the equalities in the goal.

 `induction x`
    This tactic makes a case split on all possible ways to construct a value
    of type `x` and automatically generates induction hypotheses.
[* -------------------------------------------------------------------------- *)

Lemma discriminate_showcase (nonsense : 0 = 1):
    False.
Proof.
    admit.
Qed.

Lemma inversion_showcase A (x y : A) (xs ys : list A) :
    (x :: xs = y :: ys) -> xs = ys.
Proof.
    admit.
Qed.

Fixpoint length {A : Type} (lst : list A) :=
    match lst with
    | nil => 0
    | x :: xs => 1 + length xs
    end.

Lemma zero_length A (lst : list A) :
    length lst = 0 -> lst = nil.
Proof.
    admit.
Qed.

(* -------------------------------------------------------------------------- *]
 It is good to see the basic tactics (as we sometimes need them), but to keep
 proofs short Coq provides tactics that help us automate the process.

 `auto`
    Tries to automatically complete the proof. If it cannot it simply leaves
    everything as is.

 `lia` (in older versions `omega`)
    Solver for numeric proofs. A true lifesaver (see example bellow).

 There are plent other usefull ways to help write shorter proofs, but we will
 stick to the basics.

 Do not forget you can use `_` to ask Coq to infer things for you.
[* -------------------------------------------------------------------------- *)

Fixpoint sum_nats n :=
    match n with
    | 0 => 0
    | S m => n + sum_nats m
    end.

(* We multiply since division is not properly defined on naturals. *)
(* You do not want to write this proof by hand... *)
Lemma sum_of_naturals n:
    2 * (sum_nats n) = n * (1 + n).
Proof.
    admit.
Qed.

(* -------------------------------------------------------------------------- *]
 PRACTICE: Show that if `P \/ Q -> R` and `P` hold, we can show that `R` holds.
 Do it without `auto`.
[* -------------------------------------------------------------------------- *)


Fixpoint plus' (n m : nat) : nat :=
  match n with
  | O => m
  | S n' => S (plus' n' m)
  end.
Compute plus' 3 2.     (* 5 *)
Compute plus' 123 2.   (* 125 *)

Fixpoint mult' (n m : nat) : nat :=
  match n with
  | O => O
  | S n' => m + (mult' n' m)
  end.
Compute mult' 3 2.     (* 6 *)
Compute mult' 12 3.    (* 36 *)

Fixpoint minus' (n m : nat) : nat :=
  match n, m with
  | O, _ => O    (* No negative numbers *)
  | _, O => n
  | S n', S m' => minus' n' m'
  end.
Compute minus' 3 2.    (* 1 *)
Compute minus' 23 12.  (* 11 *)
Compute minus' 1 2.    (* 0 because negative numbers not handled *)

Check plus.
Check Nat.add.
Check Nat.div.
Print Nat.div.
(*
#+BEGIN_OUTPUT (Info)
Nat.div =
fun x y : nat =>
match y with
| 0 => y
| S y' => fst (Nat.divmod x y' 0 y')
end
     : nat -> nat -> nat

Arguments Nat.div (_ _)%nat_scope
#+END_OUTPUT (Info) *)
Print Nat.divmod.
(*
#+BEGIN_OUTPUT (Info)
Nat.divmod =
fix divmod (x y q u : nat) {struct x} : nat * nat :=
  match x with
  | 0 => (q, u)
  | S x' =>
      match u with
      | 0 => divmod x' y (S q) y
      | S u' => divmod x' y q u'
      end
  end
     : nat -> nat -> nat -> nat -> nat * nat

Arguments Nat.divmod (_ _ _ _)%nat_scope
#+END_OUTPUT (Info) *)
Print Nat.sub.

Fixpoint div' (n m : nat) : nat :=
  match n, m with
  | O, _ => O
  | _, O => O
  | _, _ => S (div' (minus n m) m)
  end.


Require Export D.

(** **** Exercise: 2 stars (dist_exists_or)  *)
(** Prove that existential quantification distributes over
    disjunction. *)

Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop),
  (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
  intros. split.
  Case "->". intros. destruct H as [x H]. inversion H.
    SCase "P x". left. exists x. assumption.
    SCase "Q x". right. exists x. assumption.
  Case "<-". intros. destruct H.
    SCase "P x". destruct H as [x]. exists x. left. assumption.
    SCase "Q x". destruct H as [x]. exists x. right. assumption.
Qed.


Inductive bool : Type := true : bool | false : bool.

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

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

Eval compute in (fun x:bool => negb (andb false x)).

Eval compute in (fun x:bool => negb (andb x false)).

Parameter T1 T2 : Type.
Parameter t1:T1.
Parameter t2:T2.

Definition g (b:bool) :=
match b return if b then T1 else T2 with
| true => t1
| false => t2 end.

Definition g2 (b:bool) :=
match negb b as b2 return if b2 then T2 else T1 with
| true => t2
| false => t1 end.

Locate and.

Inductive even : nat -> Prop :=
| even0 : even 0
| evenS n : even n -> even (S (S n)).

Lemma even_is_double : forall n, even n -> exists m, n=m+m.
Proof.
	induction 1.
	exists 0.
	reflexivity.
	destruct IHeven as (m, H0).
	exists (S m).
	rewrite H0.
	unfold plus.
	auto.
Qed.

Lemma even_is_double' n :
(even n -> exists m, n=m+m) /\
(even (S n) -> exists m, S n=m+m).
Proof.

 	induction n; simpl;split;intros.
	split.
	intros.
	exists 0.

	reflexivity.
	intro.
	inversion H.

	destruct IHn.
	split.
	destruct H0.
	inversion_clear H.


(* week_39b_arithmetic_expressions.v *)
(* dIFP 2014-2015, Q1, Week 38 *)
(* Olivier Danvy <danvy@cs.au.dk> *)

(* Working version, make sure to download
   the updated version after class.
*)

(* ********** *)

Require Import Arith Bool List unfold_tactic.

(* ********** *)

(* Source syntax: *)

Inductive arithmetic_expression : Type :=
  | Lit : nat -> arithmetic_expression
  | Plus : arithmetic_expression -> arithmetic_expression -> arithmetic_expression
  | Times : arithmetic_expression -> arithmetic_expression -> arithmetic_expression.

(* Exercise 0:
   Write samples of arithmetic expressions.
*)

Definition arth_0 :=
  Lit 5.

Definition arth_1 :=
  Plus (Lit 4) (Lit 2).

Definition arth_2 :=
  Plus (Times (Lit 4) (Lit 9)) (Lit 2).

(* ********** *)

Definition specification_of_interpret (interpret : arithmetic_expression -> nat) :=
  (forall n : nat,
     interpret (Lit n) = n)
  /\
  (forall ae1 ae2 : arithmetic_expression,
     interpret (Plus ae1 ae2) = (interpret ae1) + (interpret ae2))
  /\
  (forall ae1 ae2 : arithmetic_expression,
     interpret (Times ae1 ae2) = (interpret ae1) * (interpret ae2)).

(* Exercise 1:
   Write unit tests.
*)

Notation "A =n= B" := (beq_nat A B) (at level 70, right associativity).

Definition unit_test_for_arithmetic_expression (interpret : arithmetic_expression -> nat) :=
  (interpret arth_0 =n= 5)
  &&
  (interpret arth_1 =n= 6)
  &&
  (interpret arth_2 =n= 38)
  .

(* Exercise 2:
   Define an interpreter as a function
   that satisfies the specification above
   and verify that it passes the unit tests.
*)

Fixpoint interpret_arithmetic (exp : arithmetic_expression) : nat :=
  match exp with
    | Lit n => n
    | Plus a b => interpret_arithmetic a + interpret_arithmetic b
    | Times a b => interpret_arithmetic a * interpret_arithmetic b
  end.

Compute unit_test_for_arithmetic_expression interpret_arithmetic.

(* Byte-code instructions: *)

Inductive byte_code_instruction : Type :=
  | PUSH : nat -> byte_code_instruction
  | ADD : byte_code_instruction
  | MUL : byte_code_instruction.

(* ********** *)

(* Byte-code programs: *)

Definition byte_code_program := list byte_code_instruction.

(* Data stack: *)

Definition data_stack := list nat.

(* ********** *)

(* Exercise 3:
   specify a function
     execute_byte_code_instruction : instr -> data_stack -> data_stack
   that executes a byte-code instruction, given a data stack
   and returns this stack after the instruction is executed.

   * Executing (PUSH n) given s has the effect of pushing n on s.

   * Executing ADD given s has the effect of popping two numbers
     from s and then pushing the result of adding them.

   * Executing MUL given s has the effect of popping two numbers
     from s and then pushing the result of multiplying them.

   For now, if the stack underflows, just assume it contains zeroes.
 *)

Fixpoint f_on_stack (f : nat -> nat -> nat) (l : data_stack) :=
  match l with
    | nil => 0 :: nil
    | a :: y =>
      match y with
        | nil => (f a 0) :: nil
        | b :: x => (f a b) :: x
      end
  end.

Lemma unfold_f_on_stack_zero :
  (forall f : nat -> nat -> nat,
  f_on_stack f nil = 0 :: nil).
Proof.
  unfold_tactic f_on_stack.
Qed.

Lemma unfold_f_on_stack_one :
  (forall (f : nat -> nat -> nat) (n : nat),
  f_on_stack f (n :: nil) = (f n 0) :: nil).
Proof.
  unfold_tactic f_on_stack.
Qed.

Lemma unfold_f_on_stack_two :
  (forall (f : nat -> nat -> nat) (x y : nat) (xy : list nat),
  f_on_stack f (x :: y :: xy) = (f x y) :: xy).
Proof.
  unfold_tactic f_on_stack.
Qed.

Definition specification_of_execute_byte_code_instruction
           (instr : byte_code_instruction -> data_stack -> data_stack) :=
  (forall (n : nat) (s : data_stack),
     instr (PUSH n) s = n :: s)
  /\
  (forall (s : data_stack),
     instr ADD s = (f_on_stack plus s))
  /\
  (forall (s : data_stack),
     instr MUL s = (f_on_stack mult s))
.

Fixpoint execute_byte_code_instruction (inst : byte_code_instruction) (s : data_stack): data_stack :=
    match inst with
      | PUSH n => n :: s
      | ADD => f_on_stack plus s
      | MUL => f_on_stack mult s
  end.

Lemma unfold_execute_byte_code_instruction_push :
  forall (n : nat) (s : data_stack),
    execute_byte_code_instruction (PUSH n) s = n :: s.
Proof.
  unfold_tactic execute_byte_code_instruction.
Qed.

Lemma unfold_execute_byte_code_instruction_add :
  forall (s : data_stack),
    execute_byte_code_instruction ADD s = f_on_stack plus s.
Proof.
  unfold_tactic execute_byte_code_instruction.
Qed.

Lemma unfold_execute_byte_code_instruction_mul :
  forall (s : data_stack),
    execute_byte_code_instruction MUL s = f_on_stack mult s.
Proof.
  unfold_tactic execute_byte_code_instruction.
Qed.

Proposition execute_byte_code_instruction_fits_the_specification_of_execute_byte_code_instruction :
  specification_of_execute_byte_code_instruction execute_byte_code_instruction.
Proof.
  unfold specification_of_execute_byte_code_instruction.
  unfold execute_byte_code_instruction.
  split.

  intros n s.
  reflexivity.

  split.
  intro s.
  reflexivity.

  intro s.
  reflexivity.
Qed.

(* ********** *)

(* Exercise 4:
   Define a function
     execute_byte_code_program : byte_code_program -> data_stack -> data_stack
   that executes a given byte-code program on a given data stack,
   and returns this stack after the program is executed.
*)

Fixpoint execute_byte_code_program (prog : byte_code_program) (s : data_stack): data_stack :=
  match prog with
    | nil => s
    | x :: y => (execute_byte_code_program y (execute_byte_code_instruction x s))
  end.

Lemma unfold_execute_byte_code_program_bc :
  forall (s : data_stack),
    (execute_byte_code_program nil s) = s.
Proof.
  unfold_tactic execute_byte_code_program.
Qed.

Lemma unfold_execute_byte_code_program_ic :
  forall (x : byte_code_instruction) (xs : byte_code_program) (s : data_stack),
    (execute_byte_code_program (x :: xs) s) = (execute_byte_code_program xs (execute_byte_code_instruction x s)).
Proof.
  unfold_tactic execute_byte_code_program.
Qed.

(* ********** *)

(* Exercise 5:
   Prove that for all programs p1, p2 and data stacks s,
   executing (p1 ++ p2) with s
   gives the same result as
   (1) executing p1 with s, and then
   (2) executing p2 with the resulting stack.
*)

Lemma unfold_append_bc :
  forall (bcis : list byte_code_instruction),
    nil ++ bcis = bcis.
Proof.
  apply app_nil_l.
Qed.

Lemma unfold_append_ic :
  forall (bci1 : byte_code_instruction) (bci1s' bci2s : list byte_code_instruction),
    (bci1 :: bci1s') ++ bci2s = bci1 :: (bci1s' ++ bci2s).
Proof.
  intros bci1 bci1s' bci2s.
  symmetry.
  apply app_comm_cons.
Qed.

Theorem append_before_execute_yields_same_result :
  (forall (p1 p2 : byte_code_program) (s : data_stack),
     (execute_byte_code_program (p1 ++ p2) s) =
     (execute_byte_code_program p2 (execute_byte_code_program p1 s))).
Proof.
  intro p1.
  induction p1 as [| x xs IHx].
    intros p2 s.
    rewrite -> unfold_execute_byte_code_program_bc.
    rewrite -> app_nil_l.
    reflexivity.
  intros p2 s.
  rewrite -> unfold_append_ic.
  rewrite -> (unfold_execute_byte_code_program_ic x (xs ++ p2) s).
  rewrite -> IHx.
  rewrite -> unfold_execute_byte_code_program_ic.
  reflexivity.
Qed.

(* ********** *)

Definition specification_of_compile (compile : arithmetic_expression -> byte_code_program) :=
  (forall n : nat,
     compile (Lit n) = PUSH n :: nil)
  /\
  (forall ae1 ae2 : arithmetic_expression,
     compile (Plus ae1 ae2) = (compile ae1) ++ (compile ae2) ++ (ADD :: nil))
  /\
  (forall ae1 ae2 : arithmetic_expression,
     compile (Times ae1 ae2) = (compile ae1) ++ (compile ae2)++ (MUL :: nil)).

(* Exercise 6:
   Define a compiler as a function
   that satisfies the specification above
   and uses list concatenation, i.e., ++.
*)

Fixpoint compile_expression_v0 (exp : arithmetic_expression) : byte_code_program :=
  match exp with
  | Lit n => PUSH n :: nil
  | Plus ae1 ae2 => compile_expression_v0 ae1 ++ compile_expression_v0 ae2 ++ ADD :: nil
  | Times ae1 ae2 => compile_expression_v0 ae1 ++ compile_expression_v0 ae2 ++ MUL :: nil
  end.

Lemma unfold_compile_expression_lit :
  forall n : nat,
    compile_expression_v0 (Lit n) = PUSH n :: nil.
Proof.
  unfold_tactic compile_expression_v0.
Qed.

Lemma unfold_compile_expression_plus :
  forall ae1 ae2 : arithmetic_expression,
    compile_expression_v0 (Plus ae1 ae2) = compile_expression_v0 ae1 ++ compile_expression_v0 ae2 ++ ADD :: nil.
Proof.
  unfold_tactic compile_expression_v0.
Qed.

Lemma unfold_compile_expression_times :
  forall ae1 ae2 : arithmetic_expression,
    compile_expression_v0 (Times ae1 ae2) = compile_expression_v0 ae1 ++ compile_expression_v0 ae2 ++ MUL :: nil.
Proof.
  unfold_tactic compile_expression_v0.
Qed.

Proposition compile_expression_v0_fits_the_specification_of_compile :
  specification_of_compile compile_expression_v0.
Proof.
  unfold specification_of_compile.
  split.
    exact unfold_compile_expression_lit.
  split.
    exact unfold_compile_expression_plus.
  exact unfold_compile_expression_times.
Qed.

(* Exercise 7:
   Write a compiler as a function with an accumulator
   that does not use ++ but :: instead,
   and prove it equivalent to the compiler of Exercise 6.
*)

Fixpoint compile_expression_acc (exp : arithmetic_expression) (prog : byte_code_program) : byte_code_program :=
  match exp with
  | Lit n => PUSH n :: prog
  | Plus ae1 ae2 => (compile_expression_acc ae1 (compile_expression_acc ae2 (ADD :: prog)))
  | Times ae1 ae2 => (compile_expression_acc ae1 (compile_expression_acc ae2 (MUL :: prog)))
  end.

Lemma unfold_compile_expression_acc_lit :
  forall (n : nat) (prog : byte_code_program),
    compile_expression_acc (Lit n) prog = PUSH n :: prog.
Proof.
  unfold_tactic compile_expression_acc.
Qed.

Lemma unfold_compile_expression_acc_plus :
  forall (ae1 ae2 : arithmetic_expression) (prog : byte_code_program),
    compile_expression_acc (Plus ae1 ae2) prog = (compile_expression_acc ae1 (compile_expression_acc ae2 (ADD :: prog))).
Proof.
  unfold_tactic compile_expression_acc.
Qed.

Lemma unfold_compile_expression_acc_times :
  forall (ae1 ae2 : arithmetic_expression) (prog : byte_code_program),
    compile_expression_acc (Times ae1 ae2) prog = (compile_expression_acc ae1 (compile_expression_acc ae2 (MUL :: prog))).
Proof.
  unfold_tactic compile_expression_acc.
Qed.

Definition compile_expression_v1 (exp : arithmetic_expression) : byte_code_program :=
  compile_expression_acc exp nil.

Lemma about_compile_expression_acc :
  forall (exp : arithmetic_expression) (prog : byte_code_program),
    compile_expression_acc exp prog = compile_expression_acc exp nil ++ prog.
Proof.
  intros exp.
  induction exp as [ | exp1' IHexp1' exp2' IHexp2' | exp1'' IHexp1'' exp2'' IHexp2'' ].
      intro prog.
      rewrite ->2 unfold_compile_expression_acc_lit.
      rewrite -> unfold_append_ic.
      rewrite -> app_nil_l.
      reflexivity.
    intro prog.
    rewrite ->2 unfold_compile_expression_acc_plus.
    rewrite -> IHexp1'.
    rewrite -> IHexp2'.
    rewrite -> (IHexp1' (compile_expression_acc exp2' (ADD :: nil))).
    rewrite -> (IHexp2' (ADD :: nil)).
    rewrite -> app_assoc_reverse.
    rewrite -> app_assoc_reverse.
    rewrite -> unfold_append_ic.
    rewrite -> app_nil_l.
    reflexivity.
  intro prog.
  rewrite ->2 unfold_compile_expression_acc_times.
  rewrite -> IHexp1''.
  rewrite -> IHexp2''.
  rewrite -> (IHexp1'' (compile_expression_acc exp2'' (MUL :: nil))).
  rewrite -> (IHexp2'' (MUL :: nil)).
  rewrite -> app_assoc_reverse.
  rewrite -> app_assoc_reverse.
  rewrite -> unfold_append_ic.
  rewrite -> app_nil_l.
  reflexivity.
Qed.

Proposition compile_expression_v1_fits_the_specification_of_compile :
  specification_of_compile compile_expression_v1.
Proof.
  unfold specification_of_compile.
  split.
    intro n.
    unfold compile_expression_v1.
    rewrite -> unfold_compile_expression_acc_lit.
    reflexivity.
  split.
    intros ae1 ae2.
    unfold compile_expression_v1.
    rewrite -> unfold_compile_expression_acc_plus.
    rewrite -> about_compile_expression_acc.
    rewrite -> (about_compile_expression_acc ae2 (ADD :: nil)).
    reflexivity.
  intros ae1 ae2.
  unfold compile_expression_v1.
  rewrite -> unfold_compile_expression_acc_times.
  rewrite -> about_compile_expression_acc.
  rewrite -> (about_compile_expression_acc ae2 (MUL :: nil)).
  reflexivity.
Qed.

Theorem there_is_only_one_compile_expression :
  forall (compiler1 compiler2 : arithmetic_expression -> byte_code_program),
    specification_of_compile compiler1 ->
    specification_of_compile compiler2 ->
    forall (exp : arithmetic_expression),
      compiler1 exp = compiler2 exp.
Proof.
  intros compiler1 compiler2.
  unfold specification_of_compile.
  intros [H_c1_lit [H_c1_plus H_c1_times]].
  intros [H_c2_lit [H_c2_plus H_c2_times]].
  intro exp.
  induction exp as [ | exp1' IHexp1' exp2' IHexp2' | exp1'' IHexp1'' exp2'' IHexp2'' ].
      rewrite -> H_c1_lit.
      rewrite -> H_c2_lit.
      reflexivity.
    rewrite -> H_c1_plus.
    rewrite -> H_c2_plus.
    rewrite -> IHexp1'.
    rewrite -> IHexp2'.
    reflexivity.
  rewrite -> H_c1_times.
  rewrite -> H_c2_times.
  rewrite -> IHexp1''.
  rewrite -> IHexp2''.
  reflexivity.
Qed.

(* ********** *)

(* Exercise 8:
   Prove that interpreting an arithmetic expression gives the same result
   as first compiling it and then executing the compiled program
   over an empty data stack.
*)

Definition run (prog : byte_code_program) : nat :=
  match execute_byte_code_program prog nil with
  | nil => 0
  | result :: _ => result
  end.

Lemma unfold_interpret_lit :
  forall n : nat,
    interpret_arithmetic (Lit n) = n.
Proof.
  unfold_tactic interpret_arithmetic.
Qed.

Lemma unfold_interpret_plus :
  forall a b : arithmetic_expression,
    interpret_arithmetic (Plus a b) = interpret_arithmetic a + interpret_arithmetic b.
Proof.
  unfold_tactic interpret_arithmetic.
Qed.

Lemma unfold_interpret_times :
  forall a b : arithmetic_expression,
    interpret_arithmetic (Times a b) = interpret_arithmetic a * interpret_arithmetic b.
Proof.
  unfold_tactic interpret_arithmetic.
Qed.

Lemma interpret_cons_datastack_eq_compile_execute :
  forall (exp : arithmetic_expression) (ds : data_stack),
    interpret_arithmetic exp :: ds = execute_byte_code_program (compile_expression_v0 exp) ds.
Proof.
  intro exp.
  induction exp as [ n | exp1' IHexp1' exp2' IHexp2' | exp1'' IHexp1'' exp2'' IHexp2''].
      intro ds.
      rewrite -> unfold_interpret_lit.
      rewrite -> unfold_compile_expression_lit.
      rewrite -> unfold_execute_byte_code_program_ic.
      rewrite -> unfold_execute_byte_code_instruction_push.
      rewrite -> unfold_execute_byte_code_program_bc.
      reflexivity.
    intro ds.
    rewrite -> unfold_interpret_plus.
    rewrite -> unfold_compile_expression_plus.
    rewrite ->2 append_before_execute_yields_same_result.
    rewrite -> unfold_execute_byte_code_program_ic.
    rewrite -> unfold_execute_byte_code_instruction_add.
    rewrite -> unfold_execute_byte_code_program_bc.
    rewrite <- IHexp1'.
    rewrite <- IHexp2'.
    rewrite -> unfold_f_on_stack_two.
    rewrite -> plus_comm.
    reflexivity.
  intro ds.
  rewrite -> unfold_interpret_times.
  rewrite -> unfold_compile_expression_times.
  rewrite ->2 append_before_execute_yields_same_result.
  rewrite -> unfold_execute_byte_code_program_ic.
  rewrite -> unfold_execute_byte_code_instruction_mul.
  rewrite -> unfold_execute_byte_code_program_bc.
  rewrite <- IHexp1''.
  rewrite <- IHexp2''.
  rewrite -> unfold_f_on_stack_two.
  rewrite -> mult_comm.
  reflexivity.
Qed.

Theorem interpret_exp_eq_run_compile_exp :
  forall (exp : arithmetic_expression),
    interpret_arithmetic exp = run (compile_expression_v0 exp).
Proof.
  intro exp.
  unfold run.
  rewrite <- interpret_cons_datastack_eq_compile_execute.
  reflexivity.
Qed.

(* ********** *)

(* Exercise 9:
   Write a Magritte-style execution function for a byte-code program
   that does not operate on natural numbers but on syntactic representations
   of natural numbers:

   Definition data_stack := list arithmetic_expression.

   * Executing (PUSH n) given s has the effect of pushing (Lit n) on s.

   * Executing ADD given s has the effect of popping two arithmetic
     expressions from s and then pushing the syntactic representation of
     their addition.

   * Executing MUL given s has the effect of popping two arithmetic
     expressions from s and then pushing the syntactic representation of
     their multiplication.

   Again, for this week's exercise,
   assume there are enough arithmetic expressions on the data stack.
   If that is not the case, just pad it up with syntactic representations
   of zero.

*)

Definition data_stack2 := list arithmetic_expression.

Fixpoint magritte_v0 (prog : byte_code_program) (s : data_stack2) :=
  match prog with
  | nil => s
  | (PUSH n) :: prog' => magritte_v0 prog' ((Lit n) :: s)
  | ADD :: prog' =>
      match s with
      | nil => magritte_v0 prog' ((Plus (Lit 0) (Lit 0)) :: nil)
      | exp :: nil => magritte_v0 prog' ((Plus (Lit 0) exp) :: nil)
      | exp1 :: exp2 :: exps => magritte_v0 prog' ((Plus exp2 exp1) :: exps)
      end
  | MUL :: prog' =>
      match s with
      | nil => magritte_v0 prog' ((Times (Lit 0) (Lit 0)) :: nil)
      | exp :: nil => magritte_v0 prog' ((Times (Lit 0) exp) :: nil)
      | exp1 :: exp2 :: exps => magritte_v0 prog' ((Times exp2 exp1) :: exps)
      end
  end.

Lemma unfold_magritte_v0_nil_prog :
  forall (s : data_stack2),
    magritte_v0 nil s = s.
Proof.
  unfold_tactic magritte_v0.
Qed.

Lemma unfold_magritte_v0_push :
  forall (n : nat) (prog' : byte_code_program) (s : data_stack2),
    magritte_v0 ((PUSH n) :: prog') s = magritte_v0 prog' ((Lit n) :: s).
Proof.
  unfold_tactic magritte_v0.
Qed.

Lemma unfold_magritte_v0_add_nil :
  forall (prog' : byte_code_program) (s : data_stack2),
    magritte_v0 (ADD :: prog') nil = magritte_v0 prog' ((Plus (Lit 0) (Lit 0)) :: nil).
Proof.
  unfold_tactic magritte_v0.
Qed.

Lemma unfold_magritte_v0_add_1 :
  forall (prog' : byte_code_program) (exp : arithmetic_expression) (s : data_stack2),
    magritte_v0 (ADD :: prog') (exp :: nil) = magritte_v0 prog' ((Plus (Lit 0) exp) :: nil).
Proof.
  unfold_tactic magritte_v0.
Qed.

Lemma unfold_magritte_v0_add_2 :
  forall (prog' : byte_code_program) (exp1 exp2 : arithmetic_expression) (s : data_stack2),
    magritte_v0 (ADD :: prog') (exp1 :: exp2 :: s) = magritte_v0 prog' ((Plus exp2 exp1) :: s).
Proof.
  unfold_tactic magritte_v0.
Qed.

Lemma unfold_magritte_v0_mul_nil :
  forall (prog' : byte_code_program) (s : data_stack2),
    magritte_v0 (MUL :: prog') nil = magritte_v0 prog' ((Times (Lit 0) (Lit 0)) :: nil).
Proof.
  unfold_tactic magritte_v0.
Qed.

Lemma unfold_magritte_v0_mul_1 :
  forall (prog' : byte_code_program) (exp : arithmetic_expression) (s : data_stack2),
    magritte_v0 (MUL :: prog') (exp :: nil) = magritte_v0 prog' ((Times (Lit 0) exp) :: nil).
Proof.
  unfold_tactic magritte_v0.
Qed.

Lemma unfold_magritte_v0_mul_2 :
  forall (prog' : byte_code_program) (exp1 exp2 : arithmetic_expression) (s : data_stack2),
    magritte_v0 (MUL :: prog') (exp1 :: exp2 :: s) = magritte_v0 prog' ((Times exp2 exp1) :: s).
Proof.
  unfold_tactic magritte_v0.
Qed.

Definition run_magritte (prog : byte_code_program) : arithmetic_expression :=
  match (magritte_v0 prog nil) with
  | nil => Lit 0
  | exp :: _ => exp
  end.

Compute arth_2.
Compute compile_expression_v0 arth_2.
Compute run_magritte (compile_expression_v0 arth_2).

(* Exercise 10:
   Prove that the Magrite-style execution function from Exercise 9
   implements a decompiler that is the left inverse of the compiler
   of Exercise 6.
*)

Lemma append_before_magritte_yields_same_result :
  forall (p1 p2 : byte_code_program) (s : data_stack2),
       magritte_v0 (p1 ++ p2) s =
       magritte_v0 p2 (magritte_v0 p1 s).
Proof.
  intro p1.
  induction p1 as [ | x xs' IHxs'].
    intros p2 s.
    rewrite -> unfold_magritte_v0_nil_prog.
    rewrite -> app_nil_l.
    reflexivity.
  intros p2 s.
  Check unfold_append_ic.
  rewrite -> unfold_append_ic.
  induction x.
      rewrite ->2 unfold_magritte_v0_push.
      rewrite -> IHxs'.
      reflexivity.
    induction s.
    rewrite ->2 unfold_magritte_v0_add_nil.
    rewrite ->2 unfold_magritte_v0_add_1.

Lemma exp_cons_exps_eq_magritte_compile_exp :
  forall (exp : arithmetic_expression) (s : data_stack2),
    exp :: s = magritte_v0 (compile_expression_v0 exp) s.
Proof.
  intro exp.
  induction exp as [ | exp1' IHexp1' exp2' IHexp2' | exp1'' IHexp1'' exp2'' IHexp2''].
      intro s.
      rewrite -> unfold_compile_expression_lit.
      rewrite -> unfold_magritte_v0_push.
      rewrite -> unfold_magritte_v0_nil_prog.
      reflexivity.
    intro s.
    rewrite -> unfold_compile_expression_plus.
    rewrite ->2 append_before_magritte_yields_same_result.
    rewrite <- IHexp1'.
    rewrite <- IHexp2'.
    rewrite -> unfold_magritte_v0_add_2.
    rewrite -> unfold_magritte_v0_nil_prog.
    reflexivity.
  intro s.
  rewrite -> unfold_compile_expression_times.
  rewrite ->2 append_before_magritte_yields_same_result.
  rewrite <- IHexp1''.
  rewrite <- IHexp2''.
  rewrite -> unfold_magritte_v0_mul_2.
  rewrite -> unfold_magritte_v0_nil_prog.
  reflexivity.
Qed.

Theorem compile_exp_and_run_magritte_gives_exp :
  forall exp : arithmetic_expression,
    exp = run_magritte (compile_expression_v0 exp).
Proof.
  intro exp.
  unfold run_magritte.
  rewrite <- exp_cons_exps_eq_magritte_compile_exp.
  reflexivity.
Qed.

(* ********** *)

(* end of week_39b_arithmetic_expressions.v *)


(* The set of the group. *)
Parameter G : Set.

(* The binary operator. *)
Parameter f : G -> G -> G.

(* The group identity. *)
Parameter e : G.

(* The inverse operator. *)
Parameter i : G -> G.

(* For readability, we use infix <+> to stand for the binary operator. *)
Infix "<+>" := f (at level 50, left associativity).

(* The operator [f] is associative. *)
Axiom assoc : forall a b c, a <+> b <+> c = a <+> (b <+> c).

(* [e] is the right-identity for all elements [a] *)
Axiom id_r : forall a, a <+> e = a.

(* [i a] is the right-inverse of [a]. *)
Axiom inv_r : forall a, a <+> i a = e.

Lemma mult_both :
  forall a b c d1 d2,
    a <+> c = d1
    -> b <+> c = d2
    -> a = b
    -> d1 = d2.
Proof.
  intros.
  subst.
  reflexivity.
Qed.

Hint Extern 100 (_ = _) =>
match goal with
  | [ _ : True |- _ ] => fail 1
  | _ => assert True by constructor; eapply mult_both
end.

(* The identity [e] is unique. *)
Theorem unique_id : forall a, a <+> a = a -> a = e.
Proof.
  intros.
  pose proof mult_both a (a <+> a) (i a) e a (inv_r a) as m.
  symmetry.
  apply m.
  rewrite assoc.
  rewrite inv_r.
  rewrite id_r.
  reflexivity.
  symmetry.
  assumption.
Qed.
Hint Resolve unique_id.

(* [i a] is the left-inverse of [a]. *)
Theorem inv_l : forall a, i a <+> a = e.
Proof.
  intros.
  pose proof mult_both (i a <+> a) e e (i a <+> a) e as m.
  apply m.
  rewrite assoc.
  rewrite id_r.
  reflexivity.
  rewrite id_r.
  reflexivity.

(* [e] is the left-identity. *)
Axiom id_l : forall a, e <+> a = a.

(* [x] can be cancelled on the right. *)
Axiom cancel_r : forall a b x, a <+> x = b <+> x -> a = b.

(* [x] can be cancelled on the left. *)
Axiom cancel_l: forall a b x, x <+> a = x <+> b -> a = b.

(* The left identity is unique. *)
Axiom e_uniq_l : forall a p, p <+> a = a -> p = e.

(* The left inverse is unique. *)
Axiom inv_uniq_l : forall a b, a <+> b = e -> a = i b.

(* The left identity is unique. *)
Axiom e_uniq_r : forall a p, a <+> p = a -> p = e.

(* The right inverse is unique. *)
Axiom inv_uniq_r : forall a b, a <+> b = e -> b = i a.

(* The inverse operator distributes over the group operator. *)
Axiom inv_distr : forall a b, i (a <+> b) = i b <+> i a.

(* The inverse of an inverse produces the original element. *)
Axiom double_inv : forall a, i (i a) = a.

(* The identity is its own inverse. *)
Axiom id_inv : i e = e.