Set Implicit Arguments.

Require Import util.
Require Import List.
Require Import monads.
Require Import sums_and_averages.
Require Import Setoid.
Require ne_tree.
Require arith_lems.
Require Import Rbase.
Require ne_tree_monad.

Open Scope R_scope.

Definition expec (T: Set) (f: T -> nat): ne_tree.T T -> R :=
  TRavg ∘ ne_tree.map (INR ∘ f).
    (* note: currently specialized for discrete measures (hence the nat and INR) *)

Definition expec_sum (T U: Set) (f: U -> nat) (g: T -> ne_tree_monad.M U): list T -> R :=
  Rsum ∘ map (expec f ∘ g).

Section expec_ctors.

  Variables (T: Set) (f: T -> nat).

  Lemma expec_Leaf t: expec f (ne_tree.Leaf t) = INR (f t).
  Proof. auto. Qed.

  Lemma expec_Node l: expec f (ne_tree.Node l) = Ravg (ne_list.map (@expec _ f) l).
  Proof. unfold expec, compose. intros. simpl. rewrite ne_list.map_map. reflexivity. Qed.

  Lemma expec_Node_one x:
    expec f (ne_tree.Node (ne_list.one x)) = expec f x.
  Proof. unfold expec, compose. simpl. intros. rewrite Ravg_one. reflexivity. Qed.

  Lemma expec_Node_cons x t:
    expec f (ne_tree.Node (ne_list.cons x t)) =
    (expec f x + expec f (ne_tree.Node t) * INR (length t)) * / INR (S (length t)).
  Proof.
    intros.
    rewrite expec_Node.
    simpl ne_list.map.
    simpl Ravg.
    rewrite Ravg_cons.
    rewrite expec_Node.
    rewrite ne_list.map_length.
    field.
    auto with real.
  Qed.

End expec_ctors.

(* misc expec *)

Add Parametric Morphism (A: Set): (@expec A)
  with signature (@ext_eq A nat) ==> (@ext_eq (ne_tree.T A) R)
  as expec_ext_morph.
Proof. intros. unfold expec. rewrite H. reflexivity. Qed.

Lemma expec_ext (T: Set) (f g: T -> nat) (e: ext_eq f g): forall x, expec f x = expec g x.
Proof. fold (ext_eq (expec f) (expec g)). apply expec_ext_morph. assumption. Qed.

Lemma lin_nat c d: ext_eq
  (TRavg ∘ ne_tree.map (INR ∘ plus d ∘ mult c))
  (Rplus (INR d) ∘ Rmult (INR c) ∘ TRavg ∘ ne_tree.map INR).
Proof.
  intro.
  induction x.
      repeat rewrite comp_apply.
      simpl.
      repeat rewrite comp_apply.
      rewrite plus_INR.
      rewrite mult_INR.
      reflexivity.
    repeat rewrite comp_apply in *.
    simpl.
    rewrite IHx.
    repeat rewrite Ravg_one.
    reflexivity.
  repeat rewrite comp_apply in *.
  simpl.
  rewrite IHx.
  inversion IHx0.
  repeat rewrite ne_list.map_map in *.
  repeat rewrite Ravg_cons.
  rewrite ne_list.map_length.
  rewrite H0.
  rewrite ne_list.map_length.
  rewrite S_INR.
  field.
  auto with real.
Qed.

Lemma Rmult_INR1_id: ext_eq (Rmult (INR 1)) (@id R).
Proof. intro. apply Rmult_1_l. Qed.

Lemma mult_1_id: ext_eq (mult 1) (@id nat).
Proof. intro. apply mult_1_l. Qed.

Lemma expec_plus_c (T: Set) (g: T -> nat) (c: nat):
  ext_eq (expec (plus c ∘ g)) (Rplus (INR c) ∘ expec g).
Proof.
  intros.
  unfold expec.
  rewrite comp_ass.
  rewrite <- ne_tree.map_map_ext.
  rewrite <- (compose_runit (INR ∘ plus c)).
  rewrite <- mult_1_id.
  rewrite comp_ass.
  rewrite lin_nat.
  rewrite <- comp_ass.
  rewrite ne_tree.map_map_ext.
  rewrite Rmult_INR1_id.
  rewrite compose_runit.
  reflexivity.
Qed.

Lemma expec_plus (T: Set) (f g: T -> nat) (t: ne_tree.T T):
  expec (fun x => plus (f x) (g x)) t = expec f t + expec g t.
Proof with auto.
  induction t.
      repeat rewrite expec_Leaf.
      apply plus_INR.
    repeat rewrite expec_Node_one...
  repeat rewrite expec_Node_cons.
  rewrite IHt.
  rewrite IHt0.
  field...
Qed.

Lemma expec_map (T U: Set) (g: T -> U) (f: U -> nat) (t: ne_tree.T T):
  expec f (ne_tree.map g t) = expec (f ∘ g) t.
Proof. intros. unfold expec. repeat rewrite comp_apply. rewrite ne_tree.map_map. reflexivity. Qed.

Lemma expec_nonneg (T: Set) (m: ne_tree_monad.M T) (f: T -> nat): 0 <= expec f m.
Proof with auto with real.
  induction m; intros.
      rewrite expec_Leaf...
    rewrite expec_Node_one...
  rewrite expec_Node_cons.
  apply Rmult_le_pos...
  apply Rplus_le_le_0_compat...
  apply Rmult_le_pos...
Qed.

Hint Resolve expec_nonneg.

Lemma expec_le (X: Set) (f g: X -> nat) (t: ne_tree.T X):
  (forall x, ne_tree.In x t -> (f x <= g x)%nat) -> expec f t <= expec g t.
Proof with auto with real.
  induction t; intros.
      simpl.
      repeat rewrite expec_Leaf...
    repeat rewrite expec_Node_one...
  repeat rewrite expec_Node_cons.
  apply Rmult_le_compat_r...
  apply Rplus_le_compat...
  apply Rmult_le_compat_r...
  apply IHt0.
  intros.
  apply H.
  right.
  inversion_clear H0...
Qed.

Lemma expec_0_inv (T: Set) (f: T -> nat) (t: ne_tree.T T):
  expec f t = 0 -> forall x, ne_tree.In x t -> f x = 0%nat.
Proof with auto with real.
  induction t.
      simpl.
      intros.
      inversion_clear H0.
      apply arith_lems.INR_0_inv...
    simpl.
    rewrite expec_Node_one.
    intros.
    inversion_clear H0.
    inversion_clear H1...
  rewrite expec_Node_cons.
  intros.
  inversion_clear H0.
  destruct (arith_lems.Rmult_0_inv H).
    assert (expec f t = 0).
      apply Rplus_eq_0_l with (expec f (ne_tree.Node l) * INR (length l))...
      apply Rmult_le_pos...
    assert (expec f (ne_tree.Node l) = 0).
      rewrite Rplus_comm in H0.
      cut (expec f (ne_tree.Node l) * INR (length l) = 0).
        intro.
        destruct (arith_lems.Rmult_0_inv H3)...
        cset (arith_lems.INR_0_inv _ H4).
        destruct l; discriminate.
      apply Rplus_eq_0_l with (expec f t)...
      apply Rmult_le_pos...
    inversion_clear H1...
  elimtype False.
  apply (Rinv_neq_0_compat (INR (S (length l))))...
Qed.

Lemma expec_constant (T: Set) (f: T -> nat) (c: nat) (t: ne_tree_monad.M T):
   (forall x, ne_tree.In x t -> f x = c) -> expec f t = INR c.
Proof with auto with real.
  induction t.
      intros.
      rewrite expec_Leaf...
    simpl.
    rewrite expec_Node_one...
  rewrite expec_Node_cons.
  intros.
  rewrite IHt...
  rewrite IHt0.
    rewrite S_INR.
    field...
  intros.
  apply H.
  inversion_clear H0...
Qed.

Section bind_expecs.

  Variables (T U: Set) (f: T -> nat).

  Lemma expec_bind_leaf (g: U -> T) (m: ne_tree_monad.M U):
    expec f (m >>= (ne_tree_monad.ret ∘ g)) = expec (f ∘ g) m.
  Proof with auto.
    induction m...
      simpl in *.
      repeat rewrite expec_Node_one...
    simpl in *.
    repeat rewrite expec_Node_cons.
    rewrite IHm.
    rewrite IHm0.
    repeat rewrite ne_list.map_length...
  Qed.

  Lemma expec_bind_cons (x: ne_tree_monad.M U) t (g: U -> ne_tree_monad.M T):
    expec f (@bind ne_tree_monad.M _ _  (ne_tree.Node (ne_list.cons x t)) g) =
    (expec f (x >>= g) + expec f (@bind ne_tree_monad.M _ _ (ne_tree.Node t) g) * INR (length t)) * / INR (S (length t)).
  Proof.
    intros.
    simpl expec.
    rewrite expec_Node_cons.
    repeat rewrite ne_list.map_length.
    reflexivity.
  Qed.

End bind_expecs.


Section three_3.
  Variables P Q R T : Prop.

  Lemma id_P : P -> P.
  Proof.
    intros p; assumption.
  Qed.

  Lemma id_PP : (P -> P) -> (P -> P).
  Proof.
    intros H; assumption.
  Qed.

  Lemma imp_trans : (P -> Q) -> (Q -> R) -> P -> R.
  Proof.
    intros H H' p; apply H'; apply H; assumption.
  Qed.

  Lemma imp_perm : (P -> Q -> R) -> (Q -> P -> R).
  Proof.
    intros H H' p; apply H; assumption.
  Qed.

  Lemma ignore_Q : (P -> R) -> P -> Q -> R.
  Proof.
    intros H p q; apply H; assumption.
  Qed.

  Lemma delta_imp : (P -> P -> Q) -> P -> Q.
  Proof.
    intros H p; apply H; assumption.
  Qed.

  Lemma delta_impR : (P -> Q) -> (P -> P -> Q).
  Proof.
    intros H p; assumption.
  Qed.

  Lemma diamond : (P -> Q) -> (P -> R) -> (Q -> R -> T) -> P -> T.
  Proof.
    intros H H' H'' p; apply H'';(apply H || apply H'); assumption.
  Qed.

  Lemma weak_peirce : ((((P  -> Q) -> P) -> P) -> Q) -> Q.
  Proof.
    intros H; apply H; intros H'; apply H'; intros p; apply H; intros H''; assumption.
  Qed.


(* ---------------------------------------------------------------------

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of context-free language
   theory in Coq. Specifically, the following results were obtained:

   (i) closure operations for context-free grammars,
   (ii) context-free grammars simplification
   (iii) context-free grammar Chomsky normalization and
   (iv) pumping lemma for context-free languages.

   More information can be found in thesis "Formalization of
   Context-Free Language Theory", submitted to the Informatics
   Center of the Pernambuco Federal University (CIn/UFPE) in
   Brazil.

   The file README.md descbrides the contents of each file and
   provides instructions to compile them.

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

Require Import List.

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

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

Import ListNotations.

(* --------------------------------------------------------------------- *)
(* CLOSURE - DEFINITIONS                                                 *)
(* --------------------------------------------------------------------- *)

Section Closure.

Variables non_terminal terminal: Type.

Inductive g_clo_nt: Type :=
| Start_clo : g_clo_nt
| Transf_clo_nt : non_terminal -> g_clo_nt.

Notation sf:= (list (non_terminal + terminal)).
Notation sfc:= (list (g_clo_nt + terminal)).
Notation nlist:= (list g_clo_nt).
Notation tlist:= (list terminal).
Notation sentence:= (list terminal).

Definition g_clo_sf_lift (c: non_terminal + terminal): g_clo_nt + terminal:=
  match c with
  | inl nt => inl (Transf_clo_nt nt)
  | inr t  => inr t
  end.

Inductive g_clo_rules (g: cfg non_terminal terminal): g_clo_nt -> sfc -> Prop :=
| New1_clo: g_clo_rules g Start_clo ([inl Start_clo] ++ [inl (Transf_clo_nt (start_symbol g))])
| New2_clo: g_clo_rules g Start_clo []
| Lift_clo: forall nt: non_terminal,
            forall s: sf,
            rules g nt s ->
            g_clo_rules g (Transf_clo_nt nt) (map g_clo_sf_lift s).

Lemma g_clo_finite:
forall g: cfg non_terminal terminal,
exists n: nat,
exists ntl: list g_clo_nt,
exists tl: tlist,
In Start_clo ntl /\
forall left: g_clo_nt,
forall right: sfc,
g_clo_rules g left right ->
(length right <= n) /\
(In left ntl) /\
(forall s: g_clo_nt, 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 [n1 [ntl1 [tl1 H1]]].
exists (S (S n1)), (Start_clo :: (map Transf_clo_nt ntl1)), tl1.
split.
- simpl.
  left.
  reflexivity.
- split.
  + inversion H.
    * simpl.
      omega.
    * simpl.
      omega.
    * destruct H1 as [_ H1].
      subst.
      specialize (H1 nt s H0).
      destruct H1 as [H1 _].
      rewrite map_length.
      omega.
  + split.
    * {
      inversion H.
      - simpl.
        left.
        reflexivity.
      - simpl.
        left.
        reflexivity.
      - simpl.
        right.
        destruct H1 as [_ H1].
        specialize (H1 nt s H0).
        destruct H1 as [_ [H5 [_ _]]].
        apply in_split in H5.
        destruct H5 as [l1 [l2 H5]].
        rewrite H5.
        rewrite map_app.
        apply in_or_app.
        right.
        simpl.
        left.
        reflexivity.
      }
    * {
      split.
      - inversion H.
        + subst.
          intros s H4.
          simpl in H4.
          destruct H4 as [H4 | H4].
          * inversion H4.
            simpl.
            left.
            reflexivity.
          * {
            destruct H4 as [H4 | H4].
            - inversion H4.
              simpl.
              right.
              destruct H1 as [H1 _].
              apply in_split in H1.
              destruct H1 as [l1 [l2 H1]].
              rewrite H1.
              rewrite map_app.
              apply in_or_app.
              right.
              simpl.
              left.
              reflexivity.
            - contradiction.
            }
        + subst.
          intros s H4.
          simpl in H4.
          contradiction.
        + subst.
          intros s0 H4.
          destruct H1 as [_ H1].
          specialize (H1 nt s H0).
          destruct H1 as [_ [_ [H5 _]]].
          simpl.
          right.
          destruct s0.
          * apply in_split in H4.
            destruct H4 as [l1 [l2 H4]].
            symmetry in H4.
            apply map_expand in H4.
            destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
            change (inl Start_clo :: l2) with ([inl Start_clo] ++ l2) in H4'''.
            symmetry in H4'''.
            apply map_expand in H4'''.
            destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
            {
            destruct s1'0.
            - inversion H5''.
            - simpl in H5''.
              inversion H5''.
              destruct s0.
              + simpl in H2.
                inversion H2.
              + simpl in H2.
                inversion H2.
            }
          * assert (H6: In (inl n) s).
              {
              apply in_split in H4.
              destruct H4 as [l1 [l2 H4]].
              symmetry in H4.
              apply map_expand in H4.
              destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
              change (inl (Transf_clo_nt n) :: l2) with ([inl (Transf_clo_nt n)] ++ l2) in H4'''.
              symmetry in H4'''.
              apply map_expand in H4'''.
              destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
              destruct s1'0.
              - inversion H5''.
              - inversion H5''.
                destruct s0.
                + simpl in H2.
                  inversion H2.
                  subst.
                  apply in_or_app.
                  right.
                  simpl.
                  left.
                  reflexivity.
                + simpl in H2.
                  inversion H2.
              }
            specialize (H5 n H6).
            apply in_map.
            exact H5.
      - inversion H.
        + subst.
          intros s H4.
          simpl in H4.
          destruct H4 as [H4 | H4].
          * inversion H4.
          * {
            destruct H4 as [H4 | H4].
            - inversion H4.
            - contradiction.
            }
        + subst.
          intros s H4.
          simpl in H4.
          contradiction.
        + subst.
          intros s0 H4.
          destruct H1 as [_ H1].
          specialize (H1 nt s H0).
          destruct H1 as [_ [_ [_ H5]]].
          assert (H6: In (inr s0) s).
            {
            apply in_split in H4.
            destruct H4 as [l1 [l2 H4]].
            symmetry in H4.
            apply map_expand in H4.
            destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
            change (inr s0 :: l2) with ([inr s0] ++ l2) in H4'''.
            symmetry in H4'''.
            apply map_expand in H4'''.
            destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
            destruct s1'0.
            - inversion H5''.
            - simpl in H5''.
              inversion H5''.
              destruct s1.
              + simpl in H2.
                inversion H2.
              + simpl in H2.
                inversion H2.
                subst.
                apply in_or_app.
                right.
                simpl.
                left.
                reflexivity.
            }
          specialize (H5 s0 H6).
          exact H5.
      }
Qed.

Definition g_clo (g: cfg non_terminal terminal): (cfg g_clo_nt terminal):= {|
start_symbol:= Start_clo;
rules:= g_clo_rules g;
rules_finite:= g_clo_finite g
|}.

(* --------------------------------------------------------------------- *)
(* CLOSURE - LEMMAS                                                      *)
(* --------------------------------------------------------------------- *)

Theorem derives_add_clo:
forall g: cfg non_terminal terminal,
forall s1 s2: sf,
derives g s1 s2 -> derives (g_clo g) (map g_clo_sf_lift s1) (map g_clo_sf_lift s2).
Proof.
intros g s1 s2 H.
induction H.
- apply derives_refl.
- rewrite map_app.
  rewrite map_app.
  rewrite map_app in IHderives.
  simpl in IHderives.
  apply derives_step with (g:= g_clo g) (left:= (Transf_clo_nt left)).
  exact IHderives.
  simpl.
  apply Lift_clo.
  exact H0.
Qed.

Theorem g_clo_correct:
forall g: cfg non_terminal terminal,
forall s: sf,
forall s': sfc,
 generates (g_clo g) nil /\
(generates (g_clo g) s' /\ generates g s -> generates (g_clo g) (s'++ map g_clo_sf_lift s)).
Proof.
intros g s s'.
unfold generates.
split.
- simpl.
  rewrite <- app_nil_l.
  rewrite <- app_nil_r.
  rewrite <- app_assoc.
  apply derives_step with (left:= Start_clo).
  + rewrite app_nil_l.
    apply derives_refl.
  + simpl.
    apply New2_clo.
- intros [H1 H2].
  apply derives_trans with (s2:= [inl Start_clo] ++ (map g_clo_sf_lift [inl (start_symbol g)])).
  + simpl.
    apply derives_start.
    simpl.
    apply New1_clo.
  + apply derives_add_clo in H2.
    apply derives_combine with (g:= (g_clo g)).
    split.
    * exact H1.
    * exact H2.
Qed.

Theorem g_clo_correct_inv:
forall g: cfg non_terminal terminal,
forall s: sfc,
generates (g_clo g) s ->
(s=[]) \/
(s=[inl (start_symbol (g_clo g))]) \/
(exists s': sfc,
 exists s'': sf,
 generates (g_clo g) s' /\ generates g s'' /\ s=s' ++ map g_clo_sf_lift s'').
Proof.
unfold generates.
intros g s.
remember ([inl (start_symbol (g_clo g))]) as init.
intro H.
induction H.
- right.
  left.
  reflexivity.
- subst.
  specialize (IHderives eq_refl).
  destruct IHderives.
  + destruct s2.
    * inversion H1.
    * inversion H1.
  + destruct H1.
    * {
      destruct s2.
      - inversion H1.
        subst.
        inversion H0.
        + simpl in *.
          right.
          right.
          exists [inl Start_clo].
          exists [inl (start_symbol g)].
          split.
          apply derives_refl.
          split.
          apply derives_refl.
          simpl.
          reflexivity.
        + left.
          trivial.
      - right.
        right.
        inversion H1.
        destruct s2.
        + inversion H4.
        + inversion H4.
      }
    * destruct H1 as [s' [s'' [H2 [H3 H4]]]].
      {
      inversion H0.
      - (* First case, rule New1_clo *)
        subst. simpl in *.
        assert (IN : In (inl Start_clo) (s' ++ map g_clo_sf_lift s'')).
          {
          simpl in *.
          rewrite <- H4.
          apply in_app_iff.
          right.
          simpl.
          left.
          reflexivity.
          }
        apply in_app_iff in IN.
        destruct IN.
        + (* Start_clo is in s', ok *)
          apply equal_app in H4.
          destruct H4.
          * {
            destruct H4 as [l [H5 H6]].
            destruct l.
            - simpl in H6.
              rewrite cons_app in H6.
              apply map_expand in H6.
              destruct H6 as [s1' [s2' [H7 [H8 H9]]]].
              subst.
              destruct s1'.
              + inversion H8.
              + inversion H8.
                destruct s.
                * inversion H5.
                * inversion H5.
            - right.
              right.
              inversion H6.
              subst.
              exists (s2 ++ inl Start_clo :: inl (Transf_clo_nt (start_symbol g)) :: l).
              exists s''.
              split.
              + apply derives_step with (right:=[inl Start_clo; inl (Transf_clo_nt (start_symbol g))]) in H2.
                * exact H2.
                * exact H0.
              + split.
                * exact H3.
                * rewrite <- app_assoc.
                  simpl.
                  reflexivity.
            }
          * destruct H4 as [l [H5 H6]].
            symmetry in H6.
            apply map_expand in H6.
            destruct H6 as [s1' [s2' [H7 [H8 H9]]]].
            {
            destruct s2'.
            - inversion H9.
            - inversion H9.
              destruct s.
              + inversion H6.
              + inversion H6.
            }
        + (* Start_clo is in s'', contradiction *)
          rewrite in_map_iff in H1.
          destruct H1 as [x [H5 H6]].
          destruct x.
          * inversion H5.
          * inversion H5.
      - (* Second case, rule New2_clo *)
        simpl in *.
        subst.
        assert (IN: In (inl Start_clo) (s' ++ map g_clo_sf_lift s'')).
          {
          simpl in *.
          rewrite <- H4.
          rewrite in_app_iff.
          right.
          simpl.
          left.
          reflexivity.
          }
        apply in_app_iff in IN.
        destruct IN.
        + (* Start_clo is in s', ok *)
          right.
          right.
          apply equal_app in H4.
          destruct H4.
          * destruct H4 as [l [H5 H6]].
            {
            destruct l.
            - simpl in H6.
              rewrite cons_app in H6.
              apply map_expand in H6.
              destruct H6 as [s1' [s2' [H7 [H8 H9]]]].
              destruct s1'.
              + inversion H8.
              + simpl in H8.
                inversion H8.
                destruct s.
                * inversion H6.
                * inversion H6.
            - inversion H6.
              subst.
              exists (s2 ++ l).
              exists s''.
              split.
              + replace (s2 ++ l) with (s2 ++ [] ++ l).
                * {
                  apply derives_step with (left:= Start_clo).
                  - exact H2.
                  - exact H0.
                  }
                * simpl.
                  reflexivity.
              + split.
                * exact H3.
                * rewrite <- app_assoc.
                  reflexivity.
            }
          * destruct H4 as [l [H5 H6]].
            symmetry in H6.
            apply map_expand in H6.
            destruct H6 as [s1' [s2' [H7 [H8 H9]]]].
            {
            destruct s2'.
            - inversion H9.
            - inversion H9.
              destruct s.
              + inversion H6.
              + inversion H6.
            }
        + (* Start_clo is in s'', contradiction *)
          rewrite in_map_iff in H1.
          destruct H1 as [x [H5 H6]].
          destruct x.
          * inversion H5.
          * inversion H5.
      - (* Third case, rule Lift_clo *)
        right.
        right.
        subst.
        apply equal_app in H4.
        destruct H4.
        + destruct H4 as [l [H5 H6]].
          subst.
          destruct l.
          * simpl in H6.
            rewrite cons_app in H6.
            apply map_expand in H6.
            destruct H6 as [s1' [s2' [H7 [H8 H9]]]].
            subst.
            exists s2.
            exists (s ++ s2').
            {
            split.
            - rewrite app_nil_r in H2.
              exact H2.
            - split.
              + destruct s1'.
                * inversion H8.
                * inversion H8.
                  {
                  destruct s0.
                  - inversion H5.
                    subst.
                    apply map_eq_nil in H6.
                    subst.
                    rewrite <- app_nil_l in H3.
                    apply derives_step with (right:=s) in H3.
                    + exact H3.
                    + exact H1.
                  - inversion H5.
                  }
              + rewrite map_app.
                reflexivity.
            }
          * inversion H6.
            subst.
            exists (s2 ++ map g_clo_sf_lift s ++ l).
            exists s''.
            {
            split.
            - apply derives_step with (right:= map g_clo_sf_lift s) in H2.
              + exact H2.
              + exact H0.
            - split.
              + exact H3.
              + repeat rewrite <- app_assoc.
                reflexivity.
            }
        + destruct H4 as [l [H5 H6]].
          subst.
          symmetry in H6.
          apply map_expand in H6.
          destruct H6 as [s1' [s2' [H7 [H8 H9]]]].
          subst.
          rewrite cons_app in H9.
          symmetry in H9.
          apply map_expand in H9.
          destruct H9 as [s1'' [s2'0 [H6 [H7 H8]]]].
          subst.
          exists s'.
          exists (s1' ++ s ++ s2'0).
          split.
          * exact H2.
          * {
            split.
            - destruct s1''.
              + inversion H7.
              + simpl in H7.
                inversion H7.
                destruct s0.
                * inversion H5.
                  subst.
                  apply map_eq_nil in H6.
                  subst.
                  {
                  apply derives_step with (right:= s) in H3.
                  - exact H3.
                  - exact H1.
                  }
                * inversion H5.
            - rewrite <- app_assoc.
              repeat rewrite map_app.
              reflexivity.
            }
      }
Qed.

Lemma map_clo_1:
forall s: sentence,
map (@terminal_lift g_clo_nt terminal) s =
map g_clo_sf_lift (map (@terminal_lift non_terminal terminal) s).
Proof.
induction s.
- simpl.
  reflexivity.
- simpl.
  change (inr a) with (terminal_lift g_clo_nt a).
  rewrite IHs.
  reflexivity.
Qed.

Lemma map_clo_2:
forall s: sentence,
forall l: sf,
map (@terminal_lift g_clo_nt terminal) s = map g_clo_sf_lift l ->
(map (@terminal_lift non_terminal terminal) s) = l.
Proof.
induction s.
- intros l H.
  simpl in H.
  simpl.
  symmetry in H.
  apply map_eq_nil in H.
  symmetry.
  exact H.
- intros l H.
  simpl in H.
  simpl.
  destruct l.
  + simpl in H.
    inversion H.
  + simpl in H.
    inversion H.
    specialize (IHs l H2).
    rewrite IHs.
    destruct s0.
    * simpl in H1.
      inversion H1.
    * simpl in H1.
      inversion H1.
      change (inr t) with (terminal_lift non_terminal t).
      reflexivity.
Qed.

Lemma generates_start_symbol_clo:
forall g: cfg non_terminal terminal,
forall n: nat,
generates (g_clo g) (iter [inl (Transf_clo_nt (start_symbol g))] n).
Proof.
intros g n.
induction n.
- simpl.
  apply g_clo_correct.
  + exact [].
  + exact [].
- unfold generates.
  simpl.
  apply derives_trans with (s2:= [inl (start_symbol (g_clo g))] ++ [inl (Transf_clo_nt (start_symbol g))]).
  + apply derives_start.
    simpl.
    apply New1_clo.
  + simpl.
    change (inl (Transf_clo_nt (start_symbol g)) :: iter [inl (Transf_clo_nt (start_symbol g))] n) with
           ([inl (Transf_clo_nt (start_symbol g))] ++ iter [inl terminal (Transf_clo_nt (start_symbol g))] n).
    rewrite iter_comm.
    change [inl Start_clo; inl (Transf_clo_nt (start_symbol g))] with ([inl Start_clo] ++ [inl terminal (Transf_clo_nt (start_symbol g))]).
    apply derives_combine.
    split.
    * exact IHn.
    * apply derives_refl.
Qed.

Lemma produces_split:
forall g: cfg non_terminal terminal,
forall w: sentence,
produces (g_clo g) w ->
w = [] \/
exists w1 w2: sentence,
produces (g_clo g) w1 /\
produces g w2 /\
w = w1 ++ w2.
Proof.
intros g w H.
unfold produces in H.
apply g_clo_correct_inv in H.
destruct H as [H | [H | H]].
- left.
  apply map_eq_nil in H.
  exact H.
- destruct w.
  + simpl in H.
    inversion H.
  + simpl in H.
    inversion H.
- right.
  destruct H as [s' [s'' [H1 [H2 H3]]]].
  symmetry in H3.
  apply map_expand in H3.
  destruct H3 as [s1' [s2' [ H4 [H5 H6]]]].
  exists s1', s2'.
  split.
  + unfold produces.
    rewrite H5.
    exact H1.
  + split.
    * unfold produces.
      apply map_clo_2 in H6.
      rewrite H6.
      exact H2.
    * exact H4.
Qed.

Lemma derives_g_clo_derives_g:
forall g: cfg non_terminal terminal,
forall s: sfc,
forall w: sentence,
derives (g_clo g) s (map (terminal_lift g_clo_nt (terminal:=terminal)) w) ->
forall sg: sf,
s = (map g_clo_sf_lift sg) ->
derives g sg (map (@terminal_lift non_terminal terminal) w).
Proof.
intros g s w.
rewrite derives_equiv_derives2.
intros H sg Hsg.
rewrite derives_equiv_derives2.
remember (map (terminal_lift g_clo_nt (terminal:=terminal)) w) as W.
revert sg Hsg HeqW.
induction H.
- intros.
  subst.
  symmetry in HeqW.
  apply map_clo_2 in HeqW.
  rewrite HeqW.
  apply derives2_refl.
- intros.
  subst.
  simpl in H0.
  inversion H0.
  + clear H0.
    subst.
    apply map_expand in Hsg.
    destruct Hsg as [s1' [s2' [_ [_ Hsg]]]].
    destruct s2'.
    * inversion Hsg.
    * inversion Hsg.
      {
      destruct s.
      - simpl in H1.
        inversion H1.
      - simpl in H1.
        inversion H1.
      }
  + clear H0.
    subst.
    apply map_expand in Hsg.
    destruct Hsg as [s1' [s2' [_ [_ Hsg]]]].
    destruct s2'.
    * inversion Hsg.
    * inversion Hsg.
      {
      destruct s.
      - simpl in H1.
        inversion H1.
      - simpl in H1.
        inversion H1.
      }
  + clear H0.
    subst.
    apply map_expand in Hsg.
    destruct Hsg as [s1' [s2' [Hs [Hs1 Hs2]]]].
    destruct s2' as [|[nn|nn] s2'].
    * inversion Hs2.
    * inversion Hs2.
      clear Hs2.
      subst.
      {
      apply derives2_step with (right:= s).
      - apply IHderives2.
        + rewrite map_app.
          rewrite map_app.
          reflexivity.
        + reflexivity.
      - exact H1.
      }
    * inversion Hs2.
Qed.

Lemma g_clo_correct_inv_v2:
forall g: cfg non_terminal terminal,
forall w: sentence,
produces (g_clo g) w ->
exists w': list sentence,
(forall s: sentence, In s w' -> produces g s) /\ w = flat w'.
Proof.
unfold produces, generates.
intros g w.
rewrite derives_equiv_derives6.
intros [n].
generalize (Le.le_refl n).
generalize n at 1 3 as i.
generalize dependent w.
induction n.
- intros w i Hi H.
  destruct i.
  + inversion H.
    clear H.
    destruct w.
    * inversion H0.
    * inversion H0.
  + omega.
- intros.
  inversion H0.
  clear H0.
  + destruct w.
    * inversion H4.
    * inversion H4.
  + simpl in H1.
    inversion H1.
    assert (s1 = []).
      {
      destruct s1.
      - reflexivity.
      - inversion H7.
        destruct s1.
        + inversion H9.
        + inversion H9.
      }
    assert (s2 = []).
      {
      rewrite H6 in H1.
      inversion H1.
      reflexivity.
      }
    subst.
    simpl in *.
    inversion H2.
    clear H2.
    subst.
    * rewrite app_nil_r in H4.
      apply derives6_split in H4.
      destruct H4 as [s1 [s2 [n1 [n2 [HH1 [HH2 [HH3 HH4]]]]]]].
      symmetry in HH1.
      apply map_expand in HH1.
      destruct HH1 as [w1 [w2 [Hw [Hw1 Hw2]]]].
      subst.
      assert (Hn1: n1 <= n).
        {
        omega.
        }
      specialize (IHn w1 _ Hn1 HH3).
      destruct IHn as [w1' [Hw1A Hw1B]].
      exists (w1' ++ [w2]).
      {
      split.
      - intros.
        apply in_app_or in H2.
        destruct H2 as [H2 | H2].
        + auto.
        + simpl in H2.
          destruct H2 as [H2 | H2].
          * subst.
            {
            eapply derives_g_clo_derives_g.
            - rewrite derives_equiv_derives6.
              exists n2.
              eauto.
            - reflexivity.
            }
          * contradiction.
      - rewrite flat_app.
        simpl.
        subst.
        rewrite app_nil_r.
        reflexivity.
      }
    * rewrite <- H5 in H4.
      simpl in H4.
      {
      inversion H4.
      - exists [].
        split.
        + intros s0 H11.
          inversion H11.
        + symmetry in H10.
          apply map_eq_nil in H10.
          rewrite H10.
          simpl.
          reflexivity.
      - destruct s1.
        + inversion H6.
        + inversion H6.
      }
    * rewrite <- H5 in H1.
      inversion H1.
Qed.

End Closure.

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

Section Closure_2.

Variable non_terminal terminal: Type.

Notation sentence:= (list terminal).

Inductive l_clo (l: lang terminal): lang terminal:=
| l_clo_nil: l_clo l []
| l_clo_app: forall s1 s2: sentence, (l_clo l) s1 -> l s2 -> l_clo l (s1 ++ s2).

Theorem l_clo_is_cfl:
forall l: lang terminal,
cfl l ->
cfl (l_clo l).
Proof.
intros l H.
unfold cfl.
unfold cfl in H.
unfold lang_eq.
unfold lang_eq in H.
unfold lang_of_g.
unfold lang_of_g in H.
destruct H as [non_terminal0 [g H]].
exists (g_clo_nt non_terminal0), (g_clo g).
intros w.
split.
- intros H1.
  induction H1.
  + apply g_clo_correct.
    * exact [].
    * exact [].
  + specialize (H s2).
    destruct H as [H _].
    specialize (H H0).
    unfold produces in H.
    unfold produces in IHl_clo.
    unfold produces.
    rewrite map_app.
    repeat rewrite map_clo_1.
    rewrite map_clo_1 in IHl_clo.
    apply g_clo_correct with (g:= g).
    split.
    * exact IHl_clo.
    * exact H.
- intros H1.
  apply g_clo_correct_inv_v2 in H1.
  destruct H1 as [w' [H2 H3]].
  subst.
  assert (forall s : sentence, In s w' -> l s).
    {
    intros s H4.
    specialize (H2 s H4).
    specialize (H s).
    destruct H as [_ H].
    specialize (H H2).
    exact H.
    }
  {
  induction w' using rev_ind.
  - simpl.
    constructor.
  - assert (flat (w' ++ [x]) = flat w' ++ x).
      {
      rewrite flat_app.
      simpl.
      rewrite app_nil_r.
      reflexivity.
      }
    rewrite H1.
    constructor.
    + apply IHw'.
      * intros s H5.
        apply H2.
        apply in_or_app.
        left.
        exact H5.
      * intros s H5.
        apply H0.
        apply in_or_app.
        left.
        exact H5.
    + apply H0.
      apply in_or_app.
      right.
      simpl.
      left.
      reflexivity.
  }
Qed.

Theorem l_clo_correct:
forall l: lang terminal,
(l_clo l) [] /\
forall s1 s2: sentence,
(l_clo l) s1 ->
l s2 ->
(l_clo l) (s1 ++ s2).
Proof.
intros l.
split.
- apply l_clo_nil.
- intros s1 s2 H1 H2.
  apply l_clo_app.
  + exact H1.
  + exact H2.
Qed.

Theorem l_clo_correct_inv:
forall l: lang terminal,
forall s: sentence,
(l_clo l) s ->
s = [] \/
exists s1 s2: sentence,
s = s1 ++ s2 /\
(l_clo l) s1 /\
l s2.
Proof.
intros l s H.
inversion H.
- left.
  reflexivity.
- right.
  exists s1, s2.
  split.
  + reflexivity.
  + split.
    * exact H0.
    * exact H1.
Qed.

End Closure_2.


(******************************************************************************)
(** Various lemmas (mainly about relations)                                   *)
(******************************************************************************)

Require Import Classical Peano_dec.
From PromisingLib Require Import Basic Loc.
From hahn Require Import Hahn.
Require Import List.
Set Implicit Arguments.

Section Relations.
Variable A B: Type.

Lemma inclusion_minus (s u m: A -> Prop):
  s ⊆₁ u \₁ m <-> s ⊆₁ u /\ s ∩₁ m ⊆₁ ∅.
Proof.
  split; [| basic_solver].
  ins. unfold set_minus in H. red in H. split.
  { red. ins. specialize (H x H0). desc. auto. }
  red. ins. red in H0. desc. specialize (H x H0). desc. vauto.
Qed.

Lemma empty_inter_minus_same (X Y: A -> Prop):
  X ∩₁ Y ≡₁ ∅ -> X \₁ Y ≡₁ X.
Proof.
  ins. red. split; [basic_solver| ].
  red. ins.
  red in H. desc.
  red. split; auto.
  red in H. specialize (H x).
  red. ins. apply H. basic_solver.
Qed.

Lemma same_relation_exp_iff {C: Type} (r r': relation C):
  r ≡ r' <-> (forall x y, r x y <-> r' x y).
Proof.
  red. split.
  { apply same_relation_exp. }
  ins. red. split.
  all: red; ins; apply H; auto.
Qed.

Lemma set_equiv_exp_iff {C: Type} (s s' : C -> Prop):
  s ≡₁ s' <-> forall x : C, s x <-> s' x.
Proof.
  red. split; [apply set_equiv_exp| ].
  ins. red. split.
  all: red; ins; apply H; auto.
Qed.

Lemma seq_eqv_lr_l (d1 d2: A -> Prop) r:
  r ≡ ⦗d1⦘ ⨾ r ⨾ ⦗d2⦘ -> r ≡ ⦗d1⦘ ⨾ r.
Proof. ins. rewrite H. basic_solver. Qed.

Lemma seq_eqv_lr_r (d1 d2: A -> Prop) r:
  r ≡ ⦗d1⦘ ⨾ r ⨾ ⦗d2⦘ -> r ≡ r ⨾ ⦗d2⦘.
Proof. ins. rewrite H. basic_solver. Qed.

Lemma inter_subset_helper (S S1 S2: A -> Prop):
  (forall x (Sx: S x), S1 x <-> S2 x) -> S ∩₁ S1 ≡₁ S ∩₁ S2.
Proof.
  ins. apply set_equiv_exp_iff. ins. specialize (H x).
  unfold set_inter.
  split; ins; desc; split; intuition.
Qed.

Lemma set_finite_alt (S: A -> Prop) (FIN: set_finite S):
  exists findom, forall x, S x <-> In x findom.
Proof.
  destruct FIN as [lst FIN].
  exists (filterP S lst). ins. split.
  { ins. apply in_filterP_iff. split; auto. }
  ins. apply in_filterP_iff in H. desc. auto.
Qed.

Lemma bunion_more_alt: forall (x y : A -> Prop),
    x ≡₁ y ->
    forall (x0 y0 : A -> relation B), (forall a, x0 a ≡ y0 a) -> (⋃x ∈ x, x0 x) ≡ (⋃x ∈ y, y0 x).
Proof.
  ins. apply same_relation_exp_iff. ins. red. splits.
  { unfold bunion. ins. desc. exists a. splits.
    { apply H. auto. }
    apply H0. auto. }
  { unfold bunion. ins. desc. exists a. splits.
    { apply H. auto. }
    apply H0. auto. }
Qed.

Lemma IN_SET_UNION (l1 l2: list A):
 (fun x => In x (l1 ++ l2)) ≡₁ (fun x => In x l1) ∪₁ (fun x => In x l2).
Proof.
  ins. apply set_equiv_exp_iff. ins. split.
  { ins. red. apply in_app_or. auto. }
  ins. red in H. apply in_or_app. auto.
Qed.

Lemma eqv_rel_more_inv (S1 S2: A -> Prop) (EQV_REL: ⦗S1⦘ ≡ ⦗S2⦘):
  S1 ≡₁ S2.
Proof.
  apply set_equiv_exp_iff. ins.
  apply (same_relation_exp) with (x := x) (y := x) in EQV_REL.
  unfold eqv_rel in EQV_REL. red in EQV_REL. desc.
  red. splits; desc; intuition.
Qed.

Lemma unique_restr  x y (r: relation A) (Rxy: r x y):
  ⦗eq x⦘ ⨾ r ⨾ ⦗eq y⦘ ≡ singl_rel x y.
Proof.
  ins. rewrite seq_eqv_lr. split.
  { red. ins. desc. red. splits; auto. }
  red. ins. red in H. desc. splits; vauto.
Qed.

Lemma singl_rel_restr (x y: A):
  singl_rel x y ≡ ⦗eq x⦘ ⨾ singl_rel x y ⨾ ⦗eq y⦘.
Proof. ins. basic_solver. Qed.

Lemma rel_endpoints_dom (D C EL ER : A -> Prop) r (DOM: r ≡ ⦗D⦘ ⨾ r ⨾ ⦗C⦘):
  ⦗EL⦘ ⨾ r ⨾ ⦗ER⦘ ≡ ⦗EL ∩₁ D⦘ ⨾ r ⨾ ⦗ER ∩₁ C⦘.
Proof.
  rewrite set_interC with (s' := C).
  do 2 rewrite id_inter. rewrite !seqA.
  seq_rewrite <- DOM. basic_solver.
Qed.

Lemma seq_compl_helper (r: relation A) (S: A -> Prop):
  r ⨾ ⦗set_compl S⦘ ≡ r \ set_full × S.
Proof.
  rewrite <- (seq_id_l r) at 1.
  rewrite seqA.
  pose proof (seq_eqv_lr r (fun _ : A => True) (set_compl S)).
  seq_rewrite H.
  apply same_relation_exp_iff. ins.
  split.
  { ins. desc. red. splits; auto. red. basic_solver. }
  ins. red in H0. desc. splits; auto.
  red. red. red in H1.
  ins. apply H1. unfold cross_rel. split; basic_solver.
Qed.

Lemma MINUS_DISTR_L (r: relation A) (S1 S2: A -> Prop):
  ⦗S1 \₁ S2⦘ ⨾ r ≡ ⦗S1⦘ ⨾ r \ ⦗S2⦘ ⨾ r.
Proof.
  ins. red. split; [| basic_solver].
  red. ins. red. apply seq_eqv_l in H. desc.
  red in H. desc.
  split; [basic_solver |].
  red. ins. apply seq_eqv_l in H2. basic_solver.
Qed.

Lemma MINUS_DISTR_R (r: relation A) (S1 S2: A -> Prop):
  r ⨾ ⦗S1 \₁ S2⦘ ≡ r ⨾ ⦗S1⦘ \ r ⨾ ⦗S2⦘.
Proof.
  ins. red. split; [| basic_solver].
  red. ins. red. apply seq_eqv_r in H. desc.
  red in H0. desc.
  split; [basic_solver |].
  red. ins. apply seq_eqv_r in H2. basic_solver.
Qed.

Lemma MINUS_GROUP (r1 r2 r3: relation A):
 (r1 \ r2) \ r3 ≡ r1 \ (r2 ∪ r3).
Proof.
  ins. red. split; [| basic_solver].
  red. ins. red. red in H. desc. red in H. desc.
  split; auto. red. ins. red in H2. basic_solver.
Qed.

Lemma SUPSET_RESTR (r1 r2: relation A) S (INCL: r1 ⊆ r2) (RESTR: r2 ≡ ⦗S⦘ ⨾ r2 ⨾ ⦗S⦘):
  r1 ≡ ⦗S⦘ ⨾ r1 ⨾ ⦗S⦘.
Proof.
  ins. split; [| basic_solver].
  red. ins. apply seq_eqv_lr.
  red in RESTR. desc. red in RESTR.
  red in INCL.
  pose proof (INCL x y H) as R2.
  specialize (RESTR x y R2). apply seq_eqv_lr in RESTR. desc.
  splits; auto.
Qed.

Lemma RESTR_SEQ  (r1 r2: relation A) (D: A -> Prop):
  restr_rel D r1 ⨾ restr_rel D r2 ⊆ restr_rel D (r1 ⨾ r2).
Proof. ins. basic_solver. Qed.

End Relations.

Ltac remove_emptiness :=
  repeat (rewrite set_inter_empty_r || rewrite set_inter_empty_l ||
          rewrite set_union_empty_r || rewrite set_union_empty_l ||
          rewrite union_false_r || rewrite union_false_l ||
          rewrite inter_false_r || rewrite inter_false_l ||
          rewrite seq_false_r || rewrite seq_false_l || rewrite eqv_empty ||
          rewrite cross_false_l || rewrite cross_false_r).

Lemma OPT_VAL: forall {A: Type} (opt: option A), opt <> None <-> exists o, Some o = opt.
Proof.
  intros. destruct opt eqn:v.
  - red. split; intros.
    + eexists. eauto.
    + discriminate.
  - red. split; intros.
    + intuition.
    + destruct H. discriminate H.
Qed.

Lemma find_iff_in {A: Type} (M: IdentMap.t A) k:
  IdentMap.In k M <-> exists elt, Some elt = IdentMap.find k M.
Proof.
  pose proof (@UsualFMapPositive.UsualPositiveMap.Facts.in_find_iff _ M k).
  pose proof OPT_VAL (IdentMap.find k M).
  eapply iff_stepl; [eapply H0 | symmetry; eauto].
Qed.


(******************************************************************************)
(* Dr Daniel Kirk (c) 2021                                                    *)
(******************************************************************************)
(* Let R : ringType and M : lmodType R                                        *)
(******************************************************************************)
(* lmodSetType M == a record consisting of an eqType 'sort' a function        *)
(*                  'elem' : sort -> M, and proofs of (injective elem)        *)
(*                  and (non_degenerate elem).                                *)
(*                  injective elem == forall x y, elem x = elem y -> x = y    *)
(*                  non_degenerate elem == forall x : T, elem x != 0          *)
(*                  B : lmodSetType M coerces to its type T and function elem *)
(*                  so b : B is shorthand for b : (sort B)                    *)
(*                  and S b for (elem B) b.                                   *)
(******************************************************************************)
(* Let B : lmodSetType M                                                      *)
(******************************************************************************)
(* typeIsInjective B == a proof that (sort B) is injective                    *)
(* typeIsNonDegenerate B == a proof that (sort B) is non-degenerate           *)
(******************************************************************************)
(* Let f : B -> R and s : seq B                                               *)
(******************************************************************************)
(*  lmodLCsumsTo C m  == a proof that there exists a sequence (s : seq B)  *)
(*                          without duplicates such that (hasSupport C s) and *)
(*                               \sum_(b <- s)(C b) *: (B b) == m.            *)
(*  eqLCSumsTo s1 s2  == given proofs of (hasSupport C s1) and             *)
(*                          (hasSupport C s2) this is a proof of              *)
(*                          \sum_(b <- s1)(C b) *: (B b)                      *)
(*                            = \sum_(b <- s2)(C b) *: (B b)                  *)
(******************************************************************************)
(*   lmodLCType B   == a record consisting of a function sort : B -> R        *)
(*                     and a proof of finSuppE sort                           *)
(*                     C : lmodLCType B coerces to sort                       *)
(******************************************************************************)
(* lmodLCNullType B ==                                                        *)
(* lmodLCUnitType B ==                                                        *)
(******************************************************************************)
(* Let r : R and C D : lmodLCType B                                           *)
(******************************************************************************)
(* lmodLCAdd C D    ==                                                        *)
(* lmodLCScale r C  ==                                                        *)
(******************************************************************************)

Require Import Coq.Program.Tactics.
From Coq.Logic Require Import FunctionalExtensionality ProofIrrelevance.
From mathcomp Require Import ssreflect ssrfun eqtype fintype seq bigop choice.

Require Import Modules Linears FiniteSupport.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool.
Set Warnings "parsing".

Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Open Scope ring_scope.
Open Scope lmod_scope.
Set Implicit Arguments.
Unset Strict Implicit.

Module lmodSet.
  Section Def.
    Variable (R : ringType) (M : lmodType R).
    Definition non_degenerate {T : Type} (elem : T -> M) := forall b : T, elem b != 0%R.

    Record mixin (T : eqType) := Mixin {
      elem : T -> M;
      _ : injective elem;
      _ : non_degenerate elem;
    }.

    Record type := Pack { sort : _; class_of : mixin sort; }.

    Definition Build {T : eqType} (elem : T -> M) (I : injective elem) (ND : non_degenerate elem)
     := Pack (Mixin I ND).

    Lemma typeIsInjective (T : type) : injective (elem (class_of T)).
    Proof. by destruct (class_of T)=>/=. Qed.

    Lemma typeIsNonDegenerate (T : type) : non_degenerate (elem (class_of T)).
    Proof. by destruct (class_of T)=>/=. Qed.

    Definition to_Type (T : type) : Type := (sort T).
  End Def.

  Module Exports.
    Notation lmodSetType := type.
    Notation non_degenerate := non_degenerate.
    Notation typeIsInjective := typeIsInjective.
    Notation typeIsNonDegenerate := typeIsNonDegenerate.
    Coercion to_Type : type >-> Sortclass.
    Coercion elem : mixin >-> Funclass.
    Coercion class_of : type >-> mixin.
    Coercion sort : type >-> eqType.
  End Exports.
  Export Exports.

  Section Sum.
    Variable (R : ringType) (M1 M2 : lmodType R) (B1 : type M1) (B2 : type M2).
      Definition elem_sum (t : B1 + B2) : M1*M2 := match t with
        |inl t' => (B1 t',0)
        |inr t' => (0,B2 t') end.
      Lemma inj_sum : injective elem_sum.
      Proof. rewrite /elem_sum=>/=x y H.
        destruct x as [s|s], y; inversion H.
        by rewrite(typeIsInjective H1).
        move:(typeIsNonDegenerate s); by rewrite H1 eq_refl.
        move:(typeIsNonDegenerate s); by rewrite H2 eq_refl.
        by rewrite(typeIsInjective H1).
      Qed.
      Lemma nondeg_sum : non_degenerate elem_sum.
      Proof.  rewrite /comp/elem_sum=>x. rewrite /eq_op/=.
        destruct x as [s|s]; rewrite/= eq_refl; [rewrite andbT|rewrite andTb];
        apply (typeIsNonDegenerate s).
      Qed.
    Definition sum := Build inj_sum nondeg_sum.
  End Sum.
End lmodSet.
Export lmodSet.Exports.

Import GRing.

Module lmodLC.
  Section Def.
    Variable (R : ringType) (M : lmodType R) (B : lmodSetType M).

    Definition type := (FSType R B).

    Lemma eqFSFun (C D : type) : C = D <-> (fsFun.sort C) = (fsFun.sort D).
    Proof. split; destruct C, D=>/=H. by inversion H.
    by destruct H; rewrite (proof_irrelevance _ hasFiniteSupport0 hasFiniteSupport).
    Qed.

    Definition sumsTo (C : type) m
      := exists s (_ : uniq s) (_ : hasSupport C s), \sum_(b <- s)(C b) *: (B b) == m.
  End Def.

  Module Exports.
    Notation lmodLCType := type.
    Notation lmodLCSumsTo := sumsTo.
  End Exports.

  Section Null.
    Variable (R : ringType) (M : lmodType R) (B : lmodSetType M).

    Lemma null_sumsTo : sumsTo (nullFSType R B) 0.
    Proof. rewrite/sumsTo.
      destruct (fsFun.null_finSuppE R B) as [n [NU NH]].
      refine(ex_intro _ n (ex_intro _ NU (ex_intro _ NH _)))=>/=.
      under eq_bigr do rewrite -(GRing.mulr0 0) -GRing.scalerA.
      by rewrite -GRing.scaler_sumr  GRing.scale0r.
    Qed.
  End Null.

  Section Singleton.
    Variable (R : ringType) (M : lmodType R) (B : lmodSetType M)
      (b : B) (r : R) (NZ : r != 0).

    Lemma unit_sumsTo : sumsTo (unitFSType b r) (r*:(B b)).
    Proof. rewrite/sumsTo/unitFSType/=.
      refine(ex_intro _ [::b] (ex_intro _ is_true_true _)).
      have E: hasSupport (fun b' => if b' == b then r else 0) [:: b] by
      rewrite/hasSupport=>b' F;
      case(b' == b) as []eqn:E; [rewrite in_cons E| rewrite eq_refl in F].
      refine(ex_intro _ E _).
      by rewrite big_seq1 eq_refl.
    Qed.
  End Singleton.

  Section Results.
    Variable (R : ringType) (M : lmodType R) (B : lmodSetType M).
    Import Exports.
    Definition li (C : type B) := sumsTo C 0 -> C = nullFSType R B.

    Section SumsTo.
      Lemma zeroLCSumsTo (C : B -> R) s : (hasSupport C s) -> (hasSupport C nil)
        -> \sum_(b <- s)(C b) *: (B b) == 0.
      Proof. rewrite/hasSupport=>H1 H2.
        induction s. by rewrite big_nil.
        rewrite big_cons.
        case(~~(C a == 0)) as []eqn:E.
        move:(H2 a E); rewrite in_nil=>//.
        apply negbFE in E; move/eqP in E.
        rewrite E scale0r add0r IHs=>//.
        move=>b S; move:(H1 b S)=>H; destruct H=>//.
        move:(H2 b S); rewrite in_nil=>//.
      Qed.

      Definition funOneMinus (s : seq B) (C : B -> R) (a b : B)
       := if b == a then if a \in s then 0 else -C b else C b.

      Lemma fsOneMinusA a s1 s2 (C : B -> R) (H1 : hasSupport C s1) (H2 : hasSupport C (a::s2)) : hasSupport (funOneMinus s1 C a) s2.
      Proof.
        rewrite/funOneMinus=>b D.
        case(b == a) as []eqn:A1.
        case(a \in s1) as []eqn:A2.
        by rewrite A2 eq_refl in D.
        rewrite A2 oppr_eq0 in D.
        move/eqP in A1.
        move:(H1 b D); rewrite A1 A2=>//.
        by move:(H2 b D); rewrite in_cons-(rwP orP) A1 =>F; destruct F=>//.
      Qed.

      Lemma fsOneMinusB a s1 s2 (C : B -> R) (H1 : hasSupport C s1) (H2 : hasSupport C (a::s2)) : hasSupport (funOneMinus s1 C a) (undup(a::s1)).
      Proof.
        rewrite/funOneMinus=>b D.
        case(b == a) as []eqn:A1.
        case(a \in s1) as []eqn:A2.
        by rewrite A2 eq_refl in D.
        rewrite A2 oppr_eq0 in D.
        move/eqP in A1.
        move:(H1 b D); rewrite A1 A2=>//.
        move:(H2 b D); rewrite mem_undup in_cons-(rwP orP) A1 =>F; destruct F=>//.
        by rewrite in_cons (H1 b D) orbT.
      Qed.

      Lemma RHSeq (C : B -> R) a s1 s2
      (H1 : hasSupport C s1)
      (H2 : hasSupport C (a::s2))
      (U1 : uniq s1) (A : a \notin s2)
      (U2 : uniq s2) (E : ~~ (C a == 0))
       : \sum_(j <- s2) C j *: B j = \sum_(b <- s2) (funOneMinus s1 C a b) *: B b.
      Proof. rewrite/funOneMinus !big_seq.
        apply eq_bigr=>b P.
        case(b == a) as []eqn:E1=>//.
        move/eqP in E1; destruct E1.
        by rewrite P in A.
      Qed.

      Lemma in_cat (T : eqType) (s : seq T) x : x \in s -> exists s1 s2, s = (s1 ++ [::x] ++ s2).
      Proof.
        move:x.
        induction s=>x.
        by rewrite in_nil.
        rewrite in_cons -(rwP orP) => H.
        destruct H.
        refine(ex_intro _ nil _).
        refine(ex_intro _ s _).
        move/eqP in H.
        by rewrite cat0s H cat1s.
        destruct(IHs x H) as [s1 [s2 H2]].
        refine(ex_intro _ (a::s1) _).
        refine(ex_intro _ s2 _).
        by rewrite cat_cons H2.
      Qed.

      Lemma LHSeq (C : B -> R) a s1 s2
      (H1 : hasSupport C s1)
      (H2 : hasSupport C (a::s2))
      (U1 : uniq s1) (A : a \notin s2)
      (U2 : uniq s2) (E : ~~ (C a == 0))
       : \sum_(b <- s1) C b *: B b - C a *: B a = \sum_(b <- undup (a :: s1))  (funOneMinus s1 C a b) *: B b.
      Proof. rewrite/funOneMinus/=.
      case(a \in s1) as []eqn:E1.
        rewrite (undup_id U1) E1.
        destruct (in_cat E1) as [x1 [x2 S]].
        rewrite S !big_cat/= !big_seq1 eq_refl scale0r add0r
        (addrC (C a *: B a) _) -!addrA addrN addr0 -!big_cat/= !big_seq.
        apply eq_bigr=>i P.
        case(i == a) as []eqn:F=>//.
          move/eqP in F; rewrite F mem_cat in P.
          move/orP in P; destruct P as [P|P].
            rewrite S cat_uniq cat_uniq in U1; move: U1.
            rewrite -!(rwP andP)=> U1; destruct U1 as [_ [U1 _]].
            move/hasPn in U1.
            move:(mem_head a x2); rewrite -cat1s=>G.
            move:(U1 a G).
            by rewrite /=P.

            rewrite S cat_uniq cat_uniq in U1; move: U1.
            rewrite -!(rwP andP)=> U1; destruct U1 as [_ [_ [_ [U1 _]]]].
            move/hasPn in U1.
            move:(U1 a P).
            by rewrite /= mem_seq1 eq_refl.

        rewrite (undup_id U1) E1 big_cons eq_refl (rwP eqP) subr_eq addrC addrA scaleNr addrN add0r !big_seq -(rwP eqP).
        apply eq_bigr=>i P.
        case(i == a) as []eqn:F=>//.
        by move/eqP in F; rewrite -F P in E1.
      Qed.

      Lemma eqLCSumsTo (C : B -> R) s1 s2 : (hasSupport C s1) -> (hasSupport C s2)
      -> uniq s1 -> uniq s2
      -> \sum_(b <- s1)(C b) *: (B b) = \sum_(b <- s2)(C b) *: (B b).
      Proof.
        move:C s1.
        induction s2=>C s1 H1 H2 U1 U2.
        rewrite big_nil (rwP eqP).
        apply (zeroLCSumsTo H1 H2).
        simpl in U2; move/andP in U2.
        case(C a == 0) as []eqn:E.
        move: (fsFun.finSupp_cons H2 E)=>H2c.
        move/eqP in E.
        by rewrite big_cons (IHs2 C s1 H1 H2c U1 (proj2 U2)) E scale0r add0r.
        apply negbT in E.
        move: (IHs2 _ _ (fsOneMinusB H1 H2) (fsOneMinusA H1 H2) (undup_uniq _) (proj2 U2))=>H.
        rewrite big_cons (rwP eqP) addrC -subr_eq.

        by rewrite (RHSeq H1 H2 U1 (proj1 U2) (proj2 U2) E) -H
                   (LHSeq H1 H2 U1 (proj1 U2) (proj2 U2) E).
      Qed.
    End SumsTo.
  End Results.

  Section Add.
    Import Exports.
    Variable (R : ringType) (M : lmodType R) (B : lmodSetType M) (C D : type B).

    Lemma add_sumsTo m n : sumsTo C m -> sumsTo D n -> sumsTo (C <+> D) (m + n).
    Proof. move=>HM HN.
      destruct HM as [sm [Um [Hm Sm]]], HN as [sn [Un [Hn Sn]]].
      refine(ex_intro _ (undup (sm ++ sn)) (ex_intro _ (undup_uniq (sm ++ sn)) _)).

      have HS : hasSupport (C <+> D) (undup (sm ++ sn)).
      move=>b X. rewrite mem_undup mem_cat.
      rewrite /(fsFun.add _)/= in X.
      case(~~(C b == 0)) as []eqn:E.
      by rewrite (Hm _ E).
      move/negbFE/eqP in E.
      rewrite E add0r in X.
      by rewrite (Hn _ X) orbT.

      refine(ex_intro _ HS _).
      rewrite /(fsFun.add _)/=.
      under eq_bigr do rewrite GRing.scalerDl.
      rewrite big_split/=.
      rewrite (eqLCSumsTo _ (fsFun.hasSupport_undup (fsFun.hasSupport_catl sn Hm))) in Sm=>//; [|by apply undup_uniq].
      rewrite (eqLCSumsTo _ (fsFun.hasSupport_undup (fsFun.hasSupport_catr sm Hn))) in Sn=>//; [|by apply undup_uniq].
      move/eqP in Sm; move/eqP in Sn.
      by rewrite Sm Sn.
    Qed.
  End Add.

  Section Scale.
    Import Exports.
    Variable (R : ringType) (M : lmodType R) (B : lmodSetType M) (r : R) (C : type B).

    Lemma scale_sumsTo m : sumsTo C m -> sumsTo (r <*:> C) (r *: m).
    Proof. move=>H.
      destruct H as [x [Ux [Hx Sx]]].
      refine(ex_intro _ x _).
      refine(ex_intro _ Ux _).
      have HS :hasSupport (r <*:> C) x.
      move=>b X.
      rewrite /(fsFun.scale _)/= in X.
      case(~~(C b == 0)) as []eqn:E.
      apply (Hx _ E).
      move/negbFE/eqP in E.
      by rewrite E mulr0 eq_refl in X.

      refine(ex_intro _ HS _).
      rewrite /(fsFun.scale _)/=.
      under eq_bigr do rewrite -scalerA.
      move/eqP in Sx.
      by rewrite -scaler_sumr Sx.
    Qed.
  End Scale.

  Section Sums.
    Import Exports.
      Variable (R : ringType)(M1 : lmodType R) (M2 : lmodType R)
      (B1 : lmodSetType M1) (B2 : lmodSetType M2).

      Section Def.
        Variable (C1 : type B1) (C2 : type B2).
        Definition sum : type (lmodSet.sum B1 B2) := fsFun.sum C1 C2.
      End Def.

      Section Result.
        Variable (C1 : type B1) (C2 : type B2).

        Lemma hasFunSupp_sum s1 s2 : hasSupport C1 s1 -> hasSupport C2 s2
          -> hasSupport (C1 <\oplus> C2) (fsFun.sum_seq s1 s2).
          Proof.  move=>H1 H2 b C.
            rewrite mem_cat.
            destruct b.
            move: (H1 _ C)=>D1.
            apply (map_f (@inl B1 B2)) in D1.
            by rewrite D1.
            move: (H2 _ C)=>D2.
            apply (map_f (@inr B1 B2)) in D2.
            by rewrite D2 orbT.
          Qed.
    End Result.
  End Sums.

  Section Results.
    Variable (R : ringType) (M : lmodType R) (B : lmodSetType M).

    Lemma sumToElem_sumToZero (C : type B) (b : B) : sumsTo C (B b) ->  sumsTo (C <+> unitFSType b (-1)) 0.
    Proof. move=>Z.
      move:(add_sumsTo Z (unit_sumsTo b (-1%R))).
      by rewrite scaleNr scale1r addrN.
    Qed.
  End Results.

End lmodLC.
Export lmodLC.Exports.

Notation lmodLCSumsTo := lmodLC.sumsTo.
Notation eqLCSumsTo := lmodLC.eqLCSumsTo.


Require Import Coq.Reals.Rdefinitions.
Require Import Coq.Reals.Reals.
Require Import Coq.Reals.Rminmax.
Require Import Coq.micromega.RMicromega.
Require Import Coq.micromega.Lra.

Require Import MathClasses.interfaces.abstract_algebra.

Require Import Helix.HCOL.CarrierType.
Require Import Helix.Util.Misc.

Instance Abs_R : @Abs R R_Equiv Rle R0 Ropp.
Proof.
  econstructor.
  instantiate (1:=Rabs x).
  split; intros Z.
  -
    apply Rabs_right.
    now apply Rle_ge.
  -
    now apply Rabs_left1.
Defined.

Global Instance CarrierDefs_R : CarrierDefs :=
  { CarrierA := R
  ; CarrierAe := R_Equiv
  ; CarrierAle := Rle
  ; CarrierAlt := Rlt
  ; CarrierAltdec := Rlt_dec
  ; CarrierAequivdec := R.OT.eq_dec
  ; CarrierAz := R0
  ; CarrierA1 := R1
  ; CarrierAplus := Rplus
  ; CarrierAmult := Rmult
  ; CarrierAneg := Ropp
  ; CarrierAabs := Abs_R
  }.

Global Instance CarrierProperties_R : @CarrierProperties CarrierDefs_R.
Proof.
  constructor.
  all: unfold CarrierA, CarrierAle, CarrierAlt, CarrierDefs_R.
  -
    typeclasses eauto.
  -
    repeat constructor.
    all: try typeclasses eauto.
    all: cbn.
    all: repeat try intros ?.
    all: try eapply Rsrt.
    + rewrite Radd_comm; apply Rsrt.
    + apply Rplus_opp_l.
    + rewrite Rmul_comm; apply Rsrt.
    + apply Rmult_plus_distr_l.
  -
    constructor; try typeclasses eauto; repeat intros ?.
    constructor; try typeclasses eauto; repeat intros ?.
    constructor; try typeclasses eauto; repeat intros ?.
    + now right.
    + eapply Rle_trans; eassumption.
    + now apply Rle_antisym.
    + pose proof Rle_or_lt x y as [T | T];
        [tauto | right; now apply Rlt_le].
  -
    constructor.
    all: typeclasses eauto.
  -
    constructor; try typeclasses eauto; repeat intros ?.
    constructor; try typeclasses eauto; repeat intros ?.
    constructor; try typeclasses eauto; repeat intros ?.
    all: try (cbv in *; congruence).
    +
      destruct (R.OT.eq_dec x z);
        [right | left]; congruence.
    +
      destruct (R.OT.eq_dec x y);
        now cbv in *.
    +
      destruct H.
      pose proof Rlt_trans _ _ _ H H0.
      now pose proof Rlt_irrefl x.
    +
      pose proof Rlt_dec x z as [T | T];
        [tauto |].
      right.
      apply Rnot_lt_le in T.
      eapply Rle_lt_trans; eassumption.
    +
      pose proof Req_appart_dec x y as [EQ | DEC].
      *
        subst.
        split; repeat intros ?.
        now cbv in *.
        pose proof Rlt_irrefl y.
        tauto.
      *
        destruct DEC;
          split; intros;
          try tauto.
        now apply Rlt_not_eq.
        intros C.
        eapply Rlt_not_eq; [eassumption | congruence].
    +
      split;
        [apply Rle_not_lt | apply Rnot_lt_le].
  -
    cbv.
    lra.
Qed.

Global Instance R_SRO :
  @orders.SemiRingOrder
    CarrierA CarrierAe CarrierAplus CarrierAmult CarrierAz CarrierA1 CarrierAle.
Proof.
  constructor;
    try typeclasses eauto;
    intros.
  -
    exists (y - x).
    cbv in *.
    lra.
  -
    constructor; constructor.
    1,3: constructor.
    all: try typeclasses eauto.
    all: intros; cbv in *; lra.
  -
    unfold PropHolds in *.
    now apply Rmult_le_pos.
Qed.


Require Export
  ByteString.Lib.LibExt
  ByteString.Lib.TupleEnsembles
  ByteString.Lib.Relations
  Coq.Sets.Finite_sets
  Coq.Sets.Finite_sets_facts.

Generalizable All Variables.

Global Program Instance Finite_Proper {A B} :
  Proper (Same (B:=B) ==> Basics.impl) (Finite (A * B)).
Obligation 1.
  relational.
  apply Same_Same_set in H.
  rewrite H.
  reflexivity.
Qed.

Global Program Instance Finite_Proper_flip_1 {A B} :
  Proper (Same (B:=B) ==> Basics.flip Basics.impl) (Finite (A * B)).
Obligation 1.
  relational.
  apply Same_Same_set in H.
  rewrite <- H.
  reflexivity.
Qed.

Global Program Instance Finite_Proper_flip_2 {A B} :
  Proper (Same (B:=B) --> Basics.flip Basics.impl) (Finite (A * B)).
Obligation 1.
  relational.
  apply Same_Same_set in H.
  rewrite H.
  reflexivity.
Qed.

Section TupleEnsembleFinite.

Variable A : Type.
Variable B : Type.

Lemma Empty_preserves_Finite : Finite _ (@Empty A B).
Proof. constructor. Qed.

Lemma Single_is_Finite : forall a b, Finite _ (@Single A B a b).
Proof. intros; apply Singleton_is_finite. Qed.

Lemma Insert_preserves_Finite : forall a b `(_ : Finite _ r) H,
  Finite _ (@Insert A B a b r H).
Proof. intros; apply Add_preserves_Finite; assumption. Qed.

Lemma Setminus_preserves_finite {U} :
  forall A:Ensemble U,
    Finite U A -> forall X:Ensemble U, Finite U (Setminus U A X).
Proof.
  intros A' ? ?; apply Finite_downward_closed with A'; auto with sets.
  intros ? H0; inversion H0; assumption.
Qed.

Lemma Remove_preserves_Finite : forall a `(_ : Finite _ r),
  Finite _ (@Remove A B a r).
Proof. intros; apply Setminus_preserves_finite; assumption. Qed.

Lemma Update_preserves_Finite : forall a b `(_ : Finite _ r),
  Finite _ (@Update A B a b r).
Proof.
  intros; apply Add_preserves_Finite, Setminus_preserves_finite; assumption.
Qed.

Lemma Filter_preserves_Finite : forall P `(_ : Finite _ r),
  Finite _ (@Filter A B P r).
Proof.
  unfold Filter; intros.
  eapply Finite_downward_closed; eauto with sets.
  intros ? H0; inversion H0; clear H0.
  unfold Lookup in H.
  rewrite <- surjective_pairing in H.
  assumption.
Qed.

Lemma Finite_Add_Subtract : forall T (Y : Ensemble T) x,
  Finite _ (Add T (Subtract T Y x) x) -> Finite _ Y.
Proof.
  intros.
  eapply Finite_downward_closed; eauto with sets; intros ??.
  (* Jason Gross: To avoid the axiom of choice, you'd need a stronger version
     of [Finite], something like having a list of elements together with a
     mapping of elements of the type to indices of the list such that if an
     element of the type is in the subset, then it is equal to the element of
     the list at the corresponding index. In this case, everything is
     constructive, and you shouldn't need either Extensionality_Ensembles nor
     decidable equality. *)
  elim (classic (x = x0)); intros.
    subst; right; constructor.
  left; constructor; auto.
  unfold not; intros.
  contradiction H1.
  inversion H2.
  reflexivity.
Qed.

Definition Surjective {A B} (X : Ensemble A) (Y : Ensemble B) f :=
  forall y : B, In _ Y y -> exists x : A, In _ X x /\ y = f x.

Lemma Surjective_Add_Subtract : forall T T' X Y f x,
  Surjective (Add T X x) Y f -> Surjective X (Subtract T' Y (f x)) f.
Proof.
  unfold Surjective; intros.
  inversion H0; clear H0.
  destruct (H _ H1) as [? [? ?]]; subst; clear H H1.
  inversion H0; subst; clear H0.
    exists x0; intuition.
  inversion H; subst; clear H.
  contradiction H2.
  constructor.
Qed.

Lemma Surjection_preserves_Finite : forall T T' X Y f,
  Surjective X Y f -> Finite T X -> Finite T' Y.
Proof.
  intros.
  generalize dependent Y.
  induction H0; intros.
    eapply Finite_downward_closed; eauto with sets; intros ??.
    firstorder.
  apply Surjective_Add_Subtract in H1; auto.
  specialize (IHFinite _ H1).
  eapply Finite_Add_Subtract.
  constructor.
  exact IHFinite.
  unfold not; intros.
  inversion H2.
  contradiction H4.
  constructor.
Qed.

Lemma Map_preserves_Finite {C} : forall f `(_ : Finite _ r),
  Finite _ (@Map A B C f r).
Proof.
  unfold Map; intros.
  apply Surjection_preserves_Finite
   with (X:=r) (f:=fun p => (fst p, f (fst p) (snd p))); trivial.
  intros ??.
  unfold Ensembles.In in H.
  do 2 destruct H.
  destruct y; simpl in *; subst.
  exists (a, x); simpl.
  intuition.
Qed.

Lemma Map_set_preserves_Finite {T T'} : forall f `(_ : Finite _ r),
  Finite _ (@Map_set T T' f r).
Proof.
  unfold Map_set; intros.
  apply Surjection_preserves_Finite with (X:=r) (f:=f); trivial.
  intros ??.
  unfold Ensembles.In in H.
  do 2 destruct H; subst.
  exists x; simpl.
  intuition.
Qed.

Lemma Relate_preserves_Finite :
  forall A B C D (f : A -> B -> C -> D -> Prop) `(_ : Finite _ r)
         (is_functional : forall k e k' e' k'' e'',
            f k e k' e' -> f k e k'' e'' -> k' = k'' /\ e' = e'')
         (is_total : forall (k : A) (e : B),
            { p : C * D | f k e (fst p) (snd p) }),
    Finite _ (Relate f r).
Proof.
  unfold Relate; intros ????? r ? g k.
  eapply Surjection_preserves_Finite
    with (X:=r) (f:=fun p => proj1_sig (k (fst p) (snd p))); trivial.
  intros ??.
  unfold Ensembles.In in H.
  do 2 destruct H.
  destruct y; simpl in *; subst.
  exists (x, x0); simpl.
  destruct (k x x0), x1.
  simpl in *; intuition.
  destruct (g _ _ _ _ _ _ f0 H1); subst.
  reflexivity.
Qed.

Lemma Relate_Add_preserves_Finite :
  forall A B C D (f : A -> B -> C -> D -> Prop) `(_ : Finite _ r) x
         (is_functional : forall k e k' e' k'' e'',
            f k e k' e' -> f k e k'' e'' -> k' = k'' /\ e' = e'')
         (is_total : forall (k : A) (e : B),
            { p : C * D | f k e (fst p) (snd p) }),
    ~ In (A * B) r x
      -> Finite _ (Relate f r)
      -> Finite _ (Relate f (Add (A * B) r x)).
Proof.
  intros.
  apply Relate_preserves_Finite; auto.
  constructor; auto.
Qed.

Lemma Move_preserves_Finite : forall a a' `(_ : Finite _ r),
  (forall x y : A, {x = y} + {x <> y})
    -> Finite _ (@Move A B a a' r).
Proof.
  intros.
  apply Relate_preserves_Finite; trivial; intros.
    intuition; subst; congruence.
  destruct (X k a); subst.
    exists (a', e); simpl; intuition.
  exists (k, e); simpl; intuition.
Qed.

Lemma Modify_preserves_Finite : forall a f `(_ : Finite _ r),
  (forall x y : A, {x = y} + {x <> y})
    -> Finite _ (@Modify A B a f r).
Proof.
  intros.
  apply Relate_preserves_Finite; trivial; intros.
    intuition.
      destruct H2, H3; intuition; subst; auto.
    destruct H2, H3; intuition; subst; tauto.
  destruct (X k a); subst.
    exists (a, f e); simpl; intuition.
    left; intuition.
  exists (k, e); simpl; intuition.
  right; intuition.
Qed.

Lemma Conjunction_preserves_finite_right {U} :
  forall A:Ensemble U,
    Finite U A -> forall X:Ensemble U,
      Finite U (fun x : U => In U X x /\ In U A x).
Proof.
  intros A' H' X.
  apply Finite_downward_closed with A'; auto with sets.
  intros ? H0; inversion H0; assumption.
Qed.

Lemma Conjunction_preserves_finite_left {U} :
  forall X:Ensemble U,
    Finite U X -> forall A:Ensemble U,
      Finite U (fun x : U => In U X x /\ In U A x).
Proof.
  intros X H' A'.
  apply Finite_downward_closed with X; auto with sets.
  intros ? H0; inversion H0; assumption.
Qed.

Lemma Product_preserves_Finite {T U X Y} :
  Finite T X -> Finite U Y -> Finite (T * U) (Product X Y).
Proof.
  intros.
  generalize dependent Y.
  induction H; intros.
    eapply Finite_downward_closed; eauto with sets.
    intros ? H1; inversion H1; inversion H.
  rewrite Product_Add_left.
  apply Union_preserves_Finite; auto.
  clear IHFinite H0 H A0.
  induction H1.
    eapply Finite_downward_closed; eauto with sets.
    intros ? H1; inversion H1; inversion H0.
  rewrite Product_Add_right.
  apply Union_preserves_Finite; auto.
  rewrite Product_Singleton_Singleton.
  rewrite <- Empty_set_zero'.
  constructor.
    constructor.
  unfold not; intros.
  inversion H0.
Qed.

Lemma Define_preserves_Finite : forall P b `(_ : Finite _ r),
  (forall x : A, {P x} + {~ P x})
    -> Finite _ P -> Finite _ (@Define A B P b r).
Proof.
  unfold Define; intros.
  apply Union_preserves_Finite.
    apply Product_preserves_Finite; auto.
    apply Singleton_is_finite.
  apply Filter_preserves_Finite; auto.
Qed.

End TupleEnsembleFinite.

Hint Resolve Conjunction_preserves_finite_left : sets.
Hint Resolve Conjunction_preserves_finite_right : sets.
Hint Resolve Define_preserves_Finite : sets.
Hint Resolve Empty_preserves_Finite : sets.
Hint Resolve Filter_preserves_Finite : sets.
Hint Resolve Finite_Add_Subtract : sets.
Hint Resolve Insert_preserves_Finite : sets.
Hint Resolve Map_preserves_Finite : sets.
Hint Resolve Modify_preserves_Finite : sets.
Hint Resolve Move_preserves_Finite : sets.
Hint Resolve Product_Add_left : sets.
Hint Resolve Product_Add_right : sets.
Hint Resolve Product_Empty_set_left : sets.
Hint Resolve Product_Empty_set_right : sets.
Hint Resolve Product_Singleton_Singleton : sets.
Hint Resolve Product_preserves_Finite : sets.
Hint Resolve Relate_Add_preserves_Finite : sets.
Hint Resolve Relate_preserves_Finite : sets.
Hint Resolve Remove_preserves_Finite : sets.
Hint Resolve Setminus_preserves_finite : sets.
Hint Resolve Single_is_Finite : sets.
Hint Resolve Surjection_preserves_Finite : sets.
Hint Resolve Surjective_Add_Subtract : sets.
Hint Resolve Update_preserves_Finite : sets.

Ltac finite_preservation :=
  repeat (
  match goal with
  | [ |- Finite _ Empty            ] => apply Empty_preserves_Finite
  | [ |- Finite _ (Single _ _)     ] => apply Single_is_Finite
  | [ |- Finite _ (Insert _ _ _ _) ] => apply Insert_preserves_Finite
  | [ |- Finite _ (Remove _ _)     ] => apply Remove_preserves_Finite
  | [ |- Finite _ (Update _ _ _)   ] => apply Update_preserves_Finite
  | [ |- Finite _ (Move _ _ _)     ] => apply Move_preserves_Finite
  | [ |- Finite _ (Map _ _)        ] => apply Map_preserves_Finite
  | [ |- Finite _ (Map_set _ _)    ] => apply Map_set_preserves_Finite
  | [ |- Finite _ (Relate _ _)     ] => apply Relate_preserves_Finite
  | [ |- Finite _ (Filter _ _)     ] => apply Filter_preserves_Finite
  | [ |- Finite _ (Define _ _ _)   ] => apply Define_preserves_Finite
  | [ |- Finite _ (Modify _ _ _)   ] => apply Modify_preserves_Finite
  | [ |- Finite _ (Union _ _ _)    ] => apply Union_preserves_Finite
  end; auto).


Require Export GeoCoq.Elements.OriginalProofs.lemma_squarerectangle.

Section Euclid.

Context `{Ax:area}.

Lemma proposition_48A :
   forall A B C D a b c d,
   SQ A B C D -> SQ a b c d -> EF A B C D a b c d ->
   Cong A B a b.
Proof.
intros.
assert (PG A B C D) by (conclude lemma_squareparallelogram).
assert (PG a b c d) by (conclude lemma_squareparallelogram).
assert (Cong_3 B A D D C B) by (conclude proposition_34).
assert (Cong_3 b a d d c b) by (conclude proposition_34).
assert (ET B A D D C B) by (conclude axiom_congruentequal).
assert (ET b a d d c b) by (conclude axiom_congruentequal).
assert (ET B A D B D C) by (forward_using axiom_ETpermutation).
assert (ET B D C B A D) by (conclude axiom_ETsymmetric).
assert (ET B D C A B D) by (forward_using axiom_ETpermutation).
assert (ET A B D B D C) by (conclude axiom_ETsymmetric).
assert (ET b a d b d c) by (forward_using axiom_ETpermutation).
assert (ET b d c b a d) by (conclude axiom_ETsymmetric).
assert (ET b d c a b d) by (forward_using axiom_ETpermutation).
assert (ET a b d b d c) by (conclude axiom_ETsymmetric).
assert (RE A B C D) by (conclude lemma_squarerectangle).
assert (RE a b c d) by (conclude lemma_squarerectangle).
assert (CR A C B D) by (conclude_def RE ).
assert (CR a c b d) by (conclude_def RE ).
assert (Par A B C D) by (conclude_def PG ).
assert (nCol A B D) by (forward_using lemma_parallelNC).
assert (Par a b c d) by (conclude_def PG ).
assert (nCol a b d) by (forward_using lemma_parallelNC).
assert (TS A B D C) by (forward_using lemma_crossimpliesopposite).
assert (TS a b d c) by (forward_using lemma_crossimpliesopposite).
assert (ET A B D a b d) by (conclude axiom_halvesofequals).
assert (Cong a b d a) by (conclude_def SQ ).
assert (Cong A B D A) by (conclude_def SQ ).
assert (Cong a b a d) by (forward_using lemma_congruenceflip).
assert (Cong A B A D) by (forward_using lemma_congruenceflip).
assert (~ Lt a b A B).
 {
 intro.
 let Tf:=fresh in
 assert (Tf:exists E, (BetS A E B /\ Cong A E a b)) by (conclude_def Lt );destruct Tf as [E];spliter.
 assert (Lt a d A B) by (conclude lemma_lessthancongruence2).
 assert (Lt a d A D) by (conclude lemma_lessthancongruence).
 let Tf:=fresh in
 assert (Tf:exists F, (BetS A F D /\ Cong A F a d)) by (conclude_def Lt );destruct Tf as [F];spliter.
 assert (Per D A B) by (conclude_def SQ ).
 assert (Per d a b) by (conclude_def SQ ).
 assert (neq A D) by (forward_using lemma_betweennotequal).
 assert (neq A B) by (forward_using lemma_betweennotequal).
 assert (Out A D F) by (conclude lemma_ray4).
 assert (Out A B E) by (conclude lemma_ray4).
 assert (nCol D A B) by (forward_using lemma_NCorder).
 assert (CongA D A B D A B) by (conclude lemma_equalanglesreflexive).
 assert (CongA D A B F A E) by (conclude lemma_equalangleshelper).
 assert (CongA F A E D A B) by (conclude lemma_equalanglessymmetric).
 assert (Per F A E) by (conclude lemma_equaltorightisright).
 assert (CongA F A E d a b) by (conclude lemma_Euclid4).
 assert (Cong F E d b) by (conclude proposition_04).
 assert (Cong F A d a) by (forward_using lemma_congruenceflip).
 assert (Cong_3 F A E d a b) by (conclude_def Cong_3 ).
 assert (ET F A E d a b) by (conclude axiom_congruentequal).
 assert (ET F A E a b d) by (forward_using axiom_ETpermutation).
 assert (ET a b d A B D) by (conclude axiom_ETsymmetric).
 assert (ET F A E A B D) by (conclude axiom_ETtransitive).
 assert (ET F A E D A B) by (forward_using axiom_ETpermutation).
 assert (ET D A B F A E) by (conclude axiom_ETsymmetric).
 assert (Triangle D A B) by (conclude_def Triangle ).
 assert (~ ET D A B F A E) by (conclude axiom_deZolt2).
 contradict.
 }
assert (~ Lt A B a b).
 {
 intro.
 let Tf:=fresh in
 assert (Tf:exists e, (BetS a e b /\ Cong a e A B)) by (conclude_def Lt );destruct Tf as [e];spliter.
 assert (Lt A D a b) by (conclude lemma_lessthancongruence2).
 assert (Lt A D a d) by (conclude lemma_lessthancongruence).
 let Tf:=fresh in
 assert (Tf:exists f, (BetS a f d /\ Cong a f A D)) by (conclude_def Lt );destruct Tf as [f];spliter.
 assert (Per d a b) by (conclude_def SQ ).
 assert (Per D A B) by (conclude_def SQ ).
 assert (neq a d) by (forward_using lemma_betweennotequal).
 assert (neq a b) by (forward_using lemma_betweennotequal).
 assert (Out a d f) by (conclude lemma_ray4).
 assert (Out a b e) by (conclude lemma_ray4).
 assert (nCol d a b) by (forward_using lemma_NCorder).
 assert (CongA d a b d a b) by (conclude lemma_equalanglesreflexive).
 assert (CongA d a b f a e) by (conclude lemma_equalangleshelper).
 assert (CongA f a e d a b) by (conclude lemma_equalanglessymmetric).
 assert (Per f a e) by (conclude lemma_equaltorightisright).
 assert (CongA f a e D A B) by (conclude lemma_Euclid4).
 assert (Cong f e D B) by (conclude proposition_04).
 assert (Cong f a D A) by (forward_using lemma_congruenceflip).
 assert (Cong_3 f a e D A B) by (conclude_def Cong_3 ).
 assert (ET f a e D A B) by (conclude axiom_congruentequal).
 assert (ET f a e A B D) by (forward_using axiom_ETpermutation).
 assert (ET A B D f a e) by (conclude axiom_ETsymmetric).
 assert (ET f a e a b d) by (conclude axiom_ETtransitive).
 assert (ET f a e d a b) by (forward_using axiom_ETpermutation).
 assert (ET d a b f a e) by (conclude axiom_ETsymmetric).
 assert (Triangle d a b) by (conclude_def Triangle ).
 assert (~ ET d a b f a e) by (conclude axiom_deZolt2).
 contradict.
 }
assert (neq A B) by (forward_using lemma_NCdistinct).
assert (neq a b) by (forward_using lemma_NCdistinct).
assert (Cong A B a b) by (conclude lemma_trichotomy1).
close.
Qed.

End Euclid.


(** * 6.822 Formal Reasoning About Programs, Spring 2020 - Pset 3 *)

Require Import Frap.Frap.
Require Import Pset3Sig.
Set Default Goal Selector "!".

(* Authors:
 * Ben Sherman (sherman@csail.mit.edu),
 * Adam Chlipala (adamc@csail.mit.edu),
 * Samuel Gruetter <gruetter@mit.edu>
 *)

(* In this pset, we will practice two topics:
   1) Polymorphic container types, i.e. types which are parametrized by a
      type, such as "option A", "list A", "tree A", and finally, "binary_trie A",
      which combines option and tree to obtain a new useful data structure.
   2) Higher-order functions (HOFs), i.e. functions which take other functions
      as arguments.
*)

(* Each of the exercises below is worth some number of points.
   If you just want to enjoy the proof hacking without getting distracted by points,
   feel free to ignore these points. On the other hand, if you want to know how
   many points each exercise earns you, you can find the points in Pset3Sig.v. *)

(** ****** Polymorphic container types ****** *)

(* First, we'll reproduce some definitions we need from Lecture 2,
   [tree] and [flatten]: *)

Inductive tree {A} :=
| Leaf
| Node (l : tree) (d : A) (r : tree).
Arguments tree : clear implicits.

Fixpoint flatten {A} (t : tree A) : list A :=
  match t with
  | Leaf => []
  | Node l d r => flatten l ++ d :: flatten r
  end.

(* And here's one additional definition that we'll use in this problem set.
 * [either] combines two [option] values into one.
 * If either argument to [either] is a [Some], then so is
 * the result of the [either], preferring the contents of
 * the first argument if both are [Some].
 *
 * We will observe an "analogy" between the [either]
 * function on options and the [++] function on lists.
 *)
Definition either {A} (xo yo : option A) : option A :=
  match xo with
  | None => yo
  | Some x => Some x
  end.

(* If we [either] an [option] value with [None]
 * on the right, it leaves that value unchanged,
 * (just as if we put the [None] on the left).
 * This is analogous to how appending [nil]
 * on either side of a list leaves it unchanged.
 *)
Theorem either_None_right : forall {A} (xo : option A),
    either xo None = xo.
Proof.
Admitted.

(* [either] is associative, just like [++]. *)
Theorem either_assoc : forall {A} (xo yo zo : option A),
    either (either xo yo) zo = either xo (either yo zo).
Proof.
Admitted.

(* [head] should compute the head of a list, that is,
 * it should return [Some] with the first element of
 * the list if the list is nonempty, and [None]
 * if the list is empty.
 *)
Definition head {A} (xs : list A) : option A. Admitted.

Example head_example : head [1; 2; 3] = Some 1.
Proof.
Admitted.

(* The following theorem makes a formal connection
 * between [either] and [++].
 *)
Theorem either_app_head : forall {A} (xs ys : list A),
    head (xs ++ ys) = either (head xs) (head ys).
Proof.
Admitted.

(* [leftmost_Node] should compute the leftmost node of
 * a tree.
 *
 * Please implement [leftmost_Node] directly using
 * recursion (i.e., pattern matching) on the [tree] argument,
 * without using the [flatten] operation.
 *)
Fixpoint leftmost_Node {A} (t : tree A) : option A. Admitted.

Example leftmost_Node_example :
    leftmost_Node (Node (Node Leaf 2 (Node Leaf 3 Leaf)) 1 Leaf)
    = Some 2.
Proof.
Admitted.

(* Prove that the leftmost node of the tree is the same
 * as the head of the list produced by flattening the tree
 * with an in-order traversal.
 *)
Theorem leftmost_Node_head : forall {A} (t : tree A),
    leftmost_Node t = head (flatten t).
Proof.
Admitted.

(* A binary trie is a finite map keyed by lists of Booleans.
 * We will implement a binary trie with entries of type [A]
 * by [tree (option A)]. The value at the root of the tree
 * corresponds to the entry for the key [nil : list bool],
 * the left subtree contains entries for those keys that
 * begin with [true], and the right subtree contains entries
 * for those keys that begin with [false].
 *)
Definition binary_trie A := tree (option A).

(* Define [lookup] such that [lookup k t] looks up the
 * map entry corresponding to the key [k : list bool] in the
 * binary trie [t : binary_trie A], interpreting [t] such that
 * the value at the root of [t] corresponds to the
 * entry for the key [nil], the left subtree contains entries
 * for those keys that begin with [true], and the right subtree
 * contains entries for those keys that begin with [false].
 *)
Fixpoint lookup {A} (k : list bool) (t : binary_trie A) {struct t} : option A. Admitted.

Example lookup_example1 : lookup [] (Node Leaf (None : option nat) Leaf) = None.
Proof.
Admitted.

Example lookup_example2 : lookup [false; true]
    (Node (Node Leaf (Some 2) Leaf) None (Node (Node Leaf (Some 1) Leaf) (Some 3) Leaf))
                          = Some 1.
Proof.
Admitted.

(* [Leaf] represents an empty binary trie, so a lookup for
 * any key should return [None].
 *)
Theorem lookup_empty {A} (k : list bool)
  : lookup k (Leaf : binary_trie A) = None.
Proof.
Admitted.

(* Define an operation to "insert" a key and optional value
 * into a binary trie. The [insert] definition should satisfy two
 * properties: one is [lookup_insert] below, which says that if we
 * look up a key [k] in a trie where [(k, v)] has just been inserted,
 * the result should be [v]. The other is that lookups on keys different
 * from the one just inserted should be the same as on the original map.
 *
 * If an entry for that key already exists, [insert] should replace
 * that entry with the new one being inserted. Note that [insert] can
 * be used to remove an entry from the trie, too, by inserting [None]
 * as the value.
 *
 * Hint: it may be helpful to define an auxiliary function that inserts
 * a key and optional value into the empty trie.
 *)
Fixpoint insert {A} (k : list bool) (v : option A) (t : binary_trie A) {struct t}
  : binary_trie A. Admitted.

Example insert_example1 : lookup [] (insert [] None (Node Leaf (Some 0) Leaf)) = None.
Proof.
Admitted.

Example insert_example2 : lookup [] (insert [true] (Some 2) (Node Leaf (Some 0) Leaf)) = Some 0.
Proof.
Admitted.

Theorem lookup_insert {A} (k : list bool) (v : option A) (t : binary_trie A) :
  lookup k (insert k v t) = v.
Proof.
Admitted.

(** ****** Higher-order functions ****** *)

(* Recall the identity function [id] we used in class, which just returns its
   argument without modification: *)
Definition id {A : Type} (x : A) : A := x.

(* We also saw [compose], another higher-order function: [compose g f]
 * applies [f] to its input and then applies [g]. Argument order
 * follows the general convention of functional composition in
 * mathematics denoted by the small circle.
 *)
Definition compose {A B C : Type} (g : B -> C) (f : A -> B) (x : A) : C := g (f x).

(* Let's use a small circle to refer to [compose]. This will make our
   goals much more readable.
   It's up to you to decide whether you also want to use the circle notation
   in your definitions, or whether you prefer to write "compose". *)
Notation " g ∘ f " := (compose g f) (at level 40, left associativity).

(* Here are three simple properties of function composition. *)
Lemma compose_id_l : forall A B (f: A -> B),
    id ∘ f = f.
Proof.
Admitted.

Lemma compose_id_r : forall A B (f: A -> B),
    f ∘ id = f.
Proof.
Admitted.

Lemma compose_assoc : forall A B C D (f: A -> B) (g: B -> C) (h: C -> D),
    h ∘ (g ∘ f) = h ∘ g ∘ f.
Proof.
Admitted.

(* The selfCompose function takes a function and applies this function n times
   to the argument. There are different ways of defining it, but let's
   define it using only [id] and [compose]. *)
Fixpoint selfCompose{A: Type}(f: A -> A)(n: nat): A -> A :=
  match n with
  | O => id
  | S n' => f ∘ (selfCompose f n')
  end.

(* Here's an example of what [selfCompose] can do:
   If we apply the function which adds 2 to its argument 7 times to the starting
   value 3, we obtain 3 + 7 * 2 = 17. *)
Example selfCompose_plus1: selfCompose (plus 2) 7 3 = 17. Proof. equality. Qed.

(* We can also use [selfCompose] to define exponentiation on natural numbers, by
   saying "to raise [base] to the power [e], apply the function which multiplies
   its argument by [base] to [1] [e] times".
   Define [exp] using [selfCompose] and [Nat.mul]. *)
Definition exp(base e: nat): nat. Admitted.

(* Once you define [exp], you can replace [Admitted.] below by [Proof. equality. Qed.] *)
Lemma test_exp_2_3: exp 2 3 = 8. Admitted.
Lemma test_exp_3_2: exp 3 2 = 9. Admitted.
Lemma test_exp_4_1: exp 4 1 = 4. Admitted.
Lemma test_exp_5_0: exp 5 0 = 1. Admitted.
Lemma test_exp_1_3: exp 1 3 = 1. Admitted.

(* And here's another example to illustrate [selfCompose], make sure you understand
   why its result is 256. *)
Example selfCompose_square: selfCompose (fun (x: nat) => x * x) 3 2 = 256. Proof. equality. Qed.

(* If we map the [id] function over any list, we get the
 * same list back.
 *)
Theorem map_id : forall {A : Type} (xs : list A),
    map id xs = xs.
Proof.
Admitted.

(* If we map the composition of two functions over the list,
 * it's the same as mapping the first function over the whole list
 * and then mapping the second function over that resulting list.
 *)
Theorem map_compose : forall {A B C : Type} (g : B -> C) (f : A -> B) (xs : list A),
    map (g ∘ f) xs = map g (map f xs).
Proof.
Admitted.

(* Just like we defined [map] for lists, we can similarly define
 * a higher-order function [tree_map] which applies a function on
 * elements to all of the elements in the tree, leaving the tree
 * structure intact.
 *)
Fixpoint tree_map {A B : Type} (f : A -> B) (t : tree A)
  : tree B. Admitted.

Example tree_map_example :
  tree_map (fun x => x + 1) (Node (Node Leaf 1 Leaf) 2 (Node Leaf 3 (Node Leaf 4 Leaf)))
  = (Node (Node Leaf 2 Leaf) 3 (Node Leaf 4 (Node Leaf 5 Leaf))).
Proof.
Admitted.

(* [tree_map_flatten] shows that [map]
 * and [tree_map] are related by the [flatten] function.
 *)
Theorem tree_map_flatten : forall {A B : Type} (f : A -> B) (t : tree A),
    flatten (tree_map f t) = map f (flatten t).
Proof.
Admitted.

(* *** Inverse functions *** *)

(* Using [compose] and [id], we can write a concise definition of when
   a function [g] is the inverse of a function [f]: *)
Definition inverse{A B: Type}(f: A -> B)(g: B -> A): Prop := g ∘ f = id.

(* Hint: In the following, it might be helpful to use the following fact:
   If two functions return the same value for all inputs, they are the same. *)
Check @FunctionalExtensionality.functional_extensionality.
(* Aside: I called it a "fact" above, but logicians disagree about whether
   we should believe this or not -- maybe you remember Adam's argument from
   class that even if merge sort and bubble sort return the same result for
   all inputs, they are two different things.
   Therefore, this "fact" is not actually built into Coq's kernel, but it's
   an axiom written down in the standard library, and if you believe in it,
   you can import it (the Frap library already does so).
   In any case, it is consistent with the rest of Coq's logic, i.e. by
   assuming this axiom, you will not be able to prove False, so we're safe.*)

(* Let's make a shorthand for this: *)
Definition fun_ext := @FunctionalExtensionality.functional_extensionality.

(* Here's an example: The function which subtracts two from its argument
   is the inverse of the function which adds two to its argument. *)
Example plus2minus2: inverse (fun (x: nat) => x + 2) (fun (x: nat) => x - 2).
Proof.
Admitted.

(* On the other hand, note that the other direction does not hold, because
   if a subtraction on natural numbers underflows, it just returns 0, so
   there are several [x] for which [x-2] returns 0 (namely 0, 1, and 2),
   so it can't have an inverse. *)
Example minus2plus2: ~ inverse (fun (x: nat) => x - 2) (fun (x: nat) => x + 2).
Proof.
Admitted.

(* The identity function is the inverse of itself.
   Note: we're using "@" in front of "id" to say "we want to provide all implicit
   type arguments explicitly, because otherwise Coq would not be able to infer them." *)
Lemma inverse_id: forall A, inverse (@id A) (@id A).
Proof.
Admitted.

(* Now we can start proving interesting facts about inverse functions:
   If g is the inverse of f, then [map g] is the inverse of [map f]: *)
Lemma invert_map : forall A B (f: A -> B) (g: B -> A),
    inverse f g ->
    inverse (map f) (map g).
Proof.
Admitted.

(* And here's how to invert the power function: *)
Lemma invert_selfCompose{A: Type}: forall (f g: A -> A) (n: nat),
    inverse f g ->
    inverse (selfCompose f n) (selfCompose g n).
Proof.
Admitted.

(** ****** Optional exercises ******  *)

(* Everything below this line is optional! *)

(* You've reached the end of the problem set. Congrats!
 *
 * If you're up for a completely optional additional challenge,
 * try defining a left-biased merge function below that merges two
 * binary tries, preferring map entries from the first binary trie
 * when an entry exists for both binary tries. Then prove
 * [lookup_left_biased_merge], which formally states that lookups
 * on the merged binary trie operate in exactly this manner.
 *
 * If you don't want to complete this additional challenge, you
 * can just leave everything below unmodified.
 *)

Fixpoint left_biased_merge {A} (t t' : binary_trie A) : binary_trie A. Admitted.

Theorem lookup_left_biased_merge {A} (k : list bool) (t t' : binary_trie A) :
  lookup k (left_biased_merge t t') = either (lookup k t) (lookup k t').
Proof.
Admitted.

(* And here are a few more optional exercises about [fold]: *)

(* [fold] is a higher-order function that is even more general
 * than [map]. In essence, [fold f z] takes as input a list
 * and produces a term where the [cons] constructor is
 * replaced by [f] and the [nil] constructor is replaced
 * by [z].
 *
 * [fold] is a "right" fold, which associates the binary operation
 * the opposite way as the [fold_left] function that we defined
 * in lecture.
 *)
Fixpoint fold {A B : Type} (b_cons : A -> B -> B) (b_nil : B)
         (xs : list A) : B :=
  match xs with
  | nil => b_nil
  | cons x xs' => b_cons x (fold b_cons b_nil xs')
  end.

(* For instance, we have
       fold plus 10 [1; 2; 3]
     = 1 + (2 + (3 + 10))
     = 16
 *)
Example fold_example : fold plus 10 [1; 2; 3] = 16.
Proof.
  simplify.
  equality.
Qed.

(* Prove that [map] can actually be defined as a particular
 * sort of [fold].
 *)
Lemma map_is_fold : forall {A B : Type} (f : A -> B) (xs : list A),
    map f xs = fold (fun x ys => cons (f x) ys) nil xs.
Proof.
Admitted.

(* Since [fold f z] replaces [cons] with [f] and [nil] with
 * [z], [fold cons nil] should be the identity function.
 *)
Theorem fold_id : forall {A : Type} (xs : list A),
    fold cons nil xs = xs.
Proof.
Admitted.

(* If we apply [fold] to the concatenation of two lists,
 * it is the same as folding the "right" list, and using
 * that as the starting point for folding the "left" list.
 *)
Theorem fold_append : forall {A : Type} (f : A -> A -> A) (z : A)
                             (xs ys : list A),
    fold f z (xs ++ ys) = fold f (fold f z ys) xs.
Proof.
Admitted.

(* Using [fold], define a function that computes the
 * sum of a list of natural numbers.
 *)
Definition sum : list nat -> nat. Admitted.

Example sum_example : sum [1; 2; 3] = 6.
Proof.
Admitted.

(* Using [fold], define a function that computes the
 * conjunction of a list of Booleans (where the 0-ary
 * conjunction is defined as [true]).
 *)
Definition all : list bool -> bool. Admitted.

Example all_example : all [true; false; true] = false.
Proof.
Admitted.

(* The following two theorems, [sum_append] and [all_append],
 * say that the sum of the concatenation of two lists
 * is the same as summing each of the lists first and then
 * adding the result.
 *)
Theorem sum_append : forall (xs ys : list nat),
    sum (xs ++ ys) = sum xs + sum ys.
Proof.
Admitted.

Theorem all_append : forall (xs ys : list bool),
    all (xs ++ ys) = andb (all xs) (all ys).
Proof.
Admitted.

(* Using [fold], define a function that composes a list of functions,
 * applying the *last* function in the list *first*.
 *)
Definition compose_list {A : Type} : list (A -> A) -> A -> A. Admitted.

Example compose_list_example :
  compose_list [fun x => x + 1; fun x => x * 2; fun x => x + 2] 1 = 7.
Proof.
Admitted.

(* Show that [sum xs] is the same as converting each number
 * in the list [xs] to a function that adds that number,
 * composing all of those functions together, and finally
 * applying that large composed function to [0].
 * Note that function [plus], when applied to just one number as an
 * argument, returns a function over another number, which
 * adds the original argument to it!
 *)
Theorem compose_list_map_add_sum : forall (xs : list nat),
    compose_list (map plus xs) 0 = sum xs.
Proof.
Admitted.


From UT Require Import Prelims Setoid Typoid TypoidFunction TypoidNT.
Require Import Coq.Classes.CRelationClasses.
Require Import FunctionalExtensionality.

(** typoid of typoid functions *)
Definition ExponentialTypoid {A B: Type} (TA: Typoid A) (TB: Typoid B):
  Typoid (TypoidFunction TA TB).
Proof. unshelve econstructor.
       - unshelve econstructor.
         + intros F G.
           exact (TypoidNT F G).
         + intro f.
           exact (IdNT f).
         + cbn. intros f g h F G.
           exact (ComposeNT A B TA TB f g h F G).
         + cbn. intros f g F.
           specialize (fmap_pinv f); intros finv.
           destruct f as (f, fmapf, fid, fcomp, fp, fR).
           specialize (fmap_pinv g); intros ginv.
           destruct g as (g, fmapg, gid, gcomp, gp, gR).
           destruct F as (trans, nt, FP).
           unshelve econstructor.
           ++ intro x.
              exact (inv (trans x)).
           ++ cbn. intros.
              pose proof nt as nt'.
              cbn in *.
              specialize (nt _ _  (inv e)).
              rewrite finv, ginv in nt.
              assert (fmapf x y e o inv (fmapf x y e) o trans x ==
                      fmapf x y e o trans y o inv (fmapg x y e)).
              { rewrite !Typ3, nt. easy. }
              rewrite Typ2_i, Typ1_i in X.
              rewrite X.
              rewrite !Typ5.
              do 2 rewrite Typ3.
              now rewrite Typ2_ii, Typ1_ii, Typ6.
           ++ repeat intro. unfold CMorphisms.Proper.
              easy.
       - unfold crelation. intros F G nt1 nt2.
         exact (forall a, trans nt1 a == trans nt2 a).
       - intros F G e.
         easy.
       - intros F G e d.
         intros p a. cbn in p. now rewrite p.
       - intros F G e d r.
         intros p q a. cbn in p, q.
         now rewrite p, q.
       - intros F G e.
         intro a.
         destruct F, G, e. cbn.
         now rewrite Typ1_i.
       - intros F G e.
         intro a.
         destruct F, G, e. cbn.
         now rewrite Typ1_ii.
       - intros F G e.
         intro a.
         destruct F, G, e. cbn.
         now rewrite Typ2_i.
       - intros F G e.
         intro a.
         destruct F, G, e. cbn.
         now rewrite Typ2_ii.
       - intros F G H I e1 e2 e3.
         intro a.
         destruct F, G, H, I, e1, e2, e3. cbn.
         now rewrite Typ3.
       - intros F G H e1 d1 e2 d2.
         intros p q a.
         destruct F, G, H, I, e1, d1, e2, d2. cbn.
         specialize (p a). cbn in p.
         specialize (q a). cbn in q.
         now rewrite p, q.
       - repeat intro. destruct x, y, z.
         cbn in x0, x1, y0, y1.
         destruct x0, y0, x1, y1.
         cbn in *.
         now rewrite (X a), (X0 a).
       - repeat intro. destruct x.
         now cbn.
       - repeat intro. destruct y, x.
         destruct x0, y0.
         cbn in *.
         now rewrite (X a).
Defined.

(** The Evaluation functor *)
Definition EvalF {A B: Type}
                 (TA: Typoid A)
                 (TB: Typoid B): TypoidFunction (ProductTypoid (ExponentialTypoid TA TB) TA) TB.
Proof. unshelve econstructor.
       - intros (F, a). exact (fobj F a).
       - intros (F, a) (G, b) (nt1, f).
         cbn in *.
         exact ((fmap F f) o (trans nt1 b)).
       - intros (F, a). destruct F. cbn.
         now rewrite fmap_pid, Typ1_i.
       - intros (F, a) (G, b) (H, c) e1 e2. cbn in e1, e2.
         destruct e1 as (nt1, f).
         destruct e2 as (nt2, g). cbn. destruct F, G, H. cbn.
         destruct nt1, nt2. cbn in *.
         rewrite fmap_pcomp. rewrite Typ3. setoid_rewrite <- Typ3 at 2.
         rewrite trans_cc. now do 2 rewrite Typ3.
       - intros (F, a) (G, b) e d i.
         cbn in e, d.
         destruct e as (nt1, f).
         destruct d as (nt2, g).
         destruct i as (i, j).
         rewrite j. destruct nt1, nt2. cbn in *.
         now rewrite (i b).
       - repeat intro.
         destruct x as (F, a).
         destruct y as (G, b).
         destruct x0, y0.
         destruct X. cbn in *. now rewrite (e3 b), e4.
Defined.

(** The Curry functor *)
Definition CurryF {A B C: Type}
                   {TA: Typoid A}
                   {TB: Typoid B}
                   {TC: Typoid C}
                   (F: TypoidFunction (ProductTypoid TC TA) TB):
  TypoidFunction TC (ExponentialTypoid TA TB).
Proof. unshelve econstructor.
        - intro c. exact (FixBiF1 c F).
        - intros a b h.
          exact (FixBiNT1 F a b h).
        - simpl. intros. rewrite fmap_pid. easy.
        - cbn. intros.
          rewrite <- fmap_pcomp.
          destruct F. cbn in *.
          rewrite fmap_p. easy.
          split.
          + easy.
          + now rewrite Typ1_i.
        - intros x y e d p.
          cbn. destruct F. cbn in *.
          intro a. rewrite fmap_p. easy.
          split; easy.
        - repeat intro.
          destruct F. cbn in *.
          rewrite fmap_p. easy.
          split.
          + now rewrite X.
          + easy.
Defined.