Require Import FormalMath.lib.Sets_ext.
Require Import Coq.Logic.Description.

Inductive invertible {X Y: Type} (f: X -> Y): Prop :=
| invertible_intro: forall g: Y -> X,
    (forall x: X, g (f x) = x) -> (forall y: Y, f (g y) = y) -> invertible f.

Inductive FiniteT: Type -> Prop :=
| empty_finite: FiniteT False
| add_finite: forall T: Type, FiniteT T -> FiniteT (option T)
| bij_finite: forall (X Y:Type) (f: X -> Y), FiniteT X -> invertible f -> FiniteT Y.

Lemma True_finite: FiniteT True.
Proof.
  apply bij_finite with (option False) (fun _ => I). 1: constructor; constructor.
  exists (True_rect None).
  - intros. destruct x. 1: easy. remember (True_rect None I) as LHS.
    destruct LHS; easy.
  - exact (fun y: True => match y with | I => refl_equal I end).
Qed.

Lemma finite_dep_choice: forall (A: Type) (B: forall x: A, Type)
                                (R: forall x: A, B x -> Prop),
    FiniteT A -> (forall x: A, exists y: B x, R x y) ->
    exists f: (forall x: A, B x), forall x: A, R x (f x).
Proof.
  intros. revert B R H0. induction H; intros.
  - exists (fun x: False => False_rect (B x) x). destruct x.
  - pose proof (IHFiniteT (fun x: T => B (Some x)) (fun x: T => R (Some x))
                          (fun x: T => H0 (Some x))). destruct H1.
    pose proof (H0 None). destruct H2.
    exists (fun y:option T => match y return (B y) with
                              | Some y0 => x y0 | None => x0 end). destruct x1.
    apply H1. assumption.
  - destruct H0. pose proof (IHFiniteT (fun x: X => B (f x)) (fun x: X => R (f x))
                                       (fun x: X => H1 (f x))). destruct H3.
    pose (f0 := fun y: Y => x (g y)).
    pose (conv := fun (y: Y) (a: B (f (g y))) => eq_rect (f (g y)) B a y (H2 y)).
    exists (fun y:Y => conv y (x (g y))). intro. unfold conv; simpl.
    generalize (H2 x0). pattern x0 at 2 3 6. rewrite <- H2. intro.
    rewrite <- eq_rect_eq. apply H3.
Qed.

Lemma finite_choice:  forall (A B: Type) (R: A -> B -> Prop),
    FiniteT A -> (forall x: A, exists y: B, R x y) ->
    exists f: A -> B, forall x: A, R x (f x).
Proof. intros. now apply finite_dep_choice. Qed.

Lemma exclusive_dec: forall P Q: Prop, ~(P /\ Q) -> (P \/ Q) -> {P} + {Q}.
Proof.
  intros. assert ({x: bool | if x then P else Q}). {
    apply constructive_definite_description. case H0.
    - exists true. red; split; auto. destruct x'; tauto.
    - exists false. red; split; auto. destruct x'; tauto. }
  destruct H1. destruct x; [left | right]; easy.
Qed.

Lemma EqDec_Finite_FiniteT: forall {X:Type} (S: Ensemble X),
    (forall a b: X, {a = b} + {a <> b}) -> Finite S -> FiniteT {x: X | In S x}.
Proof.
  intros. induction H.
  - apply bij_finite with False (False_rect _). 1: constructor.
    assert (g: {x:X | In Empty_set x} -> False). {
      intro. destruct X1. destruct i. } exists g.
    + destruct x.
    + destruct y. destruct g.
  - assert (Included A (Add A x)) by auto with sets.
    assert (In (Add A x) x) by auto with sets.
    pose (g := fun (y: option {x: X | In A x}) =>
                 match y return {x0: X | In (Add A x) x0} with
                 | Some (exist _ y0 i) =>
                   exist (fun x2: X => In (Add A x) x2) y0 (H1 y0 i)
                 | None => exist (fun x2: X => In (Add A x) x2) x H2
                 end). apply bij_finite with _ g.
    + now apply add_finite.
    + assert (h:forall x0:X, In (Add A x) x0 -> { In A x0 } + { x0 = x }). {
        clear -X0. intros. destruct (X0 x0 x). 1: right; auto. left.
        destruct H; auto. inversion H. now subst. }
      pose (ginv := fun s:{x0: X | In (Add A x) x0} =>
                      match s return option {x: X | In A x} with
                      | exist _ x0 i => match (h x0 i) with
                                        | left iA => Some (exist _ x0 iA)
                                        | right _ => None
                                        end
                      end). exists ginv.
      * intro; destruct x0.
        -- destruct s. simpl. remember (h x0 (H1 x0 i)) as sum; destruct sum.
           ++ now destruct (proof_irrelevance _ i i0).
           ++ now subst x0.
        -- simpl. remember (h x H2) as sum; destruct sum; easy.
      * intro. unfold ginv. destruct y. destruct (h x0 i); simpl.
        -- generalize (H1 x0 i0); intro. now destruct (proof_irrelevance _ i i1).
        -- destruct e. now destruct (proof_irrelevance _ H2 i).
Qed.

Lemma Finite_FiniteT: forall {X:Type} (S:Ensemble X),
    Finite S -> FiniteT {x: X | In S x}.
Proof.
  intros. induction H.
  - apply bij_finite with False (False_rect _). 1: constructor.
    assert (g: {x:X | In Empty_set x} -> False). {
      intro. destruct X0. destruct i. } exists g.
    + destruct x.
    + destruct y. destruct g.
  - assert (Included A (Add A x)) by auto with sets.
    assert (In (Add A x) x) by auto with sets.
    pose (g := fun (y: option {x: X | In A x}) =>
                 match y return {x0: X | In (Add A x) x0} with
                 | Some (exist _ y0 i) =>
                   exist (fun x2: X => In (Add A x) x2) y0 (H1 y0 i)
                 | None => exist (fun x2: X => In (Add A x) x2) x H2
                 end). apply bij_finite with _ g.
    + now apply add_finite.
    + assert (h:forall x0:X, In (Add A x) x0 -> { In A x0 } + { x0 = x }). {
        clear -H0. intros; apply exclusive_dec.
        - intuition. subst; auto.
        - destruct H. 1: now left. inversion H. now right. }
      pose (ginv := fun s:{x0: X | In (Add A x) x0} =>
                      match s return option {x: X | In A x} with
                      | exist _ x0 i => match (h x0 i) with
                                        | left iA => Some (exist _ x0 iA)
                                        | right _ => None
                                        end
                      end). exists ginv.
      * intro; destruct x0.
        -- destruct s. simpl. remember (h x0 (H1 x0 i)) as sum; destruct sum.
           ++ now destruct (proof_irrelevance _ i i0).
           ++ now subst x0.
        -- simpl. remember (h x H2) as sum; destruct sum; easy.
      * intro. unfold ginv. destruct y. destruct (h x0 i); simpl.
        -- generalize (H1 x0 i0); intro. now destruct (proof_irrelevance _ i i1).
        -- destruct e. now destruct (proof_irrelevance _ H2 i).
Qed.

Lemma finite_or_exists: forall (X:Type) (P: X -> Prop),
    FiniteT X -> (forall x:X, (P x) \/ (~ P x)) ->
    (exists x:X, P x) \/ (forall x:X, ~ P x).
Proof.
  intros. revert P H0. induction H.
  - right. destruct x.
  - intros. case (IHFiniteT (fun x:T => P (Some x)) (fun x:T => H0 (Some x))).
    + left. destruct H1. exists (Some x). assumption.
    + intro. case (H0 None).
      * left. exists None. assumption.
      * right. destruct x.
        -- apply H1.
        -- assumption.
  - destruct H0. intros.
    case (IHFiniteT (fun x:X => P (f x)) (fun x:X => H2 (f x))).
    + left. destruct H3. exists (f x). assumption.
    + right. intro. rewrite <- H1 with x. apply H3.
Qed.

Lemma FiniteT_img: forall (X Y:Type) (f:X->Y),
    FiniteT X -> (forall y1 y2:Y, y1=y2 \/ y1<>y2) ->
    Finite (Im Full_set f).
Proof.
  intros. induction H.
  - replace (Im Full_set f) with (@Empty_set Y). 1: constructor.
    apply Extensionality_Ensembles; split; red; intros; destruct H. destruct x.
  - assert ((exists x:T, f (Some x) = f None) \/ (forall x:T, f (Some x) <> f None)).
    + apply finite_or_exists; auto.
    + case H1.
      * intro. pose (g := fun (x:T) => f (Some x)).
        replace (Im Full_set f) with (Im Full_set g). 1: apply IHFiniteT.
        apply Extensionality_Ensembles; split; red; intros.
        -- destruct H3. subst. exists (Some x); easy.
        -- destruct H3. subst. destruct x.
           ++ exists t; easy.
           ++ destruct H2. exists x.
              ** constructor.
              ** destruct H3. subst g. symmetry. assumption.
      * intros. pose (g := fun x:T => f (Some x)).
        replace (Im Full_set f) with (Add (Im Full_set g) (f None)).
        -- constructor.
           ++ apply IHFiniteT.
           ++ red; intro. destruct H3. contradiction (H2 x). symmetry; assumption.
        -- apply Extensionality_Ensembles; split; red; intros.
           ++ red; intros. destruct H3, H3; [exists (Some x) | exists None]; easy.
           ++ red; intros. destruct H3. destruct x.
              ** left. exists t; easy.
              ** right. auto with sets.
  - pose (g := fun (x:X) => f (f0 x)).
    replace (Im Full_set f) with (Im Full_set g). 1: apply IHFiniteT.
    apply Extensionality_Ensembles; split; red; intros.
    + destruct H2. exists (f0 x); easy.
    + destruct H2, H1. subst. rewrite <- H4 with x. now exists (g0 x).
Qed.


Require Import Bool.

Inductive bool :=
| true
| false.

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

Theorem negb_negb: forall (b : bool), negb (negb b) = b.
Proof.
  intros b.
  destruct b.
  + simpl. reflexivity.
  + simpl. reflexivity.
Qed.

Theorem negb_trice : forall (b : bool), negb (negb (negb b)) = negb b.
Proof.
  intros b.
  destruct b.
  + simpl. reflexivity.
  + simpl. reflexivity.
Qed.

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

  Theorem and_true_both_arg_true : forall (a b : bool),
  a = true -> b = true ->  andb a b = true.
Proof.
  intros a b Ha Hb.
  rewrite Ha.
  rewrite Hb.
  simpl. reflexivity.
Qed.

Theorem and_true_otherside : forall (a b : bool),
  andb a b = true -> a = true /\ b = true.
Proof.
  intros a b Ha.
  destruct a.
  destruct b.
  split. reflexivity.
  reflexivity.
  split. reflexivity.
  simpl in Ha.
  inversion Ha.
  destruct b.
  simpl in Ha.
  inversion Ha.
  simpl in Ha.
  inversion Ha.
Qed.

Theorem andb_associative : forall (a b c : bool),
  andb a (andb b c) = andb (andb a b) c.
Proof.
  intros [|] [|] [|];
  reflexivity.
Qed.

Theorem andb_comutative : forall a b, andb a b = andb b a.
Proof.
  intros [|] [|]; simpl; reflexivity.
Qed.

Definition orb(a b : bool) : bool :=
  match a, b with
  | false, false => false
  | _, _ => true
  end.

Theorem andb_negb_orb : forall (a b : bool),
  negb (andb a b) = orb (negb a) (negb b).
Proof.
  intros [|] [|]; simpl; reflexivity.
Qed.

Definition material(a b : bool) : bool :=
match a,b with
  | false, true => false
  | _, _ => true
end.

Theorem positive_material : forall a b : bool,
  a = true -> material a b = true.
  Proof.
    intros a b Ha.
    destruct a eqn:E.
    - simpl. destruct b; reflexivity.
    - discriminate Ha.
    Show Proof.
Qed.


Unset Boxed Definitions.
Unset Boxed Values.

Require Export QArith_base.
Require Export Znumtheory.

(* First, a function that (tries to) build a positive back from a Z. *)

Definition Z2P (z : Z) :=
  match z with
  | Z0 => 1%positive
  | Zpos p => p
  | Zneg p => p
  end.

Lemma Z2P_correct : forall z : Z, (0 < z)%Z -> Zpos (Z2P z) = z.
Proof.
 simple destruct z; simpl in |- *; auto; intros; discriminate.
Qed.

Lemma Z2P_correct2 : forall z : Z, 0%Z <> z -> Zpos (Z2P z) = Zabs z.
Proof.
 simple destruct z; simpl in |- *; auto; intros; elim H; auto.
Qed.

(* Simplification of fractions using the Zgcd. *)

Definition Qred (q : Q) :=
  let (q1, q2) := q in
  let g := Zgcd (Zpos q2) q1 in (q1 / g)#(Z2P (Zpos q2 / g)).

Lemma Qred_correct : forall q, (Qred q) == q.
intros (n, d); unfold Qred, Qeq in |- *; simpl in |- *.
unfold Zgcd in |- *; case (Zgcd_spec (Zpos d) n); intros g.
intuition.
elim H; intros.
assert (0%Z <> g).
  intro.
  elim H1; intros.
  rewrite <- H4 in H5.
  rewrite Zmult_comm in H5; inversion H5.

assert (0 < Zpos d / g)%Z.
  apply Zmult_gt_0_lt_0_reg_r with g.
  omega.
  rewrite Zmult_comm.
  rewrite <- Z_div_exact_2; auto with zarith.
  compute in |- *; auto.
  apply Zdivide_mod; auto with zarith.
rewrite Z2P_correct; auto.
pattern n at 2 in |- *.
rewrite (Z_div_exact_2 n g); try apply Zdivide_mod; auto with zarith.
pattern d at 2 in |- *.
rewrite (Z_div_exact_2 (Zpos d) g); try apply Zdivide_mod; auto with zarith.
ring.
Qed.

Lemma Qred_complete : forall p q,  p==q -> Qred p = Qred q.
intros (a, b) (c, d); unfold Qeq in |- *; simpl in |- *.
unfold Zgcd in |- *; case (Zgcd_spec (Zpos b) a); intros g (Hg1, Hg2).
unfold Zgcd in |- *; case (Zgcd_spec (Zpos d) c); intros g' (Hg'1, Hg'2).
intros.
inversion Hg1.
inversion Hg'1.
assert (g <> 0%Z).
  intro.
  elim H0; intros.
  subst g.
  rewrite Zmult_comm in H7; inversion H7.
assert (g' <> 0%Z).
  intro.
  elim H3; intros.
  subst g'.
  rewrite Zmult_comm in H8; inversion H8.
rewrite (Z_div_exact_2 a g) in H; try apply Zdivide_mod; auto with zarith.
rewrite (Z_div_exact_2 (Zpos d) g') in H; try apply Zdivide_mod;
 auto with zarith.
rewrite (Z_div_exact_2 (Zpos b) g) in H; try apply Zdivide_mod;
 auto with zarith.
rewrite (Z_div_exact_2 c g') in H; try apply Zdivide_mod; auto with zarith.
elim (rel_prime_cross_prod (a / g) (Zpos b / g) (c / g') (Zpos d / g')).
intros.
rewrite H8; rewrite H9; auto.
unfold rel_prime in |- *; apply Zis_gcd_rel_prime; auto with zarith.
unfold rel_prime in |- *; apply Zis_gcd_rel_prime; auto with zarith.
apply Zmult_gt_0_reg_l with g.
omega.
rewrite <- Z_div_exact_2; try apply Zdivide_mod; auto with zarith.
apply Zmult_gt_0_reg_l with g'.
omega.
rewrite <- Z_div_exact_2; try apply Zdivide_mod; auto with zarith.
apply Zmult_reg_l with (g * g')%Z.
intro; elim (Zmult_integral _ _ H8); auto.
replace (g * g' * (a / g * (Zpos d / g')))%Z with
 (g * (a / g) * (g' * (Zpos d / g')))%Z.
rewrite H.
ring.
ring.
Qed.

Add Morphism Qred : Qred_comp.
intros q q' H.
setoid_rewrite (Qred_correct q); auto.
setoid_rewrite (Qred_correct q'); auto.
Qed.

Definition Qplus' (p q : Q) := Qred (Qplus p q).
Definition Qmult' (p q : Q) := Qred (Qmult p q).

Definition Qplus'_correct : forall p q : Q, Qeq (Qplus' p q) (Qplus p q).
intros; unfold Qplus' in |- *; apply Qred_correct; auto.
Qed.

Definition Qmult'_correct : forall p q : Q, Qeq (Qmult' p q) (Qmult p q).
intros; unfold Qmult' in |- *; apply Qred_correct; auto.
Qed.

Add Morphism Qplus' : Qplus'_comp.
intros; unfold Qplus' in |- *.
setoid_rewrite H; setoid_rewrite H0; auto with qarith.
Qed.

Add Morphism Qmult' : Qmult'_comp.
intros; unfold Qmult' in |- *.
setoid_rewrite H; setoid_rewrite H0; auto with qarith.
Qed.


From mathcomp Require Import ssreflect.

Require Import relation.
Require Import axiom_of_empty.
Require Import axiom_of_pair.
Require Import axiom_of_union.

Axiom AxiomOfReplacement:
  forall {U:Type}, forall {R:RelationLogicFunction U U},
      (forall {x y z:U}, ((R x y /\ R x z) -> y = z)) ->
      forall {x': Collection U}, exists y':(Collection U), forall z:U, ( z ∈ y' <-> exists w:U, w ∈ x' /\ R w z ).

Section AxiomOfSeparationFromAxiomOfReplacement.
  Variable U:Type.
  Variable F: LogicFunction U.
  Definition P: RelationLogicFunction U U := fun x y => F x /\ x = y.

  Lemma PisUniuqe: forall {x y z:U}, P x y /\ P x z -> y = z.
  Proof.
    move => x y z.
    case => HP1 HP2.
    have L1: forall x y z : U, y = x /\ z = x -> y = z.
    move => x1 y1 z1.
    case => H0 H1.
    rewrite H0 H1.
    reflexivity.
    apply (L1 x y z).
    suff: x = y /\ x = z.
    case => H0 H1.
    split; [rewrite H0| rewrite H1]; reflexivity.
    suff: (F x /\ x = y) /\ (F x /\ x = z).
    case => H0 H1.
    split; [case H0 => H2 H3|case H1 => H2 H3]; by[].
    split; by [].
  Qed.

  Theorem IntroAxiomOfSparation:
    (forall {x': Collection U}, exists y':(Collection U), forall z:U,
          ( z ∈ y' <-> exists w:U, w ∈ x' /\ P w z )) ->
    (forall {x': Collection U}, exists y':(Collection U), forall z:U,
            ( z ∈ y' <-> z ∈ x' /\ F z )).
  Proof.
    have L1: forall x': Collection U, forall y:U, (exists x:U, ( x ∈ x' /\ P x y )) <->
                                                    y ∈ x' /\ F y.
    move => x' y.
    rewrite /iff. split.
    case => x.
    case => Hx.
    case => HFx Hxy.
    split; rewrite -Hxy. by []. by [].
    case => Hyx HFy.
    exists y.
    split.
    apply Hyx.
    split. by[]. reflexivity.
    move => HAF.
    move => x'.
    move: (L1 x') => L1x'.
    move: (HAF x') => HAFx'.
    case HAFx'.
    move => w' HAF0.
    exists w' => z.
    move: (HAF0 z) => HAF0z.
    move: (L1x' z) => L1x'z.
    split.
    move => H.
    apply L1x'z.
    apply HAF0z. by [].
    case => H0 H1.
    apply HAF0z.
    apply L1x'z.
    split; by [].
  Qed.

End AxiomOfSeparationFromAxiomOfReplacement.

Inductive CollectionSparation (U:Type) (F:LogicFunction U) : Collection U :=
| intro_collection_sparation: forall x:U, F x -> x ∈ CollectionSparation U F.

Notation "{| : U | F |}" := (CollectionSparation U F).

Inductive IntersectionOfCollection {U:Type} (A B:Collection U): Collection U :=
| intro_intersection_of_collection: forall x:U, x ∈ A -> x ∈ B -> x ∈ IntersectionOfCollection A B
where "A ∩ B" := (IntersectionOfCollection A B).

Inductive BigCapOfCollection {U:Type} (A': Collection (Collection U)): Collection U :=
| intro_bigcap_of_collection: forall x:U, (forall X:Collection U, X ∈ A' -> x ∈ X) -> x ∈ BigCapOfCollection A'
where  "⋂ X" := (BigCapOfCollection X).

Inductive CollectionMinus {U:Type} (A B:Collection U): Collection U :=
| intro_collection_minus: forall x:U, x ∈ A -> x ∉ B -> x ∈ CollectionMinus A B
where "A \ B" := (CollectionMinus A B).

Theorem in_intersection_to_in_and:
  forall U:Type, forall x:U, forall {A B:Collection U}, x ∈ A ∩ B -> x ∈ A /\ x ∈ B.
Proof.
  move => U x A B.
  case => x0 HA HB.
  split; by [].
Qed.

Theorem in_and_to_in_intersection:
    forall U:Type, forall x:U, forall {A B:Collection U}, x ∈ A /\ x ∈ B -> x ∈ A ∩ B.
Proof.
  move => U x A B.
  case => HA HB.
  split; by [].
Qed.

Theorem in_intersection_iff_in_and:
  forall U:Type, forall x:U, forall {A B:Collection U}, x ∈ A ∩ B <-> x ∈ A /\ x ∈ B.
Proof.
  move => U x A B.
  rewrite /iff. split.
  apply in_intersection_to_in_and.
  apply in_and_to_in_intersection.
Qed.

Theorem triple_in_and_to_in_intersection:
  forall U:Type, forall x:U, forall {A B C:Collection U}, x ∈ A /\ x ∈ B /\ x ∈ C -> x ∈ A ∩ B ∩ C.
Proof.
  move => U x A B C.
  case => HA HBC.
  split. by [].
  apply in_and_to_in_intersection.
  by [].
Qed.

Theorem triple_in_intersection_to_in_and:
  forall U:Type, forall x:U, forall {A B C:Collection U}, x ∈ A ∩ B ∩ C -> x ∈ A /\ x ∈ B /\ x ∈ C.
Proof.
  move => U x A B C.
  case => x0 HA HBC.
  split. by [].
  apply in_intersection_iff_in_and in HBC. by [].
Qed.

Section IntersectionTest.
  Variable U:Type.
  Variable A B C:Collection U.
  Definition AndFunc A B := fun x:U => x ∈ A /\ x ∈ B.
  Definition DiffFunc A B := fun x:U => x ∈ A /\ x ∉ B.

  Goal {| : U | (AndFunc A B) |} = A ∩ B.
  Proof.
    apply mutally_included_iff_eq.
    split => x; case => x0.
    case => H0 H1.
    split; [apply H0 | apply H1].
    move => H0 H1.
    split.
    split; by [].
  Qed.

  Goal ⋂ (| A , B |) = A ∩ B.
  Proof.
    apply mutally_included_iff_eq.
    split => x; case => x0.
    move => H.
    move: (H A) (H B) => HA HB.
    split; [apply HA; left|apply HB; right].
    move => HA HB.
    apply: (intro_bigcap_of_collection (|A , B|)) => X.
    case; by [].
  Qed.

  Goal ⋂ {| A, B, C |} = A ∩ B ∩ C.
  Proof.
    apply mutally_included_iff_eq.
    split => x.
    case => x0 H.
    split.
    apply H. left. left. apply singleton_iff_eq. reflexivity.
    split; apply H.
    left. right. apply singleton_iff_eq. reflexivity.
    right. apply singleton_iff_eq. reflexivity.
    case => x0 HA HBC.
    split => X HABC.
    apply triple_ext_notation_iff_or_eq in HABC.
    case HABC => HAeq.
    rewrite HAeq. by [].
    apply in_intersection_iff_in_and in HBC.
    case: HBC => HB HC.
    case: HAeq => H; rewrite H; by [].
  Qed.

  Goal {| : U | (DiffFunc A B) |} = A \ B.
  Proof.
    apply mutally_included_iff_eq.
    split => x.
    case => x0.
    case => HA HNB.
    split; by[].
    case => x0 HA HNB.
    split. split; by [].
  Qed.

End IntersectionTest.

Theorem LawOfIdempotenceAtIntersection:
  forall U:Type, forall {X:Collection U}, X = X ∩ X.
Proof.
  move => U X.
  apply mutally_included_iff_eq.
  split => x.
  move => H. split; by [].
  case. exact.
Qed.

Theorem LawOfCommutativeAtIntersection:
  forall U:Type, forall {X Y:Collection U}, X ∩ Y = Y ∩ X.
Proof.
  move => U X Y.
  apply mutally_included_iff_eq.
  split => x H; apply in_intersection_iff_in_and ;apply in_intersection_iff_in_and in H; apply and_comm; by [].
Qed.

Theorem LawOfAssociateAtIntersection:
  forall U:Type, forall {A B C:Collection U}, (A ∩ B) ∩ C = A ∩ (B ∩ C).
Proof.
  move => U A B C.
  apply mutally_included_iff_eq.
  split => x.
  case => x0 HAB HC.
  apply in_intersection_iff_in_and in HAB.
  case HAB => HA HB.
  split. by [].
  split; by [].
  move => HABC.
  apply triple_in_intersection_to_in_and in HABC.
  case: HABC => HA.
  case => HB HC.
  split. split; by []. by [].
Qed.

Theorem no_intersection_empty:
  forall (U:Type), forall (A:Collection U), ( A ∩ `Ø` ) = `Ø`.
Proof.
  move => U A.
  apply mutally_included_iff_eq.
  split => x.
  case => x0. exact.
  case.
Qed.

Theorem collection_and_fullcollection_eq_collection:
  forall (U:Type), forall (A:Collection U), ( A ∩ (FullCollection U) ) = A.
Proof.
  move => U A.
  apply mutally_included_iff_eq.
  split => x.
  case => x0 HA HF. by [].
  move => HA.
  split. by [].
  move: HA.
  apply collection_is_subcollect_of_fullcollection.
Qed.

Definition CoPrimeAtCollection (U:Type) (A B:Collection U) := A ∩ B = `Ø`.

Theorem coprime_complement:
  forall U:Type, forall A:Collection U, CoPrimeAtCollection U A (A^c).
Proof.
  move => U A.
  apply mutally_included_iff_eq.
  split => x H.
  apply in_intersection_iff_in_and in H.
  case: H => H.
  case. by [].
  apply in_intersection_iff_in_and.
  split; move: H; apply all_collection_included_empty.
Qed.

Theorem intersection_to_subcollect:
  forall U:Type, forall A B:Collection U, A ∩ B = A -> A ⊂ B.
Proof.
  move => U A B H.
  rewrite -H => x.
  move => H0.
  apply in_intersection_iff_in_and in H0.
  case H0 => H1. exact.
Qed.

Theorem subcollect_to_intersection:
  forall U:Type, forall A B:Collection U, A ⊂ B -> A ∩ B = A.
Proof.
  move => U A B H.
  apply mutally_included_to_eq.
  split => x.
  case => x0 HA HB. by [].
  move => H0.
  split; [by []|apply H; by []].
Qed.

Theorem intersection_iff_subcollect:
  forall U:Type, forall A B:Collection U, A ∩ B = A <-> A ⊂ B.
Proof.
  move => U A B.
  rewrite /iff. split.
  apply: intersection_to_subcollect.
  apply: subcollect_to_intersection.
Qed.

Theorem coprime_to_intersection_complement_and_other:
  forall U:Type, forall A B:Collection U,
      CoPrimeAtCollection U A B -> A ∩ B^c = A.
Proof.
  move => U A B H.
  apply mutally_included_to_eq.
  split => x.
  apply in_intersection_iff_in_and.
  move => HA.
  split. by [].
  move: (notin_collect_iff_in_complement U B x) => H0.
  rewrite /iff in H0. case H0 => H1 H2.
  apply H1.
  apply mutally_included_iff_eq in H.
  case: H => HE0 HE1.
  move => HB.
  apply: (noone_in_empty U x).
  apply HE0.
  split; by [].
Qed.

Theorem intersection_complement_and_other_to_coprime:
  forall U:Type, forall A B:Collection U,
      A ∩ B^c = A -> CoPrimeAtCollection U A B.
Proof.
  move => U A B H.
  apply empty_collection_is_noone_in_collection.
  rewrite -H.
  move => x.
  rewrite LawOfAssociateAtIntersection.
  case => x0.
  move => HA.
  rewrite LawOfCommutativeAtIntersection.
  rewrite coprime_complement.
  apply noone_in_empty.
Qed.

Theorem coprime_to_complement_other_included:
  forall U:Type, forall A B:Collection U,
      CoPrimeAtCollection U A B -> A ⊂ B^c.
Proof.
  move => U A B H.
  apply coprime_to_intersection_complement_and_other in H.
  apply intersection_iff_subcollect in H.
    by [].
Qed.

Theorem complement_other_included_to_coprime:
  forall U:Type, forall A B:Collection U,
      A ⊂ B^c -> CoPrimeAtCollection U A B.
Proof.
  move => U A B H.
  apply intersection_complement_and_other_to_coprime.
  apply intersection_iff_subcollect in H.
    by [].
Qed.

Goal
  forall (U:Type) (A B:Collection U), A \ B = A ∩ B^c.
Proof.
  move => U A B.
  apply mutally_included_to_eq.
  split => x H; inversion H; split; by [].
Qed.


Require Import Setoid.
Require Import Common.

Set Implicit Arguments.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section Gen.
  Variable A : Type.
  Variable equiv : relation A.

  Inductive EquivalenceOf : A -> A -> Prop :=
  | gen_underlying : forall a b, equiv a b -> EquivalenceOf a b
  | gen_refl : forall a, EquivalenceOf a a
  | gen_sym : forall a b, EquivalenceOf a b -> EquivalenceOf b a
  | gen_trans : forall a b c, EquivalenceOf a b -> EquivalenceOf b c -> EquivalenceOf a c.

  Hint Constructors EquivalenceOf.

  Lemma EquivalenceOf_Equivalence : Equivalence EquivalenceOf.
    constructor; eauto.
  Defined.

  Definition generateEquivalence : { equiv' : A -> A -> Prop | Equivalence equiv' & forall a b, equiv a b -> equiv' a b }.
    exists EquivalenceOf.
    exact EquivalenceOf_Equivalence.
    eauto.
  Defined.
End Gen.

Add Parametric Relation A equiv : _ (@EquivalenceOf A equiv)
  reflexivity proved by (@gen_refl _ _)
  symmetry proved by (@gen_sym _ _)
  transitivity proved by (@gen_trans _ _)
    as EquivalenceOf_rel.


Require Import NArith.
Require Import List.
Require Import smart_common monads.

Inductive term : Type :=
| Var : N -> term
| App : term -> term -> term
| Abs : term -> term.

Fixpoint lifti n t k :=
  match t with
    | Var i => if N.ltb i k then Var i else Var (i + n)
    | Abs t => Abs ( lifti n t (N.succ k))
    | App t u => App (lifti n t k) (lifti n u k)
  end.
Definition lift n t := lifti n t 0.

Fixpoint substi w t n :=
  match t with
      Var k => if N.eqb k n then lift n w else if N.ltb k n then Var k else Var (N.pred k)
    | Abs t => Abs (substi w t (N.succ n))
    | App t u => App (substi w t n) (substi w u n)
  end.
Definition subst u t := substi u t 0.

Definition hnf : nat -> term  -> option (term) :=
  fuel_fix (fun x => term)
           (fun (t:term) hnf =>
              match t with
                | Var n => Some (Var n)
                | Abs t => let! t = hnf (t);
                              retn (Abs t)
                | App t u =>
                  let! t =  hnf (t);
                     match t with
                       | Abs w => hnf (subst u w)
                       | h => retn (App h u)
                     end
              end).

Definition nf big_fuel :=
  fuel_fix (fun x => term)
           (fun (t: term) nf =>
              match t with
                | Var n => Some (Var n)
                | Abs t => let! t = nf (t);
                               retn (Abs t)
                | App t u =>
                  let! t = hnf big_fuel t;
                     match t with
                       | Abs w => let! t = nf (subst u w);
                                     retn t
                       | h => let! h = nf h;
                              let! u = nf u;
                                 retn (App h u)
                     end
              end).

Definition big := 10000.

Definition Nf t := nf big big t.

Notation "\ x" := (Abs x) (at level 20).
Notation "x # y" := (App x y) (left associativity, at level 25).
Coercion Var : N >-> term.

Module T.

Open Scope N.
Definition K := \\1.

Definition false := \\ 0.
Definition true  := \\ 1.
Definition cond  := \\\ (2 # 1 #  0).

Definition pair  := \\\ (0 #  2 #  1).
Definition fst  := \ (0 #  true).
Definition snd  := \ (0 #  false).

Definition zero := \\ 0.
Definition succ := \\\ (1 #  (2 #  1 #  0)).
Definition one  := succ #  zero.

Fixpoint church n := match n with O => zero | S n => (succ #  (church n)) end.

Definition null := \ (0 #  ( K #  false) #  true).

Definition add := \\ \\ (3 #  1 #  (2 #  1 #  0)).
Definition pred :=
  let loop := \ (let pred := fst #  0 in
                 pair #  (succ #  pred) #  pred )
  in \ (snd #  (0 #  loop #  (pair #  zero #  zero))).

Definition geq := \\ (1 #  pred #  0 #  (K #  false) #  true).

Definition iter := \\( 0 #  1 #  (1 #  one)).
Definition ack  := \(0 #  iter #  succ #  0).

Definition Y := \(  (\ (1 #  (0 #  0) ))  #  (\ ( 1 #  ( 0 #  0)))).
Definition FIX := let F := (\\
                    let f := 0 in
                    let x := 1 in
                    (f #  ( x #  x #  f ) )) in F #  F.

Definition SUM :=
  FIX # (\\ ( (cond # (null # 0)) # zero # (add # 0 # (1 # (pred # 0))))).

Definition nil := \\0.
Definition cons := \\ (\\ (1 #  3 #  (2 #  1 #  0))).
Definition isnil := \(0 # (\\ false) # true).
Definition head  := \ (0 # (\\ (1)) # false).
Definition tail  :=
  \(fst # (0 # (\\(pair # (snd # 0)# (cons#1#(snd#0))))#(pair#nil#nil))).

Definition append := \\ \\ (3 #  1 #  (2 #  1 #  0)).

Definition partition :=
  \\
    (let fork :=
         \\
           (
             let pred := 3 in let l := 2 in let x := 1 in let acc := 0 in
             let l1 := fst #  acc in
             let l2 := snd #  acc in
             pred #  x #  (pair #  (cons #  x #  l1) #  l2) #  (pair #  l1 #  (cons #  x #  l2))
           )
     in
     0 #  fork #  (pair #  nil #  nil)
    ).

Definition quicksort' :=
  FIX #  (\
           (let sort :=
               \\
                 (let rec := 3 in let a := 1 in let l := 0 in
                 let p := partition #  (geq #  a) #  l in
                 append #  (rec # (fst #  p)) #  (cons #  a #  (rec #(snd #  p))))
           in
           \ (0 #  sort #  nil))
        ).

(* A more usual presentation of quicksort. *)
Definition quicksort :=
  FIX #  (\\
            (cond
                # (isnil # 0)
                # (nil)
                # (let hd := head # 0 in
                    let tl := tail # 0 in
                    let p := partition #  (geq #  hd) #  tl in
                    let rec := 1 in
                    append #  (rec # (fst #  p)) #  (cons # hd #  (rec #(snd #  p)))))).

Fixpoint list l :=
  match l with
    | List.cons t q => cons # t # (list q)
    | List.nil => nil
  end.
End T.

Section nat.
  Context {A : Type}.
  Variable iter : A -> A.
  Variable init : A.
  Fixpoint eval_rec t := match t with
                           | Var 0 => retn init
                           | App (Var 1) u => let! x = eval_rec u;
                                              retn (iter x)
                           | _ => None
                         end.
  Definition eval_nat t :=
    match t with
        | Abs (Abs t) => eval_rec t
        | _ => None
    end.
End nat.
Definition compute_nat := eval_nat S O.

Definition normal_nat n := let! t = Nf n; compute_nat (t).

(* Time Eval vm_compute in nf big big (T.SUM # T.church 1). *)
(* Time Eval vm_compute in normal_nat (T.SUM # T.church 5). *)
(* Eval compute in normal_nat (T.snd # (T.pair # T.zero # T.one)). *)
(* Eval compute in normal_nat (T.pred # T.church 5). *)

Section u.
  Fixpoint eval_lrec t := match t with
                           | Var 0 => retn (List.nil)
                           | App (App (Var 1) x) l =>
                             let! x = compute_nat x;
                             let! q = eval_lrec l  ;
                             retn (List.cons x q)
                           | _ => None
                         end.
  Fixpoint eval_list_of_nats t :=
    match t with
        Abs (Abs t) => eval_lrec t
      | _ => None
    end.
End u.
Definition normal_list_of_nats l := let! l = Nf l; eval_list_of_nats l.

Open Scope list_scope.

Definition list l := T.list (List.map T.church l).
(* Eval vm_compute in normal_list_of_nats (list  (1::nil))%nat. *)
(* Eval vm_compute in normal_list_of_nats (T.append #  (list  (1::2:: nil)) # (list  (nil)))%nat. *)
(* Eval vm_compute in nf big big (T.geq # T.church 2 # T.church 1). *)

(* Eval vm_compute in normal_list_of_nats (T.snd # (T.partition # (T.geq # T.church 3) # (list  (1::2 ::5::nil))))%nat. *)
(* Eval vm_compute in normal_list_of_nats (T.append #  (list  (1::2:: nil)) # (list  (nil)))%nat. *)

Definition quicksort l := normal_list_of_nats  (T.quicksort # (list l)).
Definition quicksort' l := normal_list_of_nats  (T.quicksort' # (list l)).

(* Time Eval vm_compute in quicksort' (0::3::5::2::4::1::nil). *)


Fixpoint eqb (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => eqb n' m'
            end
  end.
Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.

Theorem eqb_refl : forall n : nat,
  (n =? n) = true.
Proof.
  intros.
  induction n.
  - simpl. reflexivity.
  - simpl. rewrite IHn. reflexivity.
Qed.


Require Export Metalib.Metatheory.
Require Export Transitions.
Require Export Ch6.

(* Chapter 7: The Evaluation dynamics relation presented in this chapter is more commonly called
   a "bigstep" semantics" *)

(*************************************************************************)
(** * Structural Dynamics 7.1 *)
(*************************************************************************)

(* We can define the inductive relation shown in 7.1 as below *)
Inductive bigstep : exp -> exp -> Prop :=
| big_num : forall i, bigstep (exp_num i) (exp_num i)

| big_str : forall i, bigstep (exp_str i) (exp_str i)

| big_plus : forall e1 i1 e2 i2,
    bigstep e1 (exp_num i1) ->
    bigstep e2 (exp_num i2) ->
    bigstep (exp_op plus e1 e2) (exp_num (i1 + i2))

| big_let : forall e1 v1 e2 v2,
    bigstep e1 v1 ->
    bigstep (open e2 v1) v2 ->
    bigstep (exp_let e1 e2) v2.

Hint Constructors bigstep.

(* Lemma 7.1 *)
Lemma bigstep_value : forall e v, bigstep e v -> value v.
Proof.
  intros e v B. induction B; auto.
Qed.

(* Our representation requires this as well. *)
Lemma bigstep_lc_1 : forall e1 e2, bigstep e1 e2 -> lc e1.
Proof.
  intros e1 e2 B. induction B; auto.
  pick fresh x and apply lc_let; auto.
  rewrite (subst_intro x) in IHB2; auto.
  apply (subst_lc_inverse x v1) in IHB2.
  auto. destruct (bigstep_value e1 v1 B1); auto.
Qed.

(*************************************************************************)
(** * Relating Structural and Evaluation Dynamics 7.2 *)
(*************************************************************************)

Lemma big_to_small : forall e v, bigstep e v -> multistep e v.
Proof.
Admitted.  (* needs congruence lemma from Ch5.v, as well as multistep_transitive *)

Lemma small_to_big : forall e e', step e e' -> forall v, bigstep e' v -> bigstep e v.
Proof.
Admitted.


Set Implicit Arguments.
Set Asymmetric Patterns.

(* ================================================*)
(* 0. Functional Programming                       *)
(* ================================================*)

(*
    Functional programming (Coq's style)

    1. Types provide guidance for building and
       destructing data
    2. Programs are data

*)

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

(*
    Programs are data

    There is no “return” keyword:
      expression = statement

    - The program that always returns 4 is:
        4
    - This program also returns (or better computes
      to) 4:
        if (false || true) then 2 + 2 else 7
        if true then 2 + 2 else 7
        2 + 2
        4
    - This program also computes to 4:
        2 + (if 7 == 2 then 4 else 2)
        2 + (if false then 4 else 2)
        2 + 2
        4
*)

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

(*
    Programs are /really/ data

    This data is actually a program that doubles
    its input:

      (fun x => x + x)

    What does this evaluate to?

      (fun x => x + x) 3

    Recall:  f(x) is written (f x) in Coq

    This program takes in input a function f and
    uses it twice

      (fun f => f 3 + f 4)

    What does this evaluate to?

      (fun f => f 3 + f 4) (fun x => x + x)
*)

(* ================================================*)
(* 1. Build and destruct simple data               *)
(* ================================================*)

(* Booleans *)

Check bool : Type.
Check true : bool.
Check false.

(* Booleans are defined in the prelude as a data
   type with exactly the two constructors
   true and false:

   Inductive bool : Type := true | false.

   We can use this fact when we program with
   booleans via the "match .. with .. end"
   construct.
*)

(* Example: defining the negation *)
Definition negb (b : bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

(* Let's look at the type of the function we've just
   defined
*)
Check negb.

(* Given the type of negb, if we apply it to a
   boolean expression we obtain a boolean.
*)
Check (negb false).

(* Actually, the outermost parentheses can be
   omitted.  Like in:
   Check negb false.
*)

(* In this lecture we are not going to prove that
   our programs are correct, that is the topic of
   the next lesson.  We are going to just test
   our programs.
*)
Eval compute in negb true.
Eval compute in negb false.

(* The system provides syntactic sugar for
   matching over a boolean.
*)
Definition another_negb (b : bool) : bool :=
  if b then false else true.

(* Note that Definition is just a convenient syntax
   to name an otherwise anonymous function *)
Definition yet_another_negb :=
  (fun b : bool =>
     if b then false else true).

(* Definition of the boolean conjunction.

   Note: pattern matching over multiple values
   is just syntactic sugar.
*)
Definition andb (b1 : bool) (b2 : bool) :=
  match b1, b2 with
  | true, true => true
  | _, _ => false
  end.
 (* actually, this is equivalent to:
    if b1 then b2 else false *)

(* Some more syntactic sugar *)
Notation "x && y" := (andb x y).

Eval compute in true && false.
Eval compute in true && true.

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

(* Polymorphic data containers: the option type *)

(* The simplest generic container is the option type.
   Such container can either be empty, i.e. contain
   no value, or it can contain some value.
   Such container type is parametric over the
   type A of the values it contains.

   Inductive option (A : Type) : Type :=
   | None
   | Some (a : A).
*)

Check option.
Check option bool : Type.

Check Some true. (* Implicit argument *)
About Some.

(* The @ locally disables the implicit arguments *)
Check @Some bool true.
Check @Some _ true.

(* We now define a function checking if an
   option holds a value or not.

   Note the A parameter needed in order to wirte
   the type of "box"
*)
Definition is_empty A (box : option A) : bool :=
  match box with
  | None => true
  | Some _ => false  (* Here _ means discard *)
  end.

(* Note the implicit argument (A not passed) *)
Eval compute in is_empty (Some true).

(* Note: the function is polymorphic! *)
Eval compute in is_empty (Some 4).

(* first example of match with a binder *)
Definition get_default A (box: option A) (a : A) : A :=
  match box with
  | None => a
  | Some x => x
  end.

Eval compute in get_default None 3.

(* Here x binds the contents of the Some container,
   the value 4, that is also the result. *)
Eval compute in get_default (Some 4) 3.

(* Pairs *)

(* There is only a way to build a pair, and any
   two values can be paired

   Inductive prod (A B : Type) : Type :=
   | pair (a : A) (b : B).

   Notation "A * B" := (prod A B).
   Notation "( x , y )" := (pair x y).
*)

Check (true, Some false).

Definition fst A B (p : A * B) :=
  match p with (x, _) => x end.

Eval compute in fst (true, None).

Definition snd A B (p : A * B) :=
  match p with (_, y) => y end.

(* Exercises<<<<<<<<<                              *)

(* 1.1 Write a comparison function for the bool
   data type.
   Such function must evaluate to true if and only if
   the two input booleans b1 and b2 have the same
   value
*)
Definition eq_bool (b1 b2 : bool) : bool :=
  match b1, b2 with
  | true, true | false, false => true
  | _, _ => false
  end.

(* 1.2 Test the function you just wrote *)
Eval compute in eq_bool true true.
Eval compute in eq_bool false false.
Eval compute in eq_bool true false.
Eval compute in eq_bool false true.

(* 1.3 Write a function that computes the exclusive
   or of the two booleans in input *)
Definition xorb (b1 b2 : bool) : bool :=
  if eq_bool b1 b2 then false else true.

(* 1.4 Test the function you just wrote *)
Eval compute in

(* 1.5 Write and test a function that
   applies the fst projection over the option
   type.

   Hint: if o had type option (A * B) and, after
   scrutiny o turns out to be "Some x", which is
   the type of x?
 *)
Definition ofst A B (o: option (A * B)) : option A :=

(* Exercises>>>>>>>>>                              *)

(* ================================================*)
(* Recursive data and fixpoints *)
(* ================================================*)

(* Datatypes can be recursive

   Inductive nat : Type :=
   | O
   | S (n : nat).
*)

Check S (S O).
Check 1.

(* Recursive types, recursive functions

*)
Fixpoint plus (n : nat) (m : nat) : nat :=
  match n with
  | O => m
  | S n1 => S (plus n1 m)
  end.

Infix "+" := plus.

Check 1 + 2.
Eval compute in 1 + 2.

Fixpoint fast_plus (n : nat) (m : nat) : nat :=
  match n with
  | O => m
  | S n1 => fast_plus n1 (S m)
  end.

Check fast_plus 1 2.

Eval simpl in
  (fun n => fast_plus (S n) 3).
Eval simpl in
  (fun n => plus (S n) 3).

(* Lists are pretty much like naturals

  Inductive list (A : Type) : Type :=
  | nil
  | cons (x : A) (xs : list A).

*)
Infix "::" := cons.
Arguments nil {A}.
Arguments cons {A}.

(* The type of lists imposes all the elements to
    be in the same type! *)
Check true :: false :: nil.
Fail Check 1 :: false :: nil.

(* A non recursive function on lists *)
Definition tl A (l : list A) : list A :=
  match l with
  | nil => nil
  | _ :: xs => xs
  end.

Eval compute in tl (6 :: 99 :: nil).

(* The most popular function on lists *)
Fixpoint len A (l : list A) : nat :=
  match l with
  | nil => O
  | x :: xs => 1 + (len xs)
  end.

Eval compute in len (1 :: 2 :: 3 :: nil).

(* Two other examples of function over lists:

   - from a list of pairs, to a pair of lists
   - from two lists, to a list of pairs

   Note the let construction to name an
   intermediate result used more than once.

*)
Fixpoint split A B (l : list (A * B)) : list A * list B :=
  match l with
  | nil => (nil, nil)
  | (x,y) :: rest =>
      let xs_ys := split rest in
      (x :: fst xs_ys, y :: snd xs_ys)
  end.

Eval compute in
  split ((1,2) :: (3,4) :: nil).

Fixpoint zip A B (la : list A) (lb : list B) : list (A * B) :=
  match la, lb with
  | nil, nil => nil
  | x::xs, y::ys => (x,y) :: zip xs ys
  | _, _ => nil
  end.

Eval compute in
  zip (1 :: 2 :: nil) (true :: false :: nil).

Eval compute in
  let xs_ys := split ((1,2) :: (3,4) :: nil) in
  zip (fst xs_ys) (snd xs_ys).

(* Exercises<<<<<<<<<                              *)

(* 2.1 Write a function to compare two natural
   numbers n1 and n2.
   It must evaluate to true if and only if the
   two numbers are equal *)
Fixpoint eq_nat n1 n2 :=

Eval compute in eq_nat 7 4.
Eval compute in eq_nat 7 7.
Eval compute in eq_nat 7 (3 + 4).

(* 2.2 Write a function that computes the product
   of two natural numbers. Hint: you can use
   (many times) the function that computes the
   addition of natural numbers *)
Fixpoint mult n1 n2 :=

Infix "*" := mult.

Eval compute in 3 * 4.
Eval compute in eq_nat (3 * 4) 12.
Eval compute in eq_nat (3 * 0) 0.
Eval compute in eq_nat 0 (3 * 0).

(* 2.3 Write a function that appends two lists

   Example:
     append (1 :: 2 :: nil) (3 :: nil)
   must evaluate to
     (1 :: 2 :: 3 :: nil)

*)
Fixpoint
  append A (l1 : list A) (l2 : list A) : list A
:=

Eval compute in append (1 :: 2 :: nil) (3 :: nil).

(* 2.4 Write a function that reverses a list.
   Hint: use append. *)
Fixpoint rev1 A (l : list A) : list A :=

Eval compute in rev1 (1 :: 2 :: 3 :: nil).

(* 2.5 Again list reversal, but this time using
   an auxiliary function that uses an accumulator. *)
Fixpoint rev2_aux A (acc l : list A) : list A :=
  match l with
  | nil => acc
  end.

Definition rev2 A (l : list A) := rev2_aux nil l.

Eval compute in rev2 (1 :: 2 :: 3 :: nil).

(* Exercises>>>>>>>>>                              *)

(* ================================================*)
(* Illegal data types and recursive functions *)
(* ================================================*)

Fail
Fixpoint wrong A (l : list A) {struct l} :=
  match l with
  | nil => 0
  | x :: xs => 1 + wrong (x :: nil)
  end.

(* RUN THAT IN A PATCHED (UNSOUND) COQ

   Recall:

     Inductive False : Prop := .

   i.e. There is no way to build a value
   of type False.

*)

(*
Fixpoint loop (n : nat) : False := loop n.

Check loop 3.
Fail Timeout 2 Eval compute in loop 3.

Inductive non_positive : Type :=
| Call (f : non_positive -> False)

Definition self (t : non_positive) : False :=
  match t with
  | Call f => f t
  end.

Definition loop2 : False := self (Call self).

Fail Timeout 2 Eval compute in loop2.
*)

(*
   Note: for the experts in the room...
   Yes, there are ways to use a well founded order
   relation as the decreasing measure. See the

     Function ... {measure ...}

   and

     Function ... {wf ...}

   in the Reference Manual.
*)

(* ================================================*)
(* Higher order programming *)
(* ================================================*)

(* A function can be abstracted over another
   function.  It is a useful mechanism to write
   code that can be reused, especially in the context
   of polymorphic containers
*)
Fixpoint map A B (f : A -> B) (l : list A) : list B :=
  match l with
  | nil => nil
  | x :: xs => f x :: map f xs
  end.

Eval compute in
  map (fun x => x + 2) (3 :: 4 :: 7 :: nil).
Eval compute in
  map negb (true :: false :: nil).

(* fold f (x1 :: x2 :: .. xn :: nil) a
     =
	    (f xn (.. (f x2 (f x1 a))))
*)
Fixpoint fold A B (f : B -> A -> A) (l : list B) (a : A) : A :=
  match l with
  | nil => a
  | x :: xs => fold f xs (f x a)
  end.

Eval compute in fold plus (1 :: 2 :: 3 :: nil) 0.

(* Exercises<<<<<<<<<                              *)

(* 4.1 Write a function that reverses a list based on       fold.  Hint: use fold and cons.
*)
Definition rev A (l : list A) :=

Eval compute in rev (1 :: 2 :: 3 :: 4 :: nil).

(* 4.2 Write a function that appends two lists, this
   time using fold and rev *)
Definition another_append A (l1 l2 : list A) :=

Eval compute in
  another_append (1 :: 2 :: nil) (3 :: 4 :: nil).

(* 4.3 The higher order function iter takes a
   function f, an initial value a and a number n.
   The result is (f (f ... (f a))),
   where f is applied n times. *)
Fixpoint iter A (f : A -> A) a n :=

(* 4.4 Write a function that computes the sum of
   two natural numbers using iter *)
Definition another_plus n1 n2 :=

Eval compute in another_plus 3 4.

(* 4.5 Write a function that computes the product of
   two natural numbers using iter and plus *)
Definition another_mult n1 n2 :=

Eval compute in another_mult 3 7.
Eval compute in another_mult 3 0.
Eval compute in another_mult 0 7.
Eval compute in another_mult 2 4.

(* Exercises>>>>>>>>>                              *)

(* ================================================*)
(* Code reuse: a taste of ad-hoc polymorphism *)
(* ================================================*)

Class Eq (A : Type) := cmp : A -> A -> bool.

Infix "==" := cmp (at level 70, no associativity).

Fixpoint mem A `{Eq A} (y : A) (l : list A) : bool :=
  match l with
  | nil => false
  | x :: xs => if x == y then true else mem y xs
  end.

Instance bool_Eq : Eq bool := eq_bool.

Check mem true (false :: false :: true :: nil).
Eval compute in
  mem true (false :: false :: true :: nil).

Instance pair_Eq A `{Eq A} B `{Eq B} : Eq (A * B) :=
  fun (x y : A * B) =>
    (fst x == fst y) && (snd x == snd y).

Eval compute in
  mem (true,false)
        ((false,false) :: (true,false) :: nil).
Eval compute in
  mem (true,false)
        ((false,false) :: (false,true) :: nil).

(* Exercises<<<<<<<<<                              *)

(* 5.1 Register eq_nat as the comparison function
   for the nat type *)
Instance nat_Eq : Eq nat :=

(* Example: an associative list mapping numbers to
   boolean values.
   1 is mapped to true, 2 to false. *)
Definition an_associative_list : list (nat * bool) :=
  (1,true) :: (2,false) :: nil.

(* 5.2 Write a function that finds the value
   associated to y in the associative list l.   *)
Fixpoint
  find A {e : Eq A} (y : A) B (l : list (A * B))
:
  option B
:=

Definition data := 1 :: 4 :: 7 :: nil.

(* 5.3 Define a list of pairs of natural numbers
   such that the first item is an element of the list
   data (the one just defined) and the second item
   is its square.
   I.e.  the list must be (1,1)::(4,16)::... but
   don't write it by hand.  Instead, use map. *)
Definition square_cache :=

Eval compute in find 3 square_cache.

(* 5.4 The function square takes a cache c (that is
   an associative list) and a number n.  It computes
   a pair: the first component is the square of the
   input n while the second component is
   an (eventually) updated cache. *)
Definition square cache n :=

Eval compute in square square_cache 3.

(* Exercises>>>>>>>>>                              *)

(* vim: set tw=50 *)


From BraidsT Require Import CpdtTactics.
From BraidsT Require Import supp.

Require Import Bool PeanoNat List Nat.
Set Implicit Arguments.
Set Asymmetric Patterns.

(* Unset Strict Implicit. *)
(* Unset Printing Implicit Defensive. *)

Require Import ProofIrrelevance.

Require Import ZArith.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Lists.List.
Import ListNotations.

Hint Rewrite app_nil_r : core.

Definition BNat lim := { n | n < lim }.

Module Braids.

Section Theory.

Variable N : nat.
Hypothesis large_enough : 10 < N.

Definition free_braidlike_monoid := list (BNat (pred N)).

Definition mult_fbm : free_braidlike_monoid -> free_braidlike_monoid -> free_braidlike_monoid := app (A:=_).

Hint Unfold mult_fbm : core.

Notation "x * y" := (mult_fbm x y).

Lemma braids_has_1 : exists e : free_braidlike_monoid, forall x, x * e = x /\ e * x = x.
Proof.
  unfold "*";
  exists [];
  crush.
Qed.

Lemma braids_assoc : forall (x y z : free_braidlike_monoid), (x * y) * z = x * (y * z).
Proof.
  unfold "*";
  crush.
Qed.

Definition ns_list (n:nat) := rev ((fix F n :=
  match n with
  | 0 => []
  | S n' => n :: (F n')
  end) n).

Lemma ns_list_len : forall n, length(ns_list n) = n.
Proof.
  intros.
  induction n.
  - trivial.
  - unfold ns_list. rewrite rev_length.
    unfold ns_list in IHn. rewrite rev_length in IHn.
    simpl. rewrite IHn. trivial.
Qed.

Hint Rewrite ns_list_len.

Eval compute in ns_list 10.

Definition braid_perm := { perm : list nat | Permutation perm (ns_list N) }.

Lemma braid_perm_size : forall bp : braid_perm, length (proj1_sig bp) = N.
Proof.
  intros.
  destruct bp as [perm P].
  simpl. apply Permutation_length in P. rewrite ns_list_len in P. apply P.
Qed.

Lemma braid_list_len : forall l, Permutation l (ns_list N) -> length l = N.
Proof.
  intros l Hl.
  crush.
Qed.

Hint Rewrite braid_perm_size.
(* Hint Rewrite braid_list_len. *)
Hint Constructors Permutation : core.

Lemma Permutation_rev__l : forall {A} (l : list A), Permutation (rev l) l.
Proof.
  intros A.
  intros l.
  replace l with (rev (rev l)) at 2.
  apply Permutation_rev.
  apply rev_involutive.
Qed.

Print braid_perm.
Check exist.

Lemma no_empty {T} : forall i, S (S i) <= length(@nil T) -> False.
Proof.
  simpl. intros.
  inversion H.
Qed.

Lemma no_single {T} : forall i (x:T), S (S i) <= length([x]) -> False.
Proof.
  simpl. intros.
  inversion H. inversion H1.
Qed.

Notation "[[ x ]]" := (exist _ x _).
Notation "[[ x | P ]]" := (exist _ x P).

Definition optionTest : option nat := Some 4.

Definition optionTestVal : nat :=
  match optionTest with
  | None => 0
  | Some x => x
  end.

Notation "x <?- e1 ;; e2" := (match e1 with | None => None | Some x => e2 end)  (at level 50).
Notation "x <!- e1 ;; e2" := (match e1 with | None => False | Some x => e2 end)  (at level 50).

Definition optionNotationTest x : option nat :=
  y <?- optionTest;;
  Some (x + y).

Eval compute in optionNotationTest 4.

Fixpoint transpose_if_lt (l : list nat) (i : nat) : option (list nat) :=
  match l with
  | [] => None
  | [_] => None
  | (x::y::xs) => (
    match i with
    | 0 => if x <? y then Some (y :: x :: xs) else Some (x :: y :: xs)
    | S i' => (rec <?- transpose_if_lt (y::xs) i' ;; Some (x :: rec))
    end
  )
  end.

Lemma transpose_if_lt_defined : forall l i (H: S i < length l), { res | transpose_if_lt l i = Some res }.
  refine (fix F l i (H: S i < length l) {struct i} : { res | transpose_if_lt l i = Some res } := _).
  generalize l i H.
  clear l i H.
  intros l.
  refine (match l with | [] => _ | [_] => _ | (x::y::xs) => _ end); intros; try solve [clear F; crush].
  destruct i. {
  simpl. destruct (x <? y).
  - exists (y :: x :: xs). trivial.
  - exists (x :: y :: xs). trivial.
  }
  - assert (HRec: { rec | transpose_if_lt (y::xs) i = Some rec }).
    { apply F. crush. }
    Guarded.
    destruct HRec as [rec HRec]. exists (x :: rec). simpl.
    rewrite HRec. trivial.
Defined.

(*
Definition transpose_if_lt (l : list nat) (i:BNat (pred (length l))) : { l' : list nat | Permutation l' l }.
  refine ((let fix F l i : (S (S i) <= length(l)) -> { l' : list nat | Permutation l' l } :=
    match l return (S (S i) <= length(l) -> _) with
    | []  => fun H => match (no_empty H) with end
    | [x] => fun H => match (no_single H) with end
    | (x::y::xs) => fun H => (match i as m return (i = m -> _ ) with
      | (S i') => fun Heq => (match ((F (y::xs) i' _)) with | [[rec | Hind]]  => [[(x::rec)]] end)
      | 0 => fun Heq => if x <? y then [[(y::x::xs)]] else [[(x::y::xs)]]
      end) (eq_refl _)
    end in F l (proj1_sig i) _)).
    Unshelve.
    { destruct i; crush. }
    { apply perm_swap. }
    { crush. }
    { crush. }
    { apply perm_skip. apply Hind. }
Defined.
*)

Inductive transpose_if_ltR : forall (l:list nat) (l':list nat) (i:nat), Prop :=
| transpose_if_lt_step x xs l' n (H: transpose_if_ltR xs l' n) : transpose_if_ltR (x::xs) (x::l') (S n)
| transpose_if_lt_swap x y xs (H: x < y) : transpose_if_ltR (x::y::xs) (y::x::xs) 0
| transpose_if_lt_noswap x y xs (H: ~(x < y)) : transpose_if_ltR (x::y::xs) (x::y::xs) 0.

Lemma transpose_if_lt_FtR : forall (l:list nat) i (H: S i < length l),
  l' <!- transpose_if_lt l i;;
  transpose_if_ltR l l' i.
Proof.
  refine (fix IH l i H {struct i} := _).
  generalize l i H. clear l i H.
  intros l.
  refine (match l with | [] => _ | [_] => _ | (x::y::xs) => _ end); intros; try solve [clear IH; crush].
  destruct i.
  2: { simpl. destruct (@transpose_if_lt_defined (y::xs) i).
       { crush. }
       { rewrite e. apply transpose_if_lt_step.
         refine (let IH := IH (y::xs) i _ in _).
         Unshelve.
         2: { crush. }
         rewrite e in IH. assumption.
       }
  }
  simpl. destruct (Nat.ltb_spec x y).
  { apply transpose_if_lt_swap. assumption. }
  { apply transpose_if_lt_noswap. apply le_not_lt. assumption. }
Qed.

Lemma transpose_if_lt_RtF : forall l l' i, transpose_if_ltR l l' i -> transpose_if_lt l i = Some l'.
Proof.
  intros l l' i H.
  induction H.
  - destruct xs as [| y xs].
    + exfalso. destruct n; crush.
    + simpl. rewrite IHtranspose_if_ltR. trivial.
  - simpl. destruct (Nat.ltb_spec x y). { trivial.} { apply le_not_lt in H0. contradiction. }
  - simpl. destruct (Nat.ltb_spec x y). { contradiction. } { trivial. }
Qed.

Lemma transpose_if_lt_perm : forall l i (H: S i < length l),
    { l' | transpose_if_lt l i = Some l' /\ Permutation l l' }.
Proof.
  intros l i H.
  refine (let HRel := transpose_if_lt_FtR l H in _).
  destruct (transpose_if_lt_defined l H) as [l' Hl].
  rewrite Hl in HRel.
  exists l'. split.
  - apply Hl.
  - induction HRel; try solve [  apply Permutation_refl || constructor ].
    apply perm_skip. apply IHHRel.
    { crush. }
    apply transpose_if_lt_RtF. assumption.
Defined.

Definition transpose_braid (bp : braid_perm) (i:BNat (pred N))
  : braid_perm.
  destruct bp as [l Hl].
  destruct i as [i' Hi'].
  assert (S i' < length l). { crush. }
  destruct (transpose_if_lt_perm l H).
  refine ([[x]]).
  apply perm_trans with (l':=l).
  - destruct a as [_ HP]. apply Permutation_sym. assumption.
  - assumption.
  Show Proof.
Defined.

Fixpoint pi_braid (b : free_braidlike_monoid) : braid_perm.
  refine ((match b as m return (b = m -> _) with
    | [] => fun Heq => _
    | (x::xs) => fun Heq => _
    end) (eq_refl _)).
  - refine [[ns_list N]]; trivial.
  - refine (let xs' := pi_braid xs in (transpose_braid xs' x)).
Defined.

Notation "'fbm'" := free_braidlike_monoid.

Notation "x <- e1 ;; e2" := (match e1 with [[x]] => e2 end) (at level 100).

(* Definition twice_transpose_if_ltRT (l:list nat) (n:BNat (pred (length l))) : Prop.
  refine (let l1 := @transpose_if_lt l n in _).
  destruct l1 as [l1 Hl1].
  refine (let l2 := @transpose_if_lt l n in _).
  destruct l2 as [l2 Hl2].
  destruct n as [n Hn].
  refine (let l3 := @transpose_if_lt l2 [[n]] in _).
  destruct l3 as [l3 Hl3].
  exact (l1 = l3).
  Unshelve.
  apply Permutation_length in Hl2. rewrite Hl2. assumption.
Defined.

Lemma twice_transpose_if_lt : forall l n, twice_transpose_if_ltRT l n.
Proof.
  unfold twice_transpose_if_ltRT.
  refine (fix F l n : twice_transpose_if_ltRT l n := _).
  unfold twice_transpose_if_ltRT.
  destruct n as [n Hn].
  refine ((match l as m return (l = m -> _) with
    | [] => _
    | [x] => _
    | (x::y::xs) => _
    end) eq_refl).
  - intros. exfalso. assert (2 <= length (l)); crush.
  - intros. exfalso. assert (2 <= length (l)); crush.
  - refine ((match n as m return (n = m -> _) with
      | 0 => _
      | S n' => _
      end) eq_refl).
  2: { intros. .

 - intros. crush. try solve [clear F; crush]. *)

Lemma twice_transpose_braid_0 : forall l n,
  transpose_braid l n = (transpose_braid (transpose_braid l n) n).
Proof.

  intros [l Hl] [n Hn].
  generalize dependent l.
  induction n; intros l Hl.
  - refine ((match l as l' return (l' = l -> _) with [] => _ | [x] => _ | (x::y::xs) => _ end) eq_refl).
    + intros. exfalso. assert (2 <= length (l)); crush.
    + intros. exfalso. assert (2 <= length (l)); crush.
    + intros. subst l. destruct (x <? y) eqn:Heq.
    * unfold transpose_braid. unfold transpose_if_lt. simpl. rewrite Heq.
      assert ((y <? x) = false). { apply (lt_antisymm Heq). } rewrite H.
      apply subset_eq_compat. trivial.
    * unfold transpose_braid. unfold transpose_if_lt. simpl. rewrite Heq. rewrite Heq.
      apply subset_eq_compat. trivial.
  - refine ((match l as l' return (l' = l -> _) with [] => _ | [x] => _ | (x::y::xs) => _ end) eq_refl).
    + intros. exfalso. assert (2 <= length (l)); crush.
    + intros. exfalso. assert (2 <= length (l)); crush.
    + intros. subst l.
      unfold transpose_braid.
      apply transpose_if_lt_ind with .

Definition sub_b : BNat (pred N) -> BNat (pred N) -> BNat (pred N).
  intros n m.
  destruct n as [n Hn]. destruct m as [m Hm].
  exists (n - m).
  crush.
Defined.

Definition le_b : BNat (pred N) -> BNat (pred N) -> Prop.
  intros n m.
  destruct n as [n Hn]. destruct m as [m Hm].
  exact (n <= m).
Defined.

Definition lt_b : BNat (pred N) -> BNat (pred N) -> Prop.
  intros n m.
  destruct n as [n Hn]. destruct m as [m Hm].
  exact (n < m).
Defined.

Lemma lt_1_N : 1 < pred N.
Proof.
  crush.
Qed.

Inductive braid_eq : fbm -> fbm -> Prop :=
| braid_eq_refl : forall x, braid_eq x x
| braid_eq_symm : forall x y, braid_eq x y -> braid_eq y x
| braid_eq_trans : forall x y z, braid_eq x y -> braid_eq y z -> braid_eq x z
| braid_eq_idemp : forall i, braid_eq [i; i] [i]
| braid_eq_farcomm : forall i j : BNat (pred N), lt_b [[1 | lt_1_N ]] (sub_b j i) ->
      braid_eq [i; j] [j; i]
| braid_eq_braid : forall i j : (BNat (pred N)), [[1 | lt_1_N]] = (sub_b j i) ->
      braid_eq [i; j; i] [j; i; j].

Theorem braid_eq__pi_eq : forall b1 b2, braid_eq b1 b2 -> pi_braid b1 = pi_braid b2.
Proof.
  intros.
  induction H; try solve [crush].
  - unfold pi_braid.
  assert (forall l, transpose_braid (transpose_braid l i) i =
    transpose_braid l i).
  intros. unfold transpose_braid.

End braids.

}


Require Import   Algebra.SetoidCat Algebra.Monoid Algebra.NearSemiRing.

Require Import RelationClasses Relation_Definitions Morphisms SetoidClass.

Section Instances.
  Context
    {A AS}
    (nsr : @NearSemiRing A AS).

  Instance nearSemiRing_times_Monoid : @Monoid A AS.
  Proof.
    exists (one) (times).
    apply times_left_unit.
    apply times_right_unit.
    apply times_associativity.
  Defined.
End Instances.


(* Steve Awodey's book on category theory *)
(******************************************************************************)
(* Chapter 1.3: Categories                                                    *)
(******************************************************************************)
(* @suharahiromichi *)

(*
(1) ベースライン
http://www.megacz.com/berkeley/coq-categories/
これをもとに改変。Instance ... Proper を使うようにした。
 *)

(*
(2) Proper関数の定義
A Gentle Introduction to Type Classes and Relations in Coq
*)

(*
(3) Setoid を使うようにし、Setsと(P,<=)のインスタンスをつくる。
http://www.iij-ii.co.jp/lab/techdoc/category/category1.html
 *)

(*
できるだけ Generalizable を使う。
 *)

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From mathcomp Require Import finset fintype.

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

Require Import Morphisms.
Require Import Coq.Setoids.Setoid.
Require Import Notations.

(*
Reserved Notation "x ~> y" (at level 51, left associativity).
*)
Reserved Notation "x \\o y" (at level 51, left associativity).
Reserved Notation "x === y" (at level 71, left associativity).

Generalizable Variables a b c d e x.
Generalizable Variables Obj.

(* Calss Setoid (carrier : Type) とするのは難しい。なぜ？ *)
Class Setoid : Type :=
  {
    carrier : Type;
    eqv : carrier -> carrier -> Prop;
    eqv_equivalence : Equivalence eqv
  }.
Coercion carrier : Setoid >-> Sortclass.
Notation "x === y" := (eqv x y).

Class Category `(Hom : Obj -> Obj -> Setoid) : Type :=
  {
    hom := Hom where "a ~> b" := (hom a b);
    obj := Obj;
    id   : forall {a : Obj}, (a ~> a);
    comp : forall {a b c : Obj},
             (b ~> c) -> (a ~> b) -> (a ~> c)
                                       where "f \\o g" := (comp f g);
    comp_respects   : forall {a b c : Obj},
                        Proper (eqv ==> eqv ==> eqv) (@comp a b c);
    left_identity   : forall `{f : a ~> b}, id \\o f === f;
    right_identity  : forall `{f : a ~> b}, f \\o id === f;
    associativity   : forall `{f : c ~> d} `{g : b ~> c} `{h : a ~> b},
                        f \\o g \\o h === f \\o (g \\o h)
}.
Coercion obj : Category >-> Sortclass.

Notation "a ~> b"  := (hom a b).
Notation "f \\o g" := (comp f g).
Notation "a ~~{ C }~~> b" := (@hom _ _ C a b) (at level 100).

(* eqv が、Reflexive と Symmetric と Transitive とを満たす。 *)
Instance category_eqv_Equiv `(C : Category Obj) (a b : Obj) :
  Equivalence (@eqv (a ~> b)).
Proof.
  by apply eqv_equivalence.
Qed.

(* comp は eqv について固有関数である。 *)
Instance category_comp_Proper `(C : Category Obj) (a b c : Obj) :
  Proper (@eqv (b ~> c) ==> @eqv (a ~> b) ==> @eqv (a ~> c)) comp.
Proof.
  by apply comp_respects.
Qed.

(* 可換性についての定理を証明する。 *)
Lemma juggle1 : forall `{C : Category}
                       `(f : d ~> e) `(g : c ~> d) `(h : b ~> c) `(k : a ~> b),
                  f \\o g \\o h \\o k === f \\o (g \\o h) \\o k.
Proof.
  intros.
  rewrite <- associativity.
  reflexivity.
Defined.

Lemma juggle2 : forall `{C : Category}
                       `(f : d ~> e) `(g : c ~> d) `(h : b ~> c) `(k : a ~> b),
                  f \\o (g \\o (h \\o k)) === f \\o (g \\o h) \\o k.
Proof.
  intros.
  do ! rewrite <- associativity.
  reflexivity.
Defined.

Lemma juggle3 : forall `{C : Category}
                       `(f : d ~> e) `(g : c ~> d) `(h : b ~> c) `(k : a ~> b),
                  f \\o g \\o (h \\o k) === f \\o (g \\o h) \\o k.
Proof.
  intros.
  do ! rewrite <- associativity.
  reflexivity.
Defined.

Reserved Notation "x &&& y" (at level 50, left associativity).

(* 直積 *)
Class Product `{C : Category Obj} (Prod : Obj -> Obj -> Obj) : Type :=
  {
    obj' := Obj;
    proj1 : forall {a b : Obj}, (Prod a b) ~> a;
    proj2 : forall {a b : Obj}, (Prod a b) ~> b;

    (* 仲介射 *)
    mediating : forall {a b x : Obj},
                  (x ~> a) -> (x ~> b) -> (x ~> (Prod a b))
                                            where "f &&& g" := (mediating f g);

    med_commute1 : forall `(f : x ~> a) `(g : x ~> b),
                     proj1 \\o (f &&& g) === f;
    med_commute2 : forall `(f : x ~> a) `(g : x ~> b),
                     proj2 \\o (f &&& g) === g;
    med_unique : forall `(f : x ~> a) `(g : x ~> b) `(h : x ~> (Prod a b)),
                   proj1 \\o h === f ->
                   proj2 \\o h === g ->
                   h === (f &&& g)
  }.
Coercion obj': Product >-> Sortclass.
Notation "x &&& y" := (mediating x y).

Check @proj1 : ∀Obj Hom C Prod _ a b, Prod a b ~> a.
Check @proj2 : ∀Obj Hom C Prod _ a b, Prod a b ~> b.

Set Printing All.
Generalizable Variables Prod.
Definition parallel `{C : Category Obj} {Prod : Obj -> Obj -> Obj} {CP : Product Prod}
           `(f : a ~> b) `(g : c ~> d) : (Prod a c) ~> (Prod b d) :=
  let p1 := @proj1 Obj Hom C Prod CP a c in
  let p2 := @proj2 Obj Hom C Prod CP a c in
  (f \\o p1) &&& (g \\o p2).
Notation "f *** g" := (parallel f g).      (* <f,g> *)

(* **** *)
(* Sets *)
(* **** *)
Instance EquivExt : forall (A B : Set), Equivalence (@eqfun A B) := (* notu *)
  {
    Equivalence_Reflexive := @frefl A B;
    Equivalence_Symmetric := @fsym A B;
    Equivalence_Transitive := @ftrans A B
  }.

Instance EqMor : forall (A B : Set), Setoid :=
  {
    carrier := A -> B;
    eqv := @eqfun B A
  }.

Check @Category Set : (Set → Set → Setoid) → Type.
Check @Category Set EqMor : Type.
Check EqMor : Set -> Set -> Setoid.

Program Instance Sets : @Category Set EqMor.
Obligation 3.
Proof.
  rewrite /Sets_obligation_2.
  move=> homab homab' Hhomab hombc hombc' Hhombc.
  move=> x //=.
  rewrite Hhomab.
  rewrite Hhombc.
    by [].
Qed.

Check prod : (Type → Type → Type).
Check @Product Sets EqMor Sets prod.
Check Product prod : Type.

Program Instance SetsProd : @Product Sets EqMor Sets prod :=
  {
    proj1 A B := @fst A B;
    proj2 A B := @snd A B;
    mediating A B X := fun f g x => (f x, g x)
  }.
Obligation 3.
Proof.
  move: H H0.
  rewrite /Sets_obligation_2 => H1 H2 x'.
  rewrite -(H1 x').
  rewrite -(H2 x').
  by apply surjective_pairing.
Qed.

(* **** *)
(* P,<= *)
(* **** *)
Open Scope coq_nat_scope.
Search "_ <= _".
Check 0 <= 0 : Prop.

Definition eq_le m n (p q : m <= n) := True.

Instance EquivGeq : forall (m n : nat), Equivalence (@eq_le m n). (* notu *)
Proof.
    by [].
Qed.

Instance EqLe : forall (m n : nat), Setoid :=
  {
    carrier := m <= n;
    eqv := @eq_le m n
  }.

Check @Category nat : (nat → nat → Setoid) → Type.
Check EqLe : nat → nat → Setoid.
Check @Category nat EqLe.

Program Instance P_LE : @Category nat EqLe.
Obligation 2.
Proof.
    by apply (@Le.le_trans a b c).
Defined.
Obligation 3.
Proof.
  rewrite /P_LE_obligation_1.
  rewrite /P_LE_obligation_2.
  move=> homab homab' Hhomab hombc hombc' Hhombc.
  by rewrite /eq_le.
Defined.
Obligation 4.
Proof.
  rewrite /P_LE_obligation_1.
  rewrite /P_LE_obligation_2.
  by rewrite /eq_le.
Defined.
Obligation 5.
Proof.
  rewrite /P_LE_obligation_1.
  rewrite /P_LE_obligation_2.
  by rewrite /eq_le.
Defined.
Obligation 6.
Proof.
  rewrite /P_LE_obligation_2.
  by rewrite /eq_le.
Defined.

Check P_LE.

Check min : nat -> nat -> nat.
Check @Product P_LE EqLe P_LE min.

Program Instance P_LE_Prod : @Product P_LE EqLe P_LE min.
Obligation 1.
Proof.
  Search (min _ _ <= _).
  by apply PeanoNat.Nat.le_min_l.
Defined.
Obligation 2.
  by apply PeanoNat.Nat.le_min_r.
Defined.
Obligation 3.
Proof.
  Search (_ <= min _ _).
  by apply PeanoNat.Nat.min_glb.
Defined.
Obligation 4.
  rewrite /P_LE_obligation_1.
  rewrite /P_LE_obligation_2.
  rewrite /P_LE_obligation_3.
  by rewrite /eq_le.
Defined.
Obligation 5.
  rewrite /P_LE_obligation_1.
  rewrite /P_LE_obligation_2.
  rewrite /P_LE_obligation_3.
  by rewrite /eq_le.
Defined.

Check P_LE_Prod.

(* an application of parallel (***) *)
Check @parallel.
Lemma parallel_min : forall (m n p q : nat),
      m <= n -> p <= q -> min m p <= min n q.
Proof.
  move=> m n p q Hmn Hpq.
  Check @parallel nat EqLe P_LE min P_LE_Prod m n Hmn p q Hpq.
    by apply: (@parallel nat EqLe P_LE min P_LE_Prod m n Hmn p q Hpq).
    Undo 1.
  Check Hmn *** Hpq.
    by apply: (Hmn *** Hpq).
Qed.
Print parallel_min.

(* END *)


Require Import Basics.
Require Import Spaces.Pos.
Require Import Spaces.Int.Core.
Require Import Spaces.Int.Spec.

(** ** Iteration of equivalences *)

(** *** Iteration by arbitrary integers *)

Definition int_iter {A} (f : A -> A) `{!IsEquiv f} (n : Int) : A -> A
  := match n with
      | neg n => fun x => pos_iter f^-1 n x
      | zero => idmap
      | pos n => fun x => pos_iter f n x
     end.

(** Iteration by arbitrary integers requires the endofunction to be an equivalence, so that we can define a negative iteration by using its inverse. *)

Definition int_iter_succ_l {A} (f : A -> A) `{IsEquiv _ _ f}
  (n : Int) (a : A)
  : int_iter f (int_succ n) a = f (int_iter f n a).
Proof.
  destruct n as [n| |n]; trivial.
  + revert n f H a.
    serapply pos_peano_ind.
    { intros f H a.
      symmetry.
      apply eisretr. }
    hnf; intros n p f H a.
    refine (ap (fun x => _ x _) _ @ _).
    1: rewrite int_neg_pos_succ.
    1: exact (eisretr int_succ (neg n)).
    apply moveL_equiv_M.
    cbn; symmetry.
    serapply pos_iter_succ_l.
  + cbn.
    rewrite pos_add_1_r.
    serapply pos_iter_succ_l.
Qed.

Definition int_iter_succ_r {A} (f : A -> A) `{IsEquiv _ _ f}
  (n : Int) (a : A) : int_iter f (int_succ n) a = int_iter f n (f a).
Proof.
   destruct n as [n| |n]; trivial.
+ revert n f H a.
  serapply pos_peano_ind.
  { intros f H a.
    symmetry.
    apply eissect. }
  hnf; intros n p f H a.
  rewrite int_neg_pos_succ.
  refine (ap (fun x => _ x _) _ @ _).
  1: exact (eisretr int_succ (neg n)).
  cbn; rewrite pos_add_1_r.
  rewrite pos_iter_succ_r.
  rewrite eissect.
  reflexivity.
+ cbn.
  rewrite pos_add_1_r.
  serapply pos_iter_succ_r.
Qed.

Definition iter_int_pred_l {A} (f : A -> A) `{IsEquiv _ _ f}
  (n : Int) (a : A)
: int_iter f (int_pred n) a = f^-1 (int_iter f n a).
Proof.
  destruct n as [n| |n]; trivial.
  + cbn; rewrite pos_add_1_r.
    by rewrite pos_iter_succ_l.
  + revert n.
    serapply pos_peano_ind.
    - cbn; symmetry; apply eissect.
    - hnf; intros p q.
      rewrite <- pos_add_1_r.
      change (int_pred (pos (p + 1)%pos))
        with (int_pred (int_succ (pos p))).
      rewrite int_pred_succ.
      change (pos (p + 1)%pos)
        with (int_succ (pos p)).
      rewrite int_iter_succ_l.
      symmetry.
      apply eissect.
Qed.

Definition iter_int_pred_r {A} (f : A -> A) `{IsEquiv _ _ f}
  (n : Int) (a : A)
: int_iter f (int_pred n) a = int_iter f n (f^-1 a).
Proof.
  revert f H n a.
  destruct n as [n| |n]; trivial;
  induction n as [|n nH] using pos_peano_ind; trivial.
  2: hnf; intros; apply symmetry, eisretr.
  all: rewrite <- pos_add_1_r.
  all: intro a.
  1: change (neg (n + 1)%pos) with (int_pred (neg n)).
  2: change (pos (n + 1)%pos) with (int_succ (pos n)).
  1: rewrite <- 2 int_neg_pos_succ.
  1: cbn; apply pos_iter_succ_r.
  rewrite int_pred_succ.
  rewrite int_iter_succ_r.
  rewrite eisretr.
  reflexivity.
Qed.


From Coq Require Import Arith Psatz Bool String List Program.Equality Logic.Eqdep_dec Nat.

Local Open Scope string_scope.
Local Open Scope nat_scope.
Local Open Scope list_scope.

Definition ident := string.

Definition store (T: Type): Type := ident -> T.

Definition update {T: Type} (x: ident) (v: T) (s: store T): store T :=
  fun y => if string_dec x y then v else s y.

Lemma update_same:
  forall (T: Type) (x: ident) (v: T) (s: store T), (update x v s) x = v.
Proof.
  unfold update; intros. destruct (string_dec x x); congruence.
Qed.

Lemma update_other:
  forall (T: Type) (x: ident) (v: T) (s: store T) (y: ident), x <> y -> (update x v s) y = s y.
Proof.
  unfold update; intros. destruct (string_dec x y); congruence.
Qed.

Section SEQUENCES.

Variable A: Type.                 (**r the type of states *)
Variable R: A -> A -> Prop.       (**r the transition relation between states *)

(** ** Finite sequences of transitions *)

(** Zero, one or several transitions: reflexive transitive closure of [R]. *)

Inductive star: A -> A -> Prop :=
  | star_refl: forall a,
      star a a
  | star_step: forall a b c,
      R a b -> star b c -> star a c.

Lemma star_one:
  forall (a b: A), R a b -> star a b.
Proof.
  eauto using star.
Qed.

Lemma star_trans:
  forall (a b: A), star a b -> forall c, star b c -> star a c.
Proof.
  induction 1; eauto using star.
Qed.

End SEQUENCES.

(*default function if not defined is the identity function. *)

Definition nat_env := store nat.

Definition init_nenv: nat_env := fun _ => 0.

Definition debruijn_env: Type := list nat.

Definition init_debruijn_env: debruijn_env := nil.

Inductive aexp_Dan :=
| CONST_Dan (n: nat)
| VAR_Dan (x: ident)
| PARAM_Dan (n: nat)
| PLUS_Dan (a1 a2: aexp_Dan)
| MINUS_Dan (a1 a2: aexp_Dan)
| APP_Dan (f: ident) (aexps : list aexp_Dan).

(*
 * Custom induction principle with stronger handling of containers,
 * based on this trick: https://pastebin.com/BAvg3Jdh
 *)
Section aexp_Dan_ind2.
  Variable P: aexp_Dan -> Prop. (* this is the property we want to prove *)

  (* For each constructor, we add a Variable *)
  Variable fconst : forall n : nat, P (CONST_Dan n).
  Variable fvar : forall x : ident, P (VAR_Dan x).
  Variable fparam : forall n : nat, P (PARAM_Dan n).
  Variable fplus :
    forall a1 : aexp_Dan, P a1 -> forall a2 : aexp_Dan, P a2 -> P (PLUS_Dan a1 a2).
  Variable fminus :
    forall a1 : aexp_Dan, P a1 -> forall a2 : aexp_Dan, P a2 -> P (MINUS_Dan a1 a2).
  Variable fapp :
    forall f (aexps : list aexp_Dan), List.Forall P aexps -> P (APP_Dan f aexps).

  Fixpoint aexp_Dan_ind2 (a : aexp_Dan) : P a :=
    match a as a0 return (P a0) with
    | CONST_Dan n => fconst n
    | VAR_Dan x => fvar x
    | PARAM_Dan n => fparam n
    | PLUS_Dan a1 a2 => fplus a1 (aexp_Dan_ind2 a1) a2 (aexp_Dan_ind2 a2)
    | MINUS_Dan a1 a2 => fminus a1 (aexp_Dan_ind2 a1) a2 (aexp_Dan_ind2 a2)
    | APP_Dan f aexps =>
        fapp f aexps
          ((fix L aexps :=
             match aexps return (Forall P aexps) with
             | nil => Forall_nil _
             | cons a aexps_tl => Forall_cons a (aexp_Dan_ind2 a) (L aexps_tl) end) aexps)
    end.
End aexp_Dan_ind2.

(* set version *)
Section aexp_Dan_rec2.
  Variable P: aexp_Dan -> Set. (* this is the property we want to prove *)

  (* For each constructor, we add a Variable *)
  Variable fconst : forall n : nat, P (CONST_Dan n).
  Variable fvar : forall x : ident, P (VAR_Dan x).
  Variable fparam : forall n : nat, P (PARAM_Dan n).
  Variable fplus :
    forall a1 : aexp_Dan, P a1 -> forall a2 : aexp_Dan, P a2 -> P (PLUS_Dan a1 a2).
  Variable fminus :
    forall a1 : aexp_Dan, P a1 -> forall a2 : aexp_Dan, P a2 -> P (MINUS_Dan a1 a2).

   Inductive SForall : list aexp_Dan -> Set :=
   | SForall_nil : SForall nil
   | SForall_cons : forall x l, P x -> SForall l -> SForall (x::l).

  Variable fapp :
    forall f (aexps : list aexp_Dan), SForall aexps -> P (APP_Dan f aexps).

  Fixpoint aexp_Dan_rec2 (a : aexp_Dan) : P a :=
    match a as a0 return (P a0) with
    | CONST_Dan n => fconst n
    | VAR_Dan x => fvar x
    | PARAM_Dan n => fparam n
    | PLUS_Dan a1 a2 => fplus a1 (aexp_Dan_rec2 a1) a2 (aexp_Dan_rec2 a2)
    | MINUS_Dan a1 a2 => fminus a1 (aexp_Dan_rec2 a1) a2 (aexp_Dan_rec2 a2)
    | APP_Dan f aexps =>
        fapp f aexps
          ((fix L aexps :=
             match aexps return (SForall aexps) with
             | nil => SForall_nil
             | cons a aexps_tl => SForall_cons a _ (aexp_Dan_rec2 a) (L aexps_tl) end) aexps)
    end.
End aexp_Dan_rec2.

(* Definition aexp_vector (n: nat): Type := VectorDef.t aexp_Dan n. *)

(* Definition nil_aexp_vector: aexp_vector 0 := nil aexp_Dan. *)

Declare Scope dantrick_scope.

Infix "+d" := PLUS_Dan (at level 76) : dantrick_scope.
Infix "-d" := MINUS_Dan (at level 76) : dantrick_scope.
Infix "@d" := APP_Dan (at level 76) : dantrick_scope.

Inductive bexp_Dan :=
| TRUE_Dan
| FALSE_Dan
| NEG_Dan (b: bexp_Dan)
| AND_Dan (b1 b2: bexp_Dan)
| OR_Dan  (b1 b2: bexp_Dan)
| LEQ_Dan (a1 a2: aexp_Dan).

Definition eq_Dan (a b : aexp_Dan) : bexp_Dan :=
  AND_Dan (LEQ_Dan a b) (LEQ_Dan b a).
Definition geq_Dan (a b : aexp_Dan) : bexp_Dan :=
  LEQ_Dan b a.
Definition neq_Dan (a b : aexp_Dan) : bexp_Dan :=
  NEG_Dan (eq_Dan a b).
Definition lt_Dan (a b : aexp_Dan) : bexp_Dan :=
  AND_Dan (LEQ_Dan a b) (neq_Dan a b).
Definition gt_Dan (a b : aexp_Dan) : bexp_Dan :=
  lt_Dan b a.

Notation "a '=d' b" := (eq_Dan a b) (at level 50) : dantrick_scope.
Infix "&d" := AND_Dan (at level 50) : dantrick_scope.
Infix "|d" := OR_Dan (at level 50) : dantrick_scope.
Notation "'!d' a" := (NEG_Dan a) (at level 80) : dantrick_scope.
Infix "<=d" := LEQ_Dan (at level 90) : dantrick_scope.
Notation "a '>=d' b" := (geq_Dan a b) (at level 90) : dantrick_scope.
Notation "a '!=d' b" := (neq_Dan a b) (at level 90) : dantrick_scope.
Notation "a '<d' b" := (lt_Dan a b) (at level 90) : dantrick_scope.
Notation "a '>d' b" := (gt_Dan a b) (at level 90) : dantrick_scope.

Inductive imp_Dan :=
  |IF_Dan (b: bexp_Dan) (i1 i2: imp_Dan)
  |SKIP_Dan
  |WHILE_Dan (b: bexp_Dan) (i: imp_Dan)
  |ASSIGN_Dan (x: ident) (a: aexp_Dan)
|SEQ_Dan (i1 i2: imp_Dan).

Section imp_Dan_ind2.
  Variable P: aexp_Dan -> Prop. (* this is the property we want to prove *)
  Variable P0: bexp_Dan -> Prop.
  Variable P1: imp_Dan -> Prop.

  (* For each constructor, we add a Variable *)
  Variable fconst : forall n : nat, P (CONST_Dan n).
  Variable fvar : forall x : ident, P (VAR_Dan x).
  Variable fparam : forall n : nat, P (PARAM_Dan n).
  Variable fplus :
    forall a1 : aexp_Dan, P a1 -> forall a2 : aexp_Dan, P a2 -> P (PLUS_Dan a1 a2).
  Variable fminus :
    forall a1 : aexp_Dan, P a1 -> forall a2 : aexp_Dan, P a2 -> P (MINUS_Dan a1 a2).
  Variable fapp :
    forall f (aexps : list aexp_Dan), List.Forall P aexps -> P (APP_Dan f aexps).
  Variable ftrue : P0 (TRUE_Dan).
  Variable ffalse : P0 (FALSE_Dan).
  Variable fneg : forall b: bexp_Dan, P0 b -> P0 (NEG_Dan b).
  Variable fand : forall b1: bexp_Dan, P0 b1 -> forall b2: bexp_Dan, P0 b2 -> P0 (AND_Dan b1 b2).
  Variable f_or : forall b1: bexp_Dan, P0 b1 -> forall b2: bexp_Dan, P0 b2 -> P0 (OR_Dan b1 b2).
  Variable fleq :
    forall a1 : aexp_Dan, P a1 -> forall a2 : aexp_Dan, P a2 -> P0 (LEQ_Dan a1 a2).
  Variable fskip : P1 SKIP_Dan.
  Variable fassign : forall x: ident, forall a: aexp_Dan, P a -> P1 (ASSIGN_Dan x a).
  Variable fseq : forall i1: imp_Dan, P1 i1 -> forall i2: imp_Dan, P1 i2 -> P1 (SEQ_Dan i1 i2).
  Variable fif : forall b: bexp_Dan, P0 b -> forall i1: imp_Dan, P1 i1 -> forall i2: imp_Dan, P1 i2 -> P1 (IF_Dan b i1 i2).
  Variable fwhile : forall b: bexp_Dan, P0 b -> forall i: imp_Dan, P1 i -> P1 (WHILE_Dan b i).

  Fixpoint imp_aexp_Dan_ind2 (a : aexp_Dan) : P a :=
    match a as a0 return (P a0) with
    | CONST_Dan n => fconst n
    | VAR_Dan x => fvar x
    | PARAM_Dan n => fparam n
    | PLUS_Dan a1 a2 => fplus a1 (imp_aexp_Dan_ind2 a1) a2 (imp_aexp_Dan_ind2 a2)
    | MINUS_Dan a1 a2 => fminus a1 (imp_aexp_Dan_ind2 a1) a2 (imp_aexp_Dan_ind2 a2)
    | APP_Dan f aexps =>
        fapp f aexps
          ((fix L aexps :=
             match aexps return (Forall P aexps) with
             | nil => Forall_nil _
             | cons a aexps_tl => Forall_cons a (imp_aexp_Dan_ind2 a) (L aexps_tl) end) aexps)
    end.
  Fixpoint imp_Dan_ind2 (i: imp_Dan): P1 i :=
           match i as i0 return (P1 i0) with
           | SKIP_Dan => fskip
           | ASSIGN_Dan x a => fassign x a (imp_aexp_Dan_ind2 a)
           | SEQ_Dan i1 i2 => fseq i1 (imp_Dan_ind2 i1) i2 (imp_Dan_ind2 i2)
           | IF_Dan b i1 i2 =>
               fif b ((fix imp_bexp_Dan_ind2 (b: bexp_Dan) : P0 b :=
                         match b as b0 return (P0 b0) with
                         | TRUE_Dan => ftrue
                         | FALSE_Dan => ffalse
                         | NEG_Dan b => fneg b (imp_bexp_Dan_ind2 b)
                         | AND_Dan b1 b2 => fand b1 (imp_bexp_Dan_ind2 b1) b2 (imp_bexp_Dan_ind2 b2)
                         | OR_Dan b1 b2 => f_or b1 (imp_bexp_Dan_ind2 b1) b2 (imp_bexp_Dan_ind2 b2)
                         | LEQ_Dan a1 a2 => fleq a1 (imp_aexp_Dan_ind2 a1) a2 (imp_aexp_Dan_ind2 a2)
                         end) b)
                   i1 (imp_Dan_ind2 i1) i2 (imp_Dan_ind2 i2)
           | WHILE_Dan b i =>
               fwhile b ((fix imp_bexp_Dan_ind2 (b: bexp_Dan) : P0 b :=
                            match b as b0 return (P0 b0) with
                            | TRUE_Dan => ftrue
                            | FALSE_Dan => ffalse
                            | NEG_Dan b => fneg b (imp_bexp_Dan_ind2 b)
                            | AND_Dan b1 b2 => fand b1 (imp_bexp_Dan_ind2 b1) b2 (imp_bexp_Dan_ind2 b2)
                            | OR_Dan b1 b2 => f_or b1 (imp_bexp_Dan_ind2 b1) b2 (imp_bexp_Dan_ind2 b2)
                            | LEQ_Dan a1 a2 => fleq a1 (imp_aexp_Dan_ind2 a1) a2 (imp_aexp_Dan_ind2 a2)
                            end) b)
                      i (imp_Dan_ind2 i)
           end.
End imp_Dan_ind2.

Notation "x <- e" := (ASSIGN_Dan x e) (at level 75) : dantrick_scope.
Infix ";;" := SEQ_Dan (at level 76) : dantrick_scope.
Notation "'when' b 'then' t 'else' e 'done'" :=
  (IF_Dan b t e) (at level 75, b at level 0) : dantrick_scope.
Notation "'while' b 'loop' body 'done'" :=
  (WHILE_Dan b body) (at level 75) : dantrick_scope.

Local Open Scope dantrick_scope.

Record fun_Dan :=
  { Name: ident
  ; Args : nat
  ; Ret: ident
  ; Body: imp_Dan }.

Definition fun_env := store fun_Dan.

Definition init_fenv: fun_env := fun _ => {| Name := "id"
                                          ; Args := 1
                                          ; Ret := "x"
                                          ; Body := "x" <- (PARAM_Dan 0) |}.

Inductive prog_Dan :=
| PROF_Dan (l: list fun_Dan) (i: imp_Dan).

Local Open Scope vector_scope.

Inductive a_Dan : aexp_Dan -> list nat -> fun_env -> nat_env -> nat -> Prop :=
| Dan_const :
  forall dbenv fenv nenv n,
    a_Dan (CONST_Dan n) dbenv fenv nenv n
| Dan_var :
  forall dbenv fenv nenv x n,
    (nenv x = n) ->
    a_Dan (VAR_Dan x) dbenv fenv nenv n
| Dan_param :
  forall dbenv fenv nenv n m,
    0 <= n < List.length dbenv ->
    nth_error dbenv n = Some m ->
    a_Dan (PARAM_Dan n) dbenv fenv nenv m
| Dan_plus :
  forall dbenv fenv nenv a1 a2 n1 n2,
    a_Dan a1 dbenv fenv nenv n1 ->
    a_Dan a2 dbenv fenv nenv n2 ->
    a_Dan (PLUS_Dan a1 a2) dbenv fenv nenv (n1 + n2)
| Dan_minus :
  forall dbenv fenv nenv a1 a2 n1 n2,
    a_Dan a1 dbenv fenv nenv n1 ->
    a_Dan a2 dbenv fenv nenv n2 ->
    a_Dan (MINUS_Dan a1 a2) dbenv fenv nenv (n1 - n2)
| Dan_app :
  forall dbenv fenv nenv nenv'' func aexps ns ret f,
    (fenv f = func) ->
    (Args func) = Datatypes.length aexps ->
    args_Dan aexps dbenv fenv nenv ns ->
    (i_Dan (func).(Body) ns fenv init_nenv nenv'') ->
    (nenv'' ((func).(Ret)) = ret) ->
    a_Dan (APP_Dan f aexps) dbenv fenv nenv ret
with args_Dan: list aexp_Dan -> list nat -> fun_env -> nat_env -> list nat -> Prop :=
| args_nil :
  forall dbenv fenv nenv,
    args_Dan nil dbenv fenv nenv nil%list
| args_cons :
  forall aexp aexps dbenv fenv nenv v vals,
    a_Dan aexp dbenv fenv nenv v ->
    args_Dan aexps dbenv fenv nenv vals ->
    args_Dan (aexp :: aexps) dbenv fenv nenv (v :: vals)
with b_Dan: bexp_Dan -> list nat -> fun_env -> nat_env -> bool -> Prop :=
|Dan_true :
  forall dbenv fenv nenv,
    b_Dan TRUE_Dan dbenv fenv nenv true
|Dan_false :
  forall dbenv fenv nenv,
    b_Dan FALSE_Dan dbenv fenv nenv false
|Dan_neg :
  forall dbenv fenv nenv bexp b,
    b_Dan bexp dbenv fenv nenv b ->
    b_Dan (NEG_Dan bexp) dbenv fenv nenv (negb b)
|Dan_and :
  forall dbenv fenv nenv bexp1 bexp2 b1 b2,
    b_Dan bexp1 dbenv fenv nenv b1 ->
    b_Dan bexp2 dbenv fenv nenv b2 ->
    b_Dan (AND_Dan bexp1 bexp2) dbenv fenv nenv (andb b1 b2)
|Dan_or :
  forall dbenv fenv nenv bexp1 bexp2 b1 b2,
    b_Dan bexp1 dbenv fenv nenv b1 ->
    b_Dan bexp2 dbenv fenv nenv b2 ->
    b_Dan (OR_Dan bexp1 bexp2) dbenv fenv nenv (orb b1 b2)
|Dan_leq :
  forall dbenv fenv nenv a1 a2 n1 n2,
      a_Dan a1 dbenv fenv nenv n1 ->
      a_Dan a2 dbenv fenv nenv n2 ->
      b_Dan (LEQ_Dan a1 a2) dbenv fenv nenv (Nat.leb n1 n2)
with i_Dan : imp_Dan -> list nat -> fun_env -> nat_env -> nat_env -> Prop :=
| Dan_skip :
  forall dbenv fenv nenv,
    i_Dan SKIP_Dan dbenv fenv nenv nenv
| Dan_if_true :
  forall dbenv fenv nenv nenv' bexp i1 i2,
    b_Dan bexp dbenv fenv nenv true ->
    i_Dan i1 dbenv fenv nenv nenv' ->
    i_Dan (IF_Dan bexp i1 i2) dbenv fenv nenv nenv'
| Dan_if_false :
  forall dbenv fenv nenv nenv' bexp i1 i2,
    b_Dan bexp dbenv fenv nenv false ->
    i_Dan i2 dbenv fenv nenv nenv' ->
    i_Dan (IF_Dan bexp i1 i2) dbenv fenv nenv nenv'
| Dan_assign :
  forall dbenv fenv nenv x a n,
    a_Dan a dbenv fenv nenv n ->
    i_Dan (ASSIGN_Dan x a) dbenv fenv nenv (update x n nenv)
| Dan_while_done :
  forall dbenv fenv nenv bexp i,
    b_Dan bexp dbenv fenv nenv false ->
    i_Dan (WHILE_Dan bexp i) dbenv fenv nenv nenv
| Dan_while_step :
  forall dbenv fenv nenv nenv' nenv'' bexp i,
    b_Dan bexp dbenv fenv nenv true ->
    i_Dan i dbenv fenv nenv nenv' ->
    i_Dan (WHILE_Dan bexp i) dbenv fenv nenv' nenv'' ->
    i_Dan (WHILE_Dan bexp i) dbenv fenv nenv nenv''
| Dan_seq : forall dbenv fenv nenv nenv' nenv'' i1 i2,
    i_Dan i1 dbenv fenv nenv nenv' ->
    i_Dan i2 dbenv fenv nenv' nenv'' ->
    i_Dan (SEQ_Dan i1 i2) dbenv fenv nenv nenv''
.

Scheme i_Dan_mut := Induction for i_Dan Sort Prop
    with a_Dan_mut := Induction for a_Dan Sort Prop
                      with b_Dan_mut := Induction for b_Dan Sort Prop
                      with args_Dan_mut := Induction for args_Dan Sort Prop.

Combined Scheme i_Dan_mutind from i_Dan_mut,a_Dan_mut,b_Dan_mut,args_Dan_mut.

Ltac inv H :=
  inversion H; subst; try (reflexivity || assumption).

Ltac smart_inversion_helper :=
  multimatch goal with
  | [ IH : (forall x, ?dan ?dan_syntax _ _ ?nenv x -> _ = x),
        H: ?dan ?dan_syntax _ _ ?nenv _ |- _ ] => apply IH in H; try (assumption || reflexivity)
  | [ IH: forall n1, ?blah_Dan ?dan_syntax ?dbenv ?fenv ?nenv n1 -> ?nenv'' = n1, Heq: ?nenv = ?nenv''', Hblah_Dan: ?blah_Dan ?dan_syntax ?dbenv ?fenv ?nenv''' ?nenv' |- ?nenv'' = ?nenv' ] =>
      rewrite <- Heq in Hblah_Dan; apply IH in Hblah_Dan; assumption
  end.

Ltac smart_rewriter :=
  match goal with
  | [ a : ?T, b : ?T |- _ ] =>
      match goal with
      | [ H: a = b |- _ ] => rewrite H; try reflexivity
      end
  end.

Ltac det_smart_inversion :=
  match goal with
  | [ H': ?dan _ _ _ _ ?res' |- ?res = ?res' ] => inv H'; repeat smart_inversion_helper; repeat smart_rewriter
  end.

Tactic Notation "substs" :=
  repeat (match goal with H: ?x = ?y |- _ =>
            first [ subst x | subst y ] end).

Theorem big_step_deterministic :
    (forall i dbenv fenv nenv nenv',
        i_Dan i dbenv fenv nenv nenv' ->
        forall nenv'',
        i_Dan i dbenv fenv nenv nenv'' ->
        nenv' = nenv'') /\
      (forall a dbenv fenv nenv n,
          a_Dan a dbenv fenv nenv n ->
          forall n',
          a_Dan a dbenv fenv nenv n' ->
          n = n')
    /\
      (forall b dbenv fenv nenv v,
          b_Dan b dbenv fenv nenv v ->
          forall v',
          b_Dan b dbenv fenv nenv v' ->
          v = v')
    /\
      (forall args dbenv fenv nenv vals,
          args_Dan args dbenv fenv nenv vals ->
          forall vals',
          args_Dan args dbenv fenv nenv vals' ->
          vals = vals').
Proof.
  pose (fun i db f n n0 => fun H: i_Dan i db f n n0 => forall n1, i_Dan i db f n n1 -> n0 = n1) as P.
  pose (fun a db f n n0 => fun Ha: a_Dan a db f n n0 => forall n1, a_Dan a db f n n1 -> n0 = n1) as P0.
  pose (fun b db f n n0 => fun Hb: b_Dan b db f n n0 => forall n1, b_Dan b db f n n1 -> n0 = n1) as P1.
  pose (fun args db f n n0 => fun Hargs: args_Dan args db f n n0 => forall n1, args_Dan args db f n n1 -> n0 = n1) as P2.
  apply (i_Dan_mutind P P0 P1 P2); unfold P, P0, P1, P2 in *; intros; try det_smart_inversion; try discriminate; try (substs; reflexivity).
  - (* The function application case is the one case I couldn't get the automation to work on lol *)
    rewrite H2 in e.
    inversion e.
    reflexivity.
  - rewrite <- H6 in H7.
    apply H0 in H7.
    smart_rewriter.
Qed.

Ltac destruct_dan H :=
  destruct H as [Hi_Dan [Ha_Dan [Hb_Dan Hargs_Dan]]].

Theorem big_step_deterministic_human_version :
  forall dbenv fenv nenv,
    (forall i nenv' nenv'',
        i_Dan i dbenv fenv nenv nenv' ->
        i_Dan i dbenv fenv nenv nenv'' ->
        nenv' = nenv'')
    /\
      (forall a n n',
          a_Dan a dbenv fenv nenv n ->
          a_Dan a dbenv fenv nenv n' ->
          n = n')
    /\
      (forall b v v',
          b_Dan b dbenv fenv nenv v ->
          b_Dan b dbenv fenv nenv v' ->
          v = v')
    /\
      (forall args vals vals',
          args_Dan args dbenv fenv nenv vals ->
          args_Dan args dbenv fenv nenv vals' ->
          vals = vals').
Proof.
  intros dbenv fenv nenv.
  split; [ | split; [ | split ]]; intros; pose proof big_step_deterministic; destruct_dan H1.
  - eapply Hi_Dan; eassumption.
  - eapply Ha_Dan; eassumption.
  - eapply Hb_Dan; eassumption.
  - eapply Hargs_Dan; eassumption.
Qed.

(* Helper theorems that just show that each relation is deterministic without
 * having to do all the splitting nonsense. *)

Theorem i_Dan_deterministic :
  forall dbenv fenv nenv i nenv' nenv'',
    i_Dan i dbenv fenv nenv nenv' ->
    i_Dan i dbenv fenv nenv nenv'' ->
    nenv' = nenv''.
Proof.
  intros. pose proof (big_step_deterministic_human_version dbenv fenv nenv) as DET.
  destruct_dan DET. eapply Hi_Dan; eassumption.
Qed.

Theorem a_Dan_deterministic :
  forall dbenv fenv nenv a n n',
    a_Dan a dbenv fenv nenv n ->
    a_Dan a dbenv fenv nenv n' ->
    n = n'.
Proof.
  intros. pose proof (big_step_deterministic_human_version dbenv fenv nenv) as Hdet.
  destruct_dan Hdet. eapply Ha_Dan; eassumption.
Qed.

Theorem b_Dan_deterministic :
  forall dbenv fenv nenv b v v',
    b_Dan b dbenv fenv nenv v ->
    b_Dan b dbenv fenv nenv v' ->
    v = v'.
Proof.
  intros. pose proof (big_step_deterministic_human_version dbenv fenv nenv) as Hdet.
  destruct_dan Hdet. eapply Hb_Dan; eassumption.
Qed.

Theorem args_Dan_deterministic :
  forall dbenv fenv nenv args vals vals',
    args_Dan args dbenv fenv nenv vals ->
    args_Dan args dbenv fenv nenv vals' ->
    vals = vals'.
Proof.
  intros. pose proof (big_step_deterministic_human_version dbenv fenv nenv) as DET.
  destruct_dan DET. eapply Hargs_Dan; eassumption.
Qed.

Definition options_to_prod_option {A B: Type} (a: option A) (b: option B) : option (A * B) :=
  match (a, b) with
  | (Some a', Some b') => Some (a', b')
  | _ => None
  end.

Definition prod_add (n: nat * nat): nat :=
  match n with
  | (n', n'') => n' + n''
  end.

Definition prod_minus (n: nat * nat) : nat :=
  match n with
  | (n', n'') => n' - n''
  end.

Definition option_bind {A B: Type} (a: option A) (f: A -> option B): option B :=
  match a with
  | Some x => f x
  | None => None
  end.

Definition option_map_map {A B C: Type} (f: A -> B -> C) (a: option A) (b: option B): option C :=
  match a with
  | Some a' => option_map (f a') b
  | _ => None
  end.

Definition nat_option_map_2 (f: nat -> nat -> nat) (a b : option nat): option nat :=
  option_map_map f a b.

Definition option_apply {A B : Type} (f: option (A -> B)) (a: A): option B :=
  match f with
  | Some f' => Some (f' a)
  | _ => None
  end.

Print option_map.

Print Nat.add.
Print Nat.sub.
Print Nat.leb.

Print Implicit option_map_map.

(* Temporarily disable printing, without having to remove prints *)
Definition print {T: Type} (x: T) := x.

Definition print_id {T: Type}  (x: T) := x.

Fixpoint eval_aDan (a: aexp_Dan) (fuel: nat) (dbenv: list nat) (fenv: fun_env) (nenv: nat_env) : option nat :=
  let blah := print "[eval_aDan" in
  let blah2 := print a in
  let blah3 := print nenv in
  match (print_id fuel) with
    | 0 =>
        let big_res :=
          (match a with
           | CONST_Dan n => Some n
           | VAR_Dan x => Some (nenv x)
           | PARAM_Dan n => nth_error dbenv n
           | _ => None
           end) in
        let blah4 := print "eval_aDan]" in
        big_res
    | S fuel' =>
        let big_res :=
          (
            match a with
            | CONST_Dan n => Some n
            | VAR_Dan x => Some (nenv x)
            | PARAM_Dan n => nth_error dbenv n
            | PLUS_Dan a1 a2 =>
                option_map_map
                  Nat.add
                  (eval_aDan a1 fuel' dbenv fenv nenv)
                  (eval_aDan a2 fuel' dbenv fenv nenv)
            | MINUS_Dan a1 a2 =>
                option_map_map
                  Nat.sub
                  (eval_aDan a1 fuel' dbenv fenv nenv)
                  (eval_aDan a2 fuel' dbenv fenv nenv)
            | APP_Dan f a =>
                let blah_app := print "[app " in
                let eval_dbenv :=
                  eval_args_Dan a
                                fuel'
                                dbenv
                                fenv
                                nenv in
                let return_nenv :=
                  (option_bind
                     eval_dbenv
                     (fun dbenv' =>
                        eval_fuel_Dan ((fenv f).(Body)) fuel' dbenv' fenv init_nenv)) in
                let res :=
                  option_map
                    (fun return_nenv => return_nenv ((fenv f).(Ret)))
                    return_nenv in
                let blah_app_1 := print "app]" in
                res
            end) in
        let blah4' := print big_res in
        let blah4 := print "eval_aDan]" in
        big_res
  end
with eval_args_Dan (arg_exprs: list aexp_Dan)  (fuel: nat) (dbenv: list nat) (fenv: fun_env) (nenv: nat_env) : option (list nat) :=
       match fuel with
       | 0 => None
       | S fuel' =>
           match arg_exprs with
           | e :: exprs =>
               let result_e := eval_aDan e fuel' dbenv fenv nenv in
               match result_e with
               | Some v =>
                   match (eval_args_Dan exprs fuel' dbenv fenv nenv) with
                   | None =>
                       None
                   | Some dbenv' =>
                       Some (cons v dbenv')
                       end
               | None =>
                   None
               end
           | nil =>
               Some nil
           end
       end
with eval_bDan (b: bexp_Dan) (fuel: nat) (dbenv: list nat) (fenv: fun_env) (nenv: nat_env) : option bool :=
       let blah := print "[eval_bDan" in
       let blah' := print b in
       match fuel with
       | 0 => let blah2 := print "eval_bDan]" in
              None
       | S fuel' =>
           let big_res := (match b with
           | TRUE_Dan => Some true
           | FALSE_Dan => Some false
           | NEG_Dan b' =>
               option_map
                 negb
                 (eval_bDan b' fuel' dbenv fenv nenv)
           | AND_Dan b1 b2 =>
               option_map_map
                 andb
                 (eval_bDan b1 fuel' dbenv fenv nenv)
                 (eval_bDan b2 fuel' dbenv fenv nenv)
           | OR_Dan  b1 b2 =>
               option_map_map
                 orb
                 (eval_bDan b1 fuel' dbenv fenv nenv)
                 (eval_bDan b2 fuel' dbenv fenv nenv)
           | LEQ_Dan a1 a2 =>
               option_map_map
                 Nat.leb
                 (eval_aDan a1 fuel' dbenv fenv nenv)
                 (eval_aDan a2 fuel' dbenv fenv nenv)
                           end) in
           let blah2' := print big_res in
           let blah2 := print "eval_bDan]" in
           big_res
       end
with eval_fuel_Dan (i: imp_Dan) (fuel: nat) (dbenv: list nat) (fenv: fun_env) (nenv: nat_env) : option nat_env :=
       let blah := print "[eval_fuel_Dan" in
       let blah1 := print i in
       let blah2 := print fuel in
       let blah3 := print nenv in
       match fuel with
       | 0 =>
           match i with
           | SKIP_Dan =>
              Some nenv
           | _ =>
              let blah0 := print "]" in None
           end
       | S fuel' =>
           match (print_id i) with
           | SKIP_Dan =>
               let blahskip1 := print "]" in
               Some nenv
           | ASSIGN_Dan x a =>
               let res := eval_aDan a fuel' dbenv fenv nenv in
               let res' := option_map (fun res => update (print_id x) (print_id res) nenv) res in
               let blahassign1 := print "]" in
               res'

           | IF_Dan b i1 i2 =>
               let bres := eval_bDan b fuel' dbenv fenv nenv in
               let next_instruction := option_map (fun (bres': bool) => if bres' then i1 else i2) bres in
               let res: option nat_env := option_bind next_instruction (fun (i: imp_Dan) => eval_fuel_Dan i fuel' dbenv fenv nenv) in
               let blahif1 := print "]" in
               res
           | WHILE_Dan b i' =>
               let bres := eval_bDan b fuel' dbenv fenv nenv in
               option_bind bres (fun bres' =>
                                   if bres' then
                                     let new_nenv: option nat_env := eval_fuel_Dan i' fuel' dbenv fenv nenv in
                                     let res: option nat_env := option_bind new_nenv (eval_fuel_Dan i fuel' dbenv fenv) in
                                     let blahwhile1 := print "]" in
                                     res
                                   else
                                     Some nenv)
           | SEQ_Dan i1 i2 =>
               let new_nenv: option nat_env := eval_fuel_Dan i1 fuel' dbenv fenv nenv in
               let res: option nat_env := option_bind new_nenv (eval_fuel_Dan i2 fuel' dbenv fenv) in
               let blahseq1 := print "]" in
               res
           end
       end.

Definition default_fuel := 1000.

Ltac invc H :=
  inversion H; subst; clear H.

Ltac duplicate_proof H H' :=
  pose proof H as H'.

Tactic Notation "dupe" ident(H) "as" ident(H') := (duplicate_proof H H').

Fixpoint construct_fenv lst (f: fun_env) : fun_env :=
  match lst with
  | nil => f
  | foo::foos => construct_fenv foos (update ((foo).(Name)) foo f)
  end.

Definition eval_fuel_pDan (p: prog_Dan) (fuel: nat) (nenv: nat_env): option nat_env :=
  match p with
  | PROF_Dan lst imp =>
      let new_fenv := construct_fenv lst init_fenv in
      eval_fuel_Dan imp fuel nil new_fenv init_nenv
  end.


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

Definition next_day (d:day) : day :=
  match d with
  | monday    => tuesday
  | tuesday   => wednesday
  | wednesday => thursday
  | thursday  => friday
  | friday    => saturday
  | saturday  => sunday
  | sunday    => monday
end.

Compute (next_day monday).

Compute (next_day (next_day saturday)).

Example test_next_day:
  (next_day (next_day tuesday)) = thursday.
Proof. simpl. reflexivity. Qed.