(*
    Proof of Correctness of Insertion Sort from scratch
    Only assumptions include existence of a type with
    a decidable ordering that is transitive and antisymmetric.

    Last updated 28th December 2021
*)

Section Sorting.
  Inductive list {T : Type} : Type :=
  | nil_list : list
  | cons_list : T -> list -> list.

  Inductive Bool : Set :=
  | false : Bool
  | true : Bool.

  Inductive True : Prop :=
  | yes : True.

  Register True as core.True.type.

  Inductive False : Prop :=.

  Register False as core.False.type.

  Definition is_true (b : Bool) :=
  match b with
  | true => True
  | false => False
  end.

  Inductive inhabited (T : Type) : Prop := inhabits : T -> inhabited T.

  Lemma prop_eq_iff : forall (P Q : Prop), P = Q -> (P <-> Q).
  Proof.
    split. all: intro.
    rewrite H in H0. trivial.
    rewrite <- H in H0. trivial.
  Qed.

  Lemma forall_and : forall {T : Type}(P Q : T -> Prop),
    (forall t : T, P t /\ Q t) <->
    (forall t : T, P t) /\ (forall t : T, Q t).
  Proof.
    split. intro. split. apply H. apply H.
    intros. destruct H as [H G]. split. apply (H t). apply (G t).
  Qed.

  Lemma diff_true_false : true <> false.
  Proof.
    intro. apply f_equal with (f := fun t => is_true t) in H.
    simpl in H. apply prop_eq_iff in H. destruct H. contradiction.
  Qed.

  Lemma diff_false_true : false <> true.
  Proof.
    intro. symmetry in H. apply diff_true_false in H. contradiction.
  Qed.

  Definition diff_bool : true <> false /\ false <> true.
  Proof.
    split. apply diff_true_false. apply diff_false_true.
  Qed.

  Inductive Nat : Set :=
  | zero : Nat
  | succ : Nat -> Nat.

  Theorem zero_not_succ : forall (n : Nat), succ n <> zero.
  Proof.
    set (N2B (n : Nat) := match n with | succ n' => true | zero => false end).
    intro. induction n.
    all: intro; apply f_equal with (f := fun t => N2B t) in H;
    simpl in H; apply diff_bool in H; contradiction.
  Qed.

  Theorem nat_not_succ : forall (n : Nat), succ n <> n.
  Proof.
    intro. induction n. apply zero_not_succ.
    intro. inversion H. contradiction.
  Qed.

  Fixpoint add (n m : Nat) :=
  match n with
  | zero => m
  | succ n' => succ (add n' m)
  end.

  Lemma add_id_r : forall n, add n zero = n.
  Proof.
    intro. induction n. trivial.
    simpl. rewrite IHn. reflexivity.
  Qed.

  Lemma add_succ_r : forall n m, add n (succ m) = succ (add n m).
  Proof.
    intros. induction n. trivial.
    simpl. rewrite IHn. reflexivity.
  Qed.

  Lemma add_comm : forall n m, add n m = add m n.
  Proof.
    intros. induction m. rewrite add_id_r. trivial.
    simpl. rewrite add_succ_r, IHm. reflexivity.
  Qed.

  Fixpoint sum_over_list {T : Type} (f : T -> Nat) (l : list) :=
  match l with
  | nil_list => zero
  | cons_list a w => add (f a) (sum_over_list f w)
  end.

  Lemma nil_list_unique : forall {T : Type} (l : @list T) t,
    (cons_list t l) <> nil_list.
  Proof.
    intros T l t H.
    apply f_equal with
      (f := fun k => match k with | nil_list => true | _ => false end)
    in H.
    apply diff_bool, H.
  Qed.

  Ltac destruct_bool := intros; destruct_all Bool; simpl in *; trivial; try discriminate.

  Lemma bool_decidability : forall (a b : Bool), {a = b} + {a <> b}.
  Proof.
    intros. destruct_bool.
    left. reflexivity. right. apply diff_bool.
    right. apply diff_bool. left. reflexivity.
  Qed.

  Lemma true_proof (P : Prop) : (True -> P) -> P.
  Proof.
    intro. exact (H yes).
  Qed.

  Definition band (a b : Bool) : Bool :=
  match a, b with
  | true, true => true
  | _, _ => false
  end.
  Infix "&&" := band (at level 40, left associativity).

  Definition bor (a b : Bool) : Bool :=
  match a, b with
  | true, _ => true
  | _, true => true
  | _, _ => false
  end.
  Infix "||" := bor (at level 50, left associativity).

  Inductive Permutation {T : Type} : @list T -> list -> Prop :=
  | perm_nil : Permutation nil_list nil_list
  | perm_skip : forall a x y, Permutation x y -> Permutation (cons_list a x) (cons_list a y)
  | perm_swap : forall a b x, Permutation (cons_list a (cons_list b x)) (cons_list b (cons_list a x))
  | perm_trans : forall x y z, Permutation x y -> Permutation y z -> Permutation x z.

  Definition perm_id : forall {T : Type} (l : @list T), Permutation l l.
  Proof.
    intro. induction l. exact perm_nil. exact (perm_skip t l l IHl).
  Qed.

  Definition perm_refl :
    forall {T : Type} (x y : @list T), Permutation x y -> Permutation y x.
  Proof.
    intros. induction H.
    exact perm_nil.
    apply (perm_skip a y x). assumption.
    apply (perm_swap b a x).
    apply (perm_trans z y x IHPermutation2 IHPermutation1).
  Qed.

  Fixpoint length {T : Type} (l : @list T) : Nat :=
  match l with
  | cons_list a w => succ (length w)
  | nil_list  => zero
  end.

  Lemma list_length_zero : forall {T : Type} (l : @list T),
    length l = zero -> l = nil_list.
  Proof.
    intros. induction l.
    reflexivity. simpl in H.
    apply zero_not_succ in H. contradiction.
  Qed.

  Theorem length_invar_perm : forall {T : Type} (x y : @list T),
    Permutation x y -> (length x) = (length y).
  Proof.
    intros. induction H. reflexivity.
    simpl. rewrite IHPermutation. reflexivity.
    simpl. reflexivity.
    rewrite IHPermutation2 in IHPermutation1. assumption.
  Qed.

  Lemma perm_of_nil :
    forall {T : Type} (l : @list T), Permutation l nil_list -> l = nil_list.
  Proof.
    intros. apply length_invar_perm in H. simpl in H.
    apply list_length_zero in H. assumption.
  Qed.

  Fixpoint All {T : Type} (P : T -> Prop) (l : list) : Prop :=
  match l with
  | nil_list => True
  | cons_list x w => (P x) /\ (All P w)
  end.

  Inductive Every {T : Type} (P : T -> Prop) : list -> Prop :=
  | every_nil : Every P nil_list
  | every_cons t l : Every P l -> P t -> Every P (cons_list t l).

  Theorem all_every_equiv : forall {T : Type} (P : T -> Prop) l,
    All P l -> Every P l.
  Proof.
    intros. induction l. exact (every_nil P).
    simpl in H. destruct H. apply IHl in H0.
    exact (every_cons P t l H0 H).
  Qed.

  Theorem every_all_equiv : forall {T : Type} (P : T -> Prop) l,
    Every P l -> All P l.
  Proof.
    intros. induction H. simpl. apply yes.
    simpl. split. apply H0. apply IHEvery.
  Qed.

  Lemma every_rem : forall {T : Type} (P : T -> Prop) t l,
  Every P (cons_list t l) -> Every P l.
  Proof.
    intros. apply every_all_equiv in H. simpl in H. destruct H.
    apply all_every_equiv in H0. apply H0.
  Qed.

  Lemma every_check : forall {T : Type} (P : T -> Prop) t l,
  Every P (cons_list t l) -> P t.
  Proof.
    intros. apply every_all_equiv in H. simpl in H.
    destruct H. apply H.
  Qed.

  Lemma every_expand : forall {T : Type} (P : T -> Prop) t l,
  Every P (cons_list t l) <-> (P t) /\ (Every P l).
  Proof.
    split. intro. split. apply every_all_equiv in H. simpl in H. destruct H.
    apply H. apply every_rem in H. apply H.
    intro. destruct H. apply (every_cons P t l).
    apply H0. apply H.
  Qed.

  Lemma all_in_perms : forall {T : Type} (P : T -> Prop) (x y : list),
    Permutation x y -> All P x -> All P y.
  Proof.
    intros.

    induction H. apply H0.
    simpl in H0. destruct H0. simpl. split.
    apply H0. apply (IHPermutation H1).

    simpl. repeat split.
    all: simpl in H0; repeat destruct H0; trivial.

    apply (IHPermutation2 (IHPermutation1 H0)).
  Qed.

  (*Lemma perm_f_indpndnt : forall {T : Type} (f : @list T -> list) t l,
    Permutation l (f l) -> Permutation (cons_list t (f l)) (f (cons_list t l)).
  Proof.
    intros.
    induction l.
  Qed.*)

  Variable A : Type.
  Variable blt : A -> A -> Bool.
  Variable blt_antisym : forall (a b : A), blt a b = true <-> blt b a = false.
  Variable blt_trans : forall (a b c : A), ((blt a b) && (blt b c)) = (blt a c).

  (*Variable lt : A -> A -> Prop.
  Variable lt_antisym : forall (a b : A), lt a b <-> (lt b a -> False).
  Variable lt_blt_equiv : forall (a b : A), blt a b = true <-> lt a b.
  Variable lt_blt_antiequiv : forall (a b : A), blt a b = false <-> lt b a.
  Variable lt_decidability : forall (a b : A),
    (lt a b /\ not (lt b a)) \/ (lt b a /\ not (lt a b)).*)

  Variable beq : A -> A -> Bool.
  Infix "==" := beq (at level 50, left associativity).

  Variable beq_refl : forall (a : A), a == a = true.

  (*Variable beq_symmetry : forall (a b : A), (a == b) = (b == a).

  Variable beq_transitivity : forall (a b c : A),
    ((a == b) && (b == c)) = (a == c).*)

  Variable beq_eq : forall (a b : A), a == b = true -> a = b.

  Lemma blt_antirefl : forall (a : A), blt a a = false.
  Proof.
    intro. destruct (blt a a) eqn:H.
    reflexivity. apply blt_antisym in H as G.
    rewrite H in G. assumption.
  Qed.

  Lemma blt_decidability : forall (a b : A), {blt a b = true} + {blt a b = false}.
  Proof.
    intros. destruct (blt a b) eqn:H.
    right. reflexivity.
    left. reflexivity.
  Qed.

  Definition lt (a b : A) := blt a b = true.

  Lemma lt_antisym : forall (a b : A), lt a b <-> (lt b a -> False).
  Proof.
    split. unfold lt. intros. apply blt_antisym in H.
    rewrite H0 in H. apply diff_bool in H. contradiction.
    unfold lt. intros. apply blt_antisym.
    destruct (blt b a) eqn:G. reflexivity. contradiction.
  Qed.

  Lemma lt_decidability : forall (a b : A),
    (lt a b /\ not (lt b a)) \/ (lt b a /\ not (lt a b)).
  Proof.
    intros. unfold lt. destruct (blt a b) eqn:H.
    right. split. apply blt_antisym in H.
    apply H. apply diff_bool.
    left. split.
    reflexivity. apply blt_antisym in H. rewrite H. apply diff_bool.
  Qed.

  Lemma lt_blt_equiv : forall (a b : A), blt a b = true <-> lt a b.
  Proof.
    split. intro. unfold lt. assumption.
    intro. unfold lt in H. assumption.
  Qed.

  Lemma lt_blt_antiequiv : forall (a b : A), blt a b = false <-> lt b a.
  Proof.
    split. intro. unfold lt. apply blt_antisym. assumption.
    intro. unfold lt in H. apply blt_antisym. assumption.
  Qed.

  Lemma blt_inv (a b : A) : blt a b = true <-> blt b a = false.
  Proof.
    split. intro. apply lt_blt_equiv, lt_blt_antiequiv in H. apply H.
    intro. apply lt_blt_antiequiv, lt_blt_equiv in H. apply H.
  Qed.

  Fixpoint frequency (l : @list A) (t : A) :=
  match l with
  | nil_list => zero
  | cons_list r w => match t == r with
                     | true => succ (frequency w t)
                     | false => frequency w t
                     end
  end.

  Lemma frequency_cons : forall l t,
    frequency (cons_list t l) t = succ (frequency l t).
  Proof.
    intros. induction l. simpl. rewrite beq_refl. reflexivity.
    destruct (t == t0) eqn:Ht;
    simpl; rewrite Ht; rewrite beq_refl; reflexivity.
  Qed.

  Lemma frequency_succ : forall l t a,
    frequency (cons_list t l) a = succ (frequency l a) -> a == t = true.
  Proof.
    intros. destruct (a == t) eqn:G.
    unfold frequency in H. rewrite G in H. fold frequency in H.
    symmetry in H. apply nat_not_succ in H. contradiction.
    reflexivity.
  Qed.

  Lemma frequency_nil : forall l, (forall t, frequency l t = zero) <->
    l = nil_list.
  Proof.
    split. intros. induction l. reflexivity.

    exfalso. set (G := frequency (cons_list t l) t).
    assert (exists m, G = succ m).
    unfold G, frequency. rewrite beq_refl.
    fold frequency. exists (frequency l t). reflexivity.
    unfold G in H0. rewrite H in H0. destruct H0. symmetry in H0.
    apply (zero_not_succ x H0).

    intros.
    rewrite H. simpl. reflexivity.
  Qed.

  Definition Permutation' (x y : list):= forall (a : A),
    frequency x a = frequency y a.

  Lemma perm'_nil : Permutation' nil_list nil_list.
  Proof.
    unfold Permutation'. trivial.
  Qed.

  Lemma perm'_skip : forall (x y : list) (t : A),
    Permutation' x y -> Permutation' (cons_list t x) (cons_list t y).
  Proof.
    unfold Permutation'. intros.
    destruct (a == t) eqn:Ht;
    simpl; rewrite Ht; rewrite H; reflexivity.
  Qed.

  Lemma perm'_swap : forall (l : list) (a b : A),
    Permutation' (cons_list a (cons_list b l))
                 (cons_list b (cons_list a l)).
  Proof.
    unfold Permutation'. intros.
    destruct (a0 == a) eqn:Ha; destruct (a0 == b) eqn:Hb; simpl;
    rewrite Ha, Hb; reflexivity.
  Qed.

  Lemma perm'_trans : forall (x y z : list),
    Permutation' x y -> Permutation' y z -> Permutation' x z.
  Proof.
    unfold Permutation'. intros x y z Hxy Hyz a.
    rewrite Hxy, Hyz. reflexivity.
  Qed.

  Lemma perm'_of_nil :
    forall (l : list), Permutation' l nil_list -> l = nil_list.
  Proof.
    intros. unfold Permutation' in H. simpl in H.
    apply frequency_nil in H. assumption.
  Qed.

  Theorem Permutation_Permutation'_coincide_r : forall x y,
    Permutation x y -> Permutation' x y.
  Proof.
    intros. induction H.

    apply perm'_nil.
    apply perm'_skip. assumption.
    apply perm'_swap.
    apply (perm'_trans x y z); assumption.
  Qed. (*I haven't been able to prove that the reverse isn't possible*)

  Fixpoint contains {T : Type} (x : list) (t : T) : Prop :=
  match x with
  | nil_list => False
  | cons_list a y => t = a \/ contains y t
  end.

  Inductive contains' {T : Type} : list -> T -> Prop :=
  | contains_cons : forall (x : list) (t : T),
      contains' (cons_list t x) t
  | contains_cont : forall (x : list) (t a : T),
      contains' x t -> contains' (cons_list a x) t.

  Lemma contains_nil : forall {T : Type} (a : T),
    contains nil_list a -> False.
  Proof.
    intros. simpl in H. apply H.
  Qed.

  Lemma contains_singleton : forall {T : Type} (a t : T),
    contains (cons_list a nil_list) t -> t = a.
  Proof.
    intros. simpl in H. destruct H. apply H. contradiction.
  Qed.

  Lemma contains'_nil : forall {T : Type} (a : T),
    contains' nil_list a -> False.
  Proof.
    intros. inversion H as [x b Hl Ha | x b c Ha Hl Ht];
    apply f_equal with (f := fun t => length t) in Hl;
    simpl in Hl; apply zero_not_succ in Hl; contradiction.
  Qed.

  Lemma contains'_cons : forall {T : Type} (x : list) (a t : T),
    contains' (cons_list a x) t -> t = a \/ contains' x t.
  Proof.
    intros. inversion H as [l b Hx Heq | l b c Hcon Hx Heq].
    left; reflexivity. right; apply Hcon.
  Qed.

  Lemma contains'_cons_nil : forall {T : Type} (x : list) (a t : T),
    (contains' (cons_list a x) t -> False) -> (contains' x t -> False).
  Proof.
    intros. apply H. apply contains_cont. apply H0.
  Qed.

  Theorem contains_contains'_coincide : forall (x : list) (t : A),
    contains x t <-> contains' x t.
  Proof.
    split; intro; induction x.

    apply contains_nil in H. contradiction.
    destruct H as [Hl | Hr].
    rewrite Hl. apply contains_cons.
    apply contains_cont, (IHx Hr).

    apply contains'_nil in H. contradiction.
    inversion H as [w|w]. unfold contains. left. reflexivity.
    simpl. apply contains'_cons in H.
    destruct H as [Hl | Hr].
    left; apply Hl. right; apply (IHx Hr).
  Qed.

  Lemma contains_frequency_nil : forall (x : list) (a : A),
    (contains x a -> False) <-> frequency x a = zero.
  Proof.
    split; intros; induction x.

    trivial. destruct_bool. destruct (a == t) eqn:G.
    apply IHx. intro. apply H. right. apply H0.
    intuition. apply beq_eq, H0 in G. contradiction.

    apply contains_nil in H0. contradiction.
    simpl in H0. destruct (a == t) eqn:G.
    unfold frequency in H. rewrite G in H.
    fold frequency in H.
    destruct H0. rewrite H0, beq_refl in G.
    apply diff_true_false in G. contradiction.
    apply (IHx H H0).
    simpl in H. rewrite G in H. apply zero_not_succ in H.
    contradiction.
  Qed.

  Definition Permutation'' (x y : list) := forall (a : A),
    (contains x a <-> contains y a) /\ frequency x a = frequency y a.

  Lemma perm''_nil : Permutation'' nil_list nil_list.
  Proof.
    unfold Permutation''. intro. simpl.
    split; try split; trivial.
  Qed.

(* The following commented-out code is a work in progress.

  Lemma perm''_skip : forall (x y : list) (t : A),
    Permutation'' x y -> Permutation'' (cons_list t x) (cons_list t y).
  Proof.
    unfold Permutation''. intros. split. split.
    destruct (H a) as [Hc Hf].

    simpl. destruct (t == k) eqn:G.
    apply contains'_cons in Hy as G. destruct G.
    simpl. rewrite H0, beq_refl.
    apply f_equal with (f := fun t => succ t).
    apply (H k).

    destruct_bool; destruct (t == k) eqn:G.
    destruct Hx, Hy;
    try ((rewrite H0 in G || rewrite H1 in G); rewrite beq_refl in G;
    apply diff_true_false in G; contradiction).
    apply (H t H0 H1).

    apply f_equal with (f := fun t => succ t).
    apply (H t).
    destruct Hx.
  Qed.

  Lemma perm''_swap : forall (l : list) (a b : A),
    Permutation'' (cons_list a (cons_list b l))
                 (cons_list b (cons_list a l)).
  Proof.
    unfold Permutation'. intros.
    destruct (a0 == a) eqn:Ha; destruct (a0 == b) eqn:Hb; simpl;
    rewrite Ha, Hb; reflexivity.
  Qed.

  Lemma perm''_trans : forall (x y z : list),
    Permutation'' x y -> Permutation'' y z -> Permutation'' x z.
  Proof.
    unfold Permutation''. intros x y z Hxy Hyz a.
    rewrite Hxy, Hyz. reflexivity.
  Qed.

  Lemma perm''_of_nil :
    forall (l : list), Permutation'' l nil_list -> l = nil_list.
  Proof.
    intros. unfold Permutation' in H. simpl in H.
    apply frequency_nil in H. assumption.
  Qed.

  Theorem Permutation'_Permutation''_coincide : forall (x y : list),
    Permutation' x y <-> Permutation'' x y.
  Proof.
    split; intro. induction y.
    apply perm'_of_nil in H. rewrite H.
  Qed.
  *)

  Inductive Sorted : list -> Prop :=
  | nil_sorted : Sorted (nil_list)
  | singleton_sorted a : Sorted (cons_list a (nil_list))
  | list_sorted a b l : Sorted (cons_list b l) -> lt a b
    -> Sorted (cons_list a (cons_list b l)).

  Fixpoint Sorted' (l : list) :=
  match l with
  | nil_list => True
  | cons_list a x => match x with
                     | nil_list => True
                     | cons_list b y => (lt a b) /\ Sorted' x
                     end
  end.

  Lemma Sorted_rem (l : list) : forall (a : A),
    Sorted (cons_list a l) -> Sorted l.
  Proof.
    intros. inversion H.
    apply f_equal with (f := fun t => length t) in H0.
    simpl in H0. symmetry in H0. apply zero_not_succ in H0.
    contradiction.
    exact nil_sorted.
    assumption.
  Qed.

  Lemma Sorted'_rem (l : list) : forall (a : A),
    Sorted' (cons_list a l) -> Sorted' l.
  Proof.
    intros. induction l. trivial.
    simpl in H. destruct H as [lt S'bl].
    induction l. trivial. apply S'bl.
  Qed.

  Theorem Sorted_Sorted'_coincide : forall l, Sorted l <-> Sorted' l.
  Proof.
    split.
    intro. induction H.
    all: simpl; try apply yes.
    split. assumption.
    induction l. apply yes.
    split. simpl in IHSorted.
    destruct IHSorted as [lt S'tl].
    apply lt. apply Sorted'_rem in IHSorted. assumption.

    intro. induction l. exact nil_sorted.
    induction l. exact (singleton_sorted t).
    apply Sorted'_rem in H as G.
    apply IHl in G. simpl in H. destruct H as [lt S't0l].
    apply (list_sorted t t0 l G lt).
  Qed.

  Definition Is_Sorting_Algorithm (f : list -> list) :=
    forall (l : list), (Sorted (f l) /\ Permutation l (f l)).

  Fixpoint insertion (n : A) (l : list) :=
  match l return list with
  | nil_list => cons_list n nil_list
  | cons_list h k => if blt h n then
                       cons_list n (cons_list h k)
                       else cons_list h (insertion n k)
  end.

  Fixpoint insertion_sort (l : list) :=
  match l with
  | nil_list => l
  | cons_list h k => insertion h (insertion_sort k)
  end.

  Lemma insertion_into_sorted_is_sorted : forall (l : list) (a : A),
    Sorted l -> Sorted (insertion a l).
  Proof.
    intros l a S. induction S; simpl. exact (singleton_sorted a).

    destruct (blt a0 a) eqn:H.
    apply lt_blt_antiequiv in H.
    exact (list_sorted a a0 nil_list (singleton_sorted a0) H).
    apply lt_blt_equiv in H.
    exact (list_sorted a0 a nil_list (singleton_sorted a) H).

    destruct (blt a0 a) eqn:G.
    apply lt_blt_antiequiv in G.
    exact (list_sorted a a0 (cons_list b l) (list_sorted a0 b l S H) G).

    destruct (blt b a) eqn:K.
    apply lt_blt_equiv in G. apply lt_blt_antiequiv in K.
    exact (list_sorted a0 a (cons_list b l) (list_sorted a b l S K) G).
    apply lt_blt_equiv in G, K.
    unfold insertion in IHS.
    destruct (blt b a) eqn:L in IHS.
    apply lt_blt_antiequiv in L.

    exfalso.
    destruct (lt_decidability a b) as [dl | dr].
    destruct dl as [x y]. contradiction.
    destruct dr as [x y]. contradiction.

    fold insertion in IHS.
    exact (list_sorted a0 b (insertion a l) IHS H).
  Qed.

  Lemma insertion_into_is_perm_of_cons : forall (a : A) (l : list),
    Permutation (cons_list a l) (insertion a l).
  Proof.
    intros.

    induction l.
    simpl. exact (perm_skip a nil_list nil_list perm_nil).

    unfold insertion. destruct (blt t a) eqn:H.
    exact (perm_id (cons_list a (cons_list t l))). fold insertion.

    set (x := cons_list a (cons_list t l)).
    set (y := cons_list t (cons_list a l)).
    set (z := cons_list t (insertion a l)).
    set (K := perm_swap a t l).
    set (G := perm_skip t (cons_list a l) (insertion a l) IHl).
    apply (perm_trans x y z K G).
  Qed.

  Theorem Insertion_Sort_Is_Sorting_Alg : Is_Sorting_Algorithm insertion_sort.
  Proof.
    unfold Is_Sorting_Algorithm. intros.

    induction l. simpl. split. exact nil_sorted. exact perm_nil.
    destruct IHl as [Hs Hp].
    split. simpl. apply insertion_into_sorted_is_sorted.
    assumption.

    simpl. apply (perm_skip t l (insertion_sort l)) in Hp.

    set (x := cons_list t l).
    set (y := cons_list t (insertion_sort l)).
    set (z := insertion t (insertion_sort l)).
    set (G := insertion_into_is_perm_of_cons t (insertion_sort l)).
    apply (perm_trans x y z Hp G).
  Qed.

  Definition clear_list (l : @list A):= @nil_list A.

  Lemma Clear_List_Sorts : forall (l : list),
    Sorted (clear_list l).
  Proof.
    intros. unfold clear_list. apply nil_sorted.
  Qed.

  Lemma Clear_List_Not_Permutes : forall (l : list),
    l <> nil_list -> Permutation l (clear_list l) -> False.
  Proof.
    intros. destruct l. contradiction.
    unfold clear_list in H0.
    apply perm_of_nil in H0. contradiction.
  Qed.

  Theorem Clear_List_Not_Sorting_Alg : inhabited A -> Is_Sorting_Algorithm clear_list -> False.
  Proof.
    unfold Is_Sorting_Algorithm. intros Hin H.
    apply forall_and in H. destruct H as [H G].
    inversion Hin as [a].
    set (l := cons_list a nil_list).
    assert (l <> nil_list) as Heq by (apply nil_list_unique).
    set (Hn := G l).
    apply (Clear_List_Not_Permutes l Heq Hn).
  Qed.


Require Import List.
Section Last.

Variable A : Set.
Set Implicit Arguments.

Inductive last (a:A) : list A -> Prop :=
   | last_hd : last a (a :: nil)
   | last_tl : forall (b:A) (l:list A), last a l -> last a (b :: l).

Hint Resolve last_hd last_tl.

Fixpoint last_fun (l:list A) : option A :=
  match l with
  | nil => None (A:=A)
  | a :: nil => Some a
  | a :: l' => last_fun l'
  end.

Theorem last_fun_correct :
 forall (a:A) (l:list A), last a l -> last_fun l = Some a.
Proof.
 intros a l H; elim H; simpl; auto.
 intros b l0; case l0; simpl.
 discriminate 2.
 inversion_clear 1; auto.
Qed.

Theorem last_fun_correct2 :
 forall (a:A) (l:list A), last_fun l = Some a -> last a l.
Proof.
 intros a l ; elim l; simpl.
 discriminate 1.
 intros a0 l0; case l0; simpl.
 injection 2.
 intro e; rewrite e; auto.
 auto.
Qed.

Lemma last_fun_of_cons : forall (l:list A) (a:A), last_fun (a :: l) <> None.
Proof.
 intros l ; elim l; simpl.
 intros a H; discriminate H.
 intros a l0 H0 b.
 auto.
Qed.

Theorem last_fun_correct3 :
 forall l:list A, last_fun l = None -> forall b:A, ~ last b l.
Proof.
 intro l; case l.
 simpl.
 red; inversion 2.
 intros a l0 H.
 case (last_fun_of_cons l0 a H).
Qed.

End Last.


Require Import Basics.
Require Import Types.
Require Import Algebra.Group.
Require Import Algebra.AbelianGroup.
Require Import Homotopy.Pi1S1.
Require Import Algebra.Z.
Require Import Pointed.
Require Import Spaces.Int.
Require Import HIT.Circle.
Require Import Truncations.
Require Import Homotopy.HomotopyGroup.
Require Import UnivalenceImpliesFunext.
Import TrM.

Require Import Torus.
Require Import TorusEquivCircles.

Local Open Scope trunc_scope.
Local Open Scope pointed_scope.

(** The torus is 1-truncated *)

Global Instance is1type_Torus `{Univalence} : IsTrunc 1 Torus.
Proof.
  refine (trunc_equiv _ equiv_torus_prod_S1^-1).
Qed.

(** The torus is 0-connected *)

Global Instance isconnected_Torus `{Univalence} : IsConnected 0 Torus.
Proof.
  serapply (isconnected_equiv' _ _ equiv_torus_prod_S1^-1).
  serapply (isconnected_equiv' _ _ (equiv_sigma_prod0 _ _)).
Qed.

(** We give these notations for the pointed versions. *)
Local Notation T := (Build_pType Torus _).
Local Notation S1 := (Build_pType S1 _).

(** Loop space of Torus *)
Theorem loops_torus `{Univalence} : loops T <~>* Int * Int.
Proof.
  srefine (_ o*E _).
  1: exact (loops (S1 * S1)).
  1: apply pequiv_loops_functor.
  { serapply Build_pEquiv.
    1: serapply Build_pMap.
    1: exact equiv_torus_prod_S1.
    1: reflexivity.
    exact _. }
  srefine (_ o*E _).
  1: exact (loops S1 * loops S1).
  1: apply loops_prod.
  simple notypeclasses refine (Build_pEquiv _ _ _ _).
  1: serapply Build_pMap.
  { apply functor_prod.
    1,2: apply equiv_loopS1_int. }
  1: reflexivity.
  exact _.
Defined.

Lemma pequiv_torus_prod_circles `{Funext} : T  <~>* S1 * S1.
Proof.
  serapply Build_pEquiv'.
  1: apply equiv_torus_prod_S1.
  reflexivity.
Defined.

(* Fundamental group of Torus *)

Theorem Pi1Torus `{Univalence}
  : GroupIsomorphism (Pi 1 T) (group_prod Z Z).
Proof.
  etransitivity.
  { apply groupiso_pi_functor.
    apply pequiv_torus_prod_circles. }
  etransitivity.
  1: apply pi_prod.
  apply grp_iso_prod.
  1,2: apply Pi1Circle.
Defined.


Require Import MathClasses.interfaces.canonical_names.
Require Import BijNat.
Require Import Frame.
Require Import MeetSemiLattice.
Require Import PreorderEquiv.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Lists.List.

(**
 This module constructs the free sigma-frame generated
 by a meet semilattice, with relations on the generators.

 It is a formalization of Theorem 3.3 in

 Thierry Coquand, Giovanni Sambin, Jan Smith, Silvio Valentini

 Inductively generated formal topologies

 #http://doai.io/10.1016/S0168-0072(03)00052-6#
 *)

Section Free_Frame.

(** * Definition of the free frame *)

  (** ** Assumptions *)

  (** First we assume a meet semilattice of generators, [T].  Note
      that this structure comes with its own equality (setoid). As in
      the rest of this development, setoid equalities are
      denoted by [a = b], whereas coq's definitional equality is [a ≡
      b] (because we use the setoid equality much more often
      than the definitional one). *)
  Variable T : Type.
  Variable Tle : Le T.
  Variable Tmsl : @MeetSemiLattice T Tle.
  Existing Instance Feq_equiv.

  (**
      There are many ways to present the relations (called here
      axioms) that we want to impose on the generated structure.
      Following the paper, restrict the form of axioms to
      inequalities [a ≤ U], where [a] is a generator and [U]
      is a countable set of generators. Any axiom can be
      written as a conjunction of these.
      These basic axioms are written [a ◁_0 U] in the paper.

      For each generator, we are given an index set for its coverings.
      This formalization allows us to accept an arbitrary number
      of axioms for each generator.

   *)
  Variable Idx : forall t:T, Set.
  (**
      For each generator and an index in its index set,
      we associate a contable family of generators:
      this is understood as enumerating the axiom [t ◁_0 CovAx t i]
  *)
  Variable CovAx : forall t:T, forall i:Idx t, (nat -> T).

  (** ** Inductive covering relation

     The elements of our freely generated structure
     are formal countable unions of generators. Our task
     is therefore define the appropriate frame structure
     on them, starting with the order relation. Again,
     we first restrict the relation to the case where
     the left-hand side is a generator.

     The following inductive definition is very well
     motivated in the paper.
     *)
  Inductive covrel (a : T) : (nat -> T) -> Prop :=
  | cr_refl : forall (U : nat -> T) n, U n = a -> covrel a U
  | cr_inf : forall U : nat -> T, forall b : T, forall i:Idx b, a ≤ b -> (forall n, covrel (a ⊓ (CovAx b i n)) U) -> covrel a U
  | cr_left : forall U : nat -> T, forall b : T, a ≤ b -> covrel b U -> covrel a U.
  (** We note [a ◁ U] when the generator [a] is
      lower than the formal union [U] *)
  Infix "◁" := (covrel) (at level 60).

  Lemma cr_n : forall U n, U n ◁ U.
  Proof. intros. apply cr_refl with (n := n). reflexivity. Qed.

  (** The covering relation ◁ respects the equality
      on the generators. *)
  Lemma covrel_Teq : forall x U, x ◁ U -> forall y, x = y -> y ◁ U.
  Proof.
    intros.
    destruct H0.
    apply cr_left with (b := x) ; assumption.
  Qed.

  Lemma covrel_proper : Proper ((=) ==> eq ==> iff) covrel.
  Proof.
    unfold Proper, respectful.
    intros.
    split ; intro.

    rewrite <- H0.
    apply (covrel_Teq x x0 H1 y H).

    rewrite H0.
    apply (covrel_Teq y y0 H1 x).
    symmetry. apply H.
  Qed.
  Add Parametric Morphism : covrel with signature ((=) ==> eq ==> iff) as covrel_morphism.
  Proof.
    intros. apply covrel_proper. apply H. reflexivity.
  Qed.

  (** ** Preorder and equivalence between coverings
      The [◁] relation can now be used to define
      the order relation on terms.
   *)

  Definition Covrel (U : nat -> T) (V : nat -> T) :=
    forall n : nat, (U n) ◁ V.
  Instance Covrel_le : Le (nat -> T) := Covrel.
  Ltac unfold_Covrel := unfold le, Covrel_le, Covrel.

  (** Transitivity is admissible, by induction
      on [a ◁ U]. *)
  Lemma cr_trans : forall a U W, a ◁ U -> U ≤ W -> a ◁ W.
  Proof.
    intros a U W CR.
    generalize W ; clear W.
    induction CR ; intros.

    - (* cr_left *)
      unfold Covrel in H0.
      rewrite <- H. apply (H0 n).

    - (* cr_inf *)
      assert (forall n, (a ⊓ (CovAx b i n)) ◁ W).
      intro n ; apply (H1 n). apply H2.
      apply (cr_inf a W b i H H3).

    - (* cr_left *)
      apply cr_left with (b := b).
      apply H.
      apply IHCR ; apply H0.
  Qed.

  (** We can now show that [≤] is a preorder *)
  Lemma Covrel_refl : Reflexive Covrel.
  Proof.
    unfold Reflexive.
    intros.
    unfold Covrel.
    intro. apply cr_refl with (n:=n).
    reflexivity.
  Qed.

  Lemma Covrel_trans : Transitive Covrel.
  Proof.
    unfold Transitive.
    intros.
    unfold Covrel; intro.
    apply cr_trans with (U := y).
    apply (H n). apply H0.
  Qed.

  Definition PO_for_FFrame : @Preorder (nat -> T) Covrel :=
    MkPreorder
      (nat -> T)
      Covrel
      Covrel_refl
      Covrel_trans.
  Existing Instance PO_for_FFrame.

  (** This defines an equivalence relation [=]
      on the terms: [a = b <-> a ≤ b /\ b ≤ a].

      The [◁] relation respects the equality
      on the generators (left hand side) and
      our new equality on terms (right hand side).
   *)

  Add Morphism covrel : covrel_morphism2.
  Proof.
    intros x y Heq U W H.
    destruct H as [Hl Hr].
    split ; intro.
    apply cr_left with (b := x).
    rewrite Heq ; apply le_refl.
    apply cr_trans with (U := U) ; auto.

    apply cr_left with (b := y).
    rewrite Heq ; apply le_refl.
    apply cr_trans with (U := W) ; auto.
  Qed.

  (** One simple case where [U ≤ W] is when
      [U] is contained in [W].
       *)
  Definition cov_inj (U W : nat -> T) :=
    forall n, exists m, U n = W m.

  Lemma cov_inj_Covrel : forall U W, cov_inj U W -> U ≤ W.
  Proof.
    intros.
    unfold Covrel ; intro.
    unfold cov_inj in H.
    destruct (H n) as [m Heq].
    apply cr_refl with (n:=m).
    symmetry. exact Heq.
  Qed.

  Ltac by_cov_inj :=
    try (apply cov_inj_Covrel) ;
    unfold cov_inj ;
    intro.

  (** If the terms contain the same generators, they are
      equal. *)
  Lemma covbij_coveq : forall U W : (nat -> T), (forall n, U n = W n) -> U = W.
  Proof.
    intros.
    split ; by_cov_inj ; exists n.
    apply H.
    symmetry. apply H.
  Qed.

  (** A useful shortcut for later: *)
  Lemma cr_right : forall a U W, a ◁ U -> cov_inj U W -> a ◁ W.
  Proof.
    intros.
    apply cr_trans with (U := U).
    apply H.
    apply cov_inj_Covrel.
    apply H0.
  Qed.

  (** ** Binary meet
    We first show the admissibility of the localization rule,
    which relates [◁] to the meet on the generators.
    *)

  Definition down (a : T) (U : nat -> T) : nat -> T :=
    fun n => a ⊓ (U n).

  Infix "↓" := down (at level 50).

  Proposition cr_loc : forall a b U, a ◁ U -> b ⊓ a ◁ b ↓ U.
  Proof.
    intros a b U HR.
    induction HR as [a | a | a].

    - (* cr_refl *)
      apply cr_refl with (n := n).
      unfold down ; simpl.
      rewrite H ; reflexivity.

    - (* cr_inf *)
      apply cr_inf with (b := b0) (i := i).
      apply le_trans with (y := a).
      apply meet_r. assumption.
      intro n.
      rewrite <- meet_assoc.
      apply (H1 n).

    - (* cr_left *)
      apply cr_left with (b := b ⊓ b0).
      apply meet_le_r ; assumption.
      apply IHHR.
  Qed.

  (** We can now define the meet on terms:
      the set of meets of pairs of elements of
      the two terms.
    *)

  Definition CMeet (U : nat -> T) (W : nat -> T) : nat -> T :=
    fun n => (U (bijNN1 n)) ⊓ (W (bijNN2 n)).

  Instance CMeet_meet : Meet (nat -> T) | 50 := CMeet.

  Ltac simpl_bijNN :=
    try (rewrite bijNN1_eq) ; try (rewrite bijNN2_eq) ; simpl.
  Ltac Meet_refl a b :=
    apply cr_refl with (n := bijNN (a,b)) ;
    try (unfold Meet) ;
    simpl_bijNN.

  Lemma CMeet_cov_inj_comm : forall U W : nat -> T, cov_inj (U ⊓ W) (W ⊓ U).
  Proof.
    intros.
    unfold cov_inj.
    intro.
    exists (bijNN (bijNN2 n,bijNN1 n)).
    unfold meet, CMeet_meet, CMeet.
    simpl_bijNN.
    rewrite meet_comm. reflexivity.
  Qed.

  Lemma CMeet_comm : forall U W : nat -> T, U ⊓ W = W ⊓ U.
  Proof.
    intros.
    split ; apply cov_inj_Covrel ; apply CMeet_cov_inj_comm.
  Qed.

  Lemma CMeet_covrel_comm : forall a U W, a ◁ U ⊓ W -> a ◁ W ⊓ U.
  Proof.
    intros.
    apply cr_right with (U := U ⊓ W).
    apply H.
    apply CMeet_cov_inj_comm.
  Qed.

  (* Admissibility of the meet rule *)
  Proposition cr_meet : forall a U W, a ◁ U -> a ◁ W -> a ◁ U ⊓ W.
  Proof.
    intros a U W TU TW.

    assert (a ⊓ a ◁ a ↓ U).
    apply (cr_loc a a U TU).
    rewrite meet_idem in H.

    apply cr_trans with (U := a ↓ U).
    apply H.

    (* Covrel *)
    unfold Covrel. intros p.
    unfold down.
    apply cr_right with (U := (U p) ↓ W).
    rewrite meet_comm. apply cr_loc. apply TW.
    (* cov_inj *)
    by_cov_inj.
    exists (bijNN (p,n)).
    unfold meet, CMeet_meet, CMeet. simpl_bijNN.
    unfold down. reflexivity.
  Qed.

  Proposition Meet_univ : forall U W Z : nat -> T,
                            Z ≤ U -> Z ≤ W -> Z ≤ U ⊓ W.
  Proof.
    unfold_Covrel.
    intros.
    apply cr_meet.
    apply (H n).
    apply (H0 n).
  Qed.

  Proposition CMeet_l : forall U W, U ⊓ W ≤ U.
  Proof.
    unfold_Covrel.
    intros.
    unfold Meet.
    apply cr_left with (b := U (bijNN1 n)).
    apply meet_l.
    apply cr_refl with (n := bijNN1 n).
    reflexivity.
  Qed.

  Proposition CMeet_r : forall U W, U ⊓ W ≤ W.
  Proof.
    intros.
    rewrite CMeet_comm.
    apply CMeet_l.
  Qed.

  (* ** Countable join
     We name it [Vc] because [V] looks like a big
     join and [c] means countable. *)

  Definition Vc (U : nat -> nat -> T) :=
    fun n => U (bijNN1 n) (bijNN2 n).

  Lemma V_le : forall U n, U n ≤ Vc U.
  Proof.
    intros.
    by_cov_inj.
    exists (bijNN (n,n0)).
    unfold Vc.
    rewrite bijNN1_eq, bijNN2_eq.
    reflexivity.
  Qed.

  Lemma V_univ : forall U v, (forall n, U n ≤ v) -> Vc U ≤ v.
  Proof.
    intros.
    unfold Vc, Covrel.
    intro.
    eapply cr_trans.
    eapply cr_refl. reflexivity.
    eapply H.
  Qed.

  (** ** Distributivity of meets over joins *)

  Lemma Cdistr_l : forall a U, a ⊓ (Vc U) ≤ Vc (fun n => a ⊓ (U n)).
  Proof.
    intros.
    unfold meet, CMeet_meet, CMeet, Covrel. intro.
    apply cr_trans with (U := (a (bijNN1 n) ↓ (Vc U))).
    apply cr_loc. eapply cr_refl. reflexivity.
    by_cov_inj.
    exists (bijNN (bijNN1 n0, bijNN (bijNN1 n, bijNN2 n0))).
    unfold Vc, down.
    repeat (rewrite bijNN1_eq, bijNN2_eq ; simpl).
    reflexivity.
  Qed.

  (** ** Top and bottom elements *)

  Definition Bot : nat -> T := fun n => ⊥.
  Instance BotNatT : Bottom (nat -> T) := Bot.

  Lemma Bot_le : forall U, ⊥ ≤ U.
  Proof.
    intro.
    unfold Covrel.
    intro.
    apply cr_left with (b := U O).
    unfold Bot. apply bot_le.
    eapply cr_refl.
    reflexivity.
  Qed.

  Definition Tp : nat -> T := fun n => ⊤.
  Instance TopNatT : Top (nat -> T) := Tp.
  Lemma Top_le : forall U, U ≤ ⊤.
  Proof.
    intro.
    unfold Covrel.
    intro.
    apply cr_left with (b := ⊤).
    apply top_le.
    apply cr_refl with (n := O).
    reflexivity.
  Qed.

  Proposition Top_n : forall U n, (U n = ⊤) -> U = ⊤.
  Proof.
    intros.
    split.
    apply Top_le.
    intro. apply cr_refl with (n := n).
    unfold Top. assumption.
  Qed.

  (** This allows us to define our frame. *)

  Definition MSL_for_FFrame : @MeetSemiLattice (nat -> T) Covrel :=
    MkMSL
      (nat -> T)
      Covrel
      PO_for_FFrame
      Tp
      Top_le
      Bot
      Bot_le
      CMeet
      CMeet_l
      CMeet_r
      Meet_univ.
  Existing Instance MSL_for_FFrame.

  Definition FFrame : @Frame (nat -> T) Covrel :=
    MkFrame
      (nat -> T)
      Covrel
      MSL_for_FFrame
      Vc
      V_le
      V_univ
      Cdistr_l.
  Existing Instance FFrame.

  Definition FFeq := @Feq (nat -> T) Covrel.
  Definition FFeq_setoid := Feq_equivalence PO_for_FFrame.

  (** * Properties of the free frame

      Here, we prove the universal property of the
      frame we have constructed. (This part of the
      proof is implicit in the paper.)

      ** Injection of the generators

      The generators inject in the free frame via
      a meet semilattice morphism.
    *)

  Definition inj_gen (t : T) : (nat -> T) := fun _ => t.

  Instance inj_gen_mslmorph : MSLMorphism Tmsl MSL_for_FFrame inj_gen.
  Proof.
    apply MkMSLMorphism ; unfold inj_gen.
    - apply MkPOMorphism.
      intros.
      unfold le, Covrel. intro.
      apply cr_left with (b := y) ; try assumption.
      apply cr_refl with (n := O) ; reflexivity.
    - intros.
      reflexivity.
    - reflexivity.
    - reflexivity.
  Qed.

  Lemma V_inj_gen : forall u : nat -> T, V (fun n => inj_gen (u n)) = u.
  Proof.
    intro.
    unfold inj_gen.
    unfold V, FFrame, Vc.
    split ; unfold le, Covrel_le, Covrel ; intro.
    apply cr_n.
    set (g := fun a => u (bijNN1 a)).
    assert (u n = g (bijNN (n,O))).
    unfold g.
    rewrite bijNN1_eq. simpl. reflexivity.
    rewrite H.
    apply cr_n.
  Qed.

  Lemma inj_gen_le : forall t u, inj_gen t ≤ u <-> t ◁ u.
  Proof.
    intros.
    unfold inj_gen.
    unfold le, Covrel_le, Covrel.
    firstorder.
    apply (H O).
  Qed.

  Lemma inj_gen_meet : forall t u, inj_gen t ⊓ u = (fun x => t ⊓ x) ∘ u.
  Proof.
    intros.
    unfold inj_gen, compose, meet, msl_meet, MSL_for_FFrame, CMeet.
    split ; by_cov_inj.
    - exists (bijNN2 n). reflexivity.
    - exists (bijNN (O,n)). simpl_bijNN. reflexivity.
  Qed.

  (** ** Facts on finite joins *)

  Require Import SeqOfList.

  Definition Vl (u : list T) := seq_of_list u.

  Existing Instance msl_preorder.
  Existing Instance Feq_equivalence.
  Existing Instance MSL_for_FFrame.
  Existing Instance CMeet_meet.
  Existing Instance Covrel_le.
  Ltac unfold_meet := unfold meet, msl_meet, MSL_for_FFrame, CMeet_meet, CMeet.

  Lemma V_cons_increasing : forall x y u v, x ≤ y -> u ≤ v -> x ::: u ≤ y ::: v.
  Proof.
    intros.
    unfold V_cons, le, Covrel_le, Covrel ; intros.
    destruct n.
    apply cr_left with (b := y). assumption.
    apply cr_refl with (n := O) ; reflexivity.
    apply cr_trans with (U := v).
    apply (H0 n).
    unfold le, Covrel_le, Covrel. intro.
    apply cr_refl with (n := S n0) ; reflexivity.
  Qed.

  Add Morphism V_cons with signature (Feq ==> (=) ==> (=)) as V_cons_morphism.
  Proof.
    intros.
    destruct H, H0.
    split.
    apply V_cons_increasing ; assumption.
    apply V_cons_increasing ; assumption.
  Qed.

  Ltac rewrite_as_pair n :=
    assert (HbijNN : n ≡ bijNN (bijNNinv n)) by (rewrite bijNN_bijNNinv ;
                                                 reflexivity) ;
    rewrite HbijNN.

  Lemma V_cons_inj_gen : forall a b u, inj_gen a ⊓ (b ::: u) =
                                  (a ⊓ b) ::: (inj_gen a ⊓ u).
  Proof.
    intros.
    split ; by_cov_inj.
    - rewrite_as_pair n.
      destruct (bijNNinv n).
      unfold_meet.
      simpl_bijNN.
      destruct n1 ; unfold inj_gen ; simpl.
      + exists O. reflexivity.
      + exists (S (bijNN (O,n1))). simpl.
      simpl_bijNN. reflexivity.
    - destruct n ; unfold inj_gen ; simpl.
      + exists (bijNN (O,O)).
        unfold_meet. reflexivity.
      + rewrite_as_pair n.
        unfold_meet ; simpl_bijNN.
        exists (bijNN (O,S (snd (bijNNinv n)))).
        simpl_bijNN. reflexivity.
  Qed.

  Lemma Vl_meet : forall x u, inj_gen x ⊓ Vl u = Vl (map (fun y => x ⊓ y) u).
  Proof.
    intros.
    unfold inj_gen, Vl.
    induction u ; simpl.
    - assert ((fun _ => ⊥) = ⊥) by reflexivity.
      apply covbij_coveq ; intro.
      unfold_meet.
      meetsemilattice.
    - rewrite <- IHu.
      apply V_cons_inj_gen.
  Qed.

  Lemma Vl_Vf : forall u, Vl u = Vf FFrame (map inj_gen u).
  Proof.
    intros.
    unfold Vl, Vf.
    assert (V (seq_of_list (map inj_gen u)) = V (inj_gen ∘ (seq_of_list u)) ).
    apply V_morphism.
    apply seq_of_list_compose.
    apply Feq_equivalence.
    apply msl_preorder.
    reflexivity.
    rewrite H.
    unfold compose.
    symmetry.
    apply V_inj_gen.
  Qed.

  (** ** Alternative representation of binary joins
      As we have all countable joins, binary ones
      come for free, but they are computed with
      our bijection [nat * nat -> nat], which is a
      bit dirty. Here is an alternative definition.

   *)

  Existing Instance joinb_join.
  Proposition join_NpN : forall u v, u ⊔ v = (fun n => match bijNpNinv n with
                                        | inl a => u a
                                        | inr b => v b
                                               end).
  Proof.
    intros.
    unfold join, joinb_join, joinb, Vf, V, FFrame, Vc, seq_of_list.
    split.
    - unfold le, Covrel_le, Covrel. intro.
      destruct (bijNN1 n) ; simpl.
      apply cr_refl with (n := bijNpN (inl (bijNN2 n))).
      rewrite bijNpN_bij2. reflexivity.
      destruct n0.
      apply cr_refl with (n := bijNpN (inr (bijNN2 n))).
      rewrite bijNpN_bij2. reflexivity.
      simpl.
      apply Bot_le.
    - by_cov_inj.
      destruct (bijNpNinv n).
      exists (bijNN (O,n0)). simpl_bijNN. reflexivity.
      exists (bijNN (S O,n0)). simpl_bijNN. reflexivity.
  Qed.

  (** ** Equalities generated by the axioms *)

  Proposition CovAx_meet_gen :
    forall (b:T), forall (i : Idx b), inj_gen b = (inj_gen b) ⊓ (CovAx b i).
  Proof.
    intros.
    rewrite inj_gen_meet.
    split.
    - rewrite inj_gen_le.
      apply cr_inf with (b := b) (i := i).
      apply le_refl.
      intros. unfold compose.
      apply cr_refl with (n := n).
      reflexivity.
    - intro. unfold compose, inj_gen.
      apply cr_left with (b := b).
      apply meet_l.
      apply cr_refl with (n := O).
      reflexivity.
  Qed.

  Proposition CovAx_le_eq :
    forall (b:T), forall (i : Idx b), (forall n, CovAx b i n ≤ b) -> inj_gen b = CovAx b i.
  Proof.
    intros.
    split.
    - rewrite CovAx_meet_gen with (i := i).
      apply (@meet_r (nat -> T) Covrel_le MSL_for_FFrame).
    - intro.
      apply cr_left with (b := b).
      apply H.
      apply cr_refl with (n := O).
      reflexivity.
  Qed.

  (** ** Universality

     Let us assume that we have a meet semilattice
     morphism to an arbitrary frame R. *)
  Context {R : Type}.
  Context {Rle : Le R}.
  Variable RFrame : @Frame R Rle.

  Definition Rmsl := @frame_msl R Rle RFrame.
  Definition Rpo := @msl_preorder R Rle Rmsl.
  Variable f : T -> R.
  Variable mslmorph : MSLMorphism Tmsl Rmsl f.
  Existing Instance mslmorph.

  (** We assume that the morphism respects the axioms
      we have used to generate our free frame. *)
  Definition respects_axioms : Prop :=
    forall t : T, forall i : Idx t, f t ≤ V (f ∘ (CovAx t i)).
  Variable resp_ax : respects_axioms.

  (** We define a function from our free frame to R. *)
  Definition fframe_ext (x : nat -> T) : R :=
    V (f ∘ x).

  (** We show that this function is a frame morphism. *)
  Existing Instance Covrel_le.

  Lemma f_covrel : forall a U, a ◁ U -> f a ≤ V (f ∘ U).
  Proof.
    intros.
    induction H.
    - rewrite <- H.
      assert (f (U n) = (f ∘ U) n) by reflexivity.
      rewrite H0 ; apply v_le.
    - unfold respects_axioms in resp_ax.
      specialize (resp_ax b i).
      set (K := (V (fun n => f (a ⊓ CovAx b i n)))).
      apply le_trans with (y := K).
      + assert (K = f a ⊓ V (f ∘ CovAx b i)).
        * rewrite cdistr.
          apply V_morphism ; intro.
          unfold compose.
          rewrite mslmorph_meet.
          reflexivity.
          apply mslmorph.
        * rewrite H2.
          apply le_trans with (y := f a ⊓ f b).
          assert (f a ≤ f b) by (apply (pomorph_le a b H)).
          assert (f a ⊓ f b = f a) by (apply order_meet ; assumption).
          rewrite H4.
          apply le_refl.
          apply meet_le.
          apply le_refl.
          assumption.
      + unfold K.
        apply v_univ.
        assumption.
    - apply le_trans with (y := f b).
      assert (f a ≤ f b) by (apply (pomorph_le a b H)).
      assumption. assumption.
  Qed.

  Instance fframe_mor : FMorphism FFrame RFrame fframe_ext.
  Proof.
    unfold fframe_ext.
    apply MkFMorphism.

    - apply MkMSLMorphism.
      + apply MkPOMorphism.
        intros.
        apply v_univ ; intro.
        unfold compose.
        unfold le, Covrel in H.
        specialize (H n).
        apply f_covrel ; assumption.
      + intros.
        unfold meet, msl_meet, FFrame. simpl.
        unfold CMeet, compose.
        assert (forall n, f (x (bijNN1 n) ⊓ y (bijNN2 n)) = f (x (bijNN1 n)) ⊓ f (y (bijNN2 n))).
        intro.
        apply (@mslmorph_meet T R Tle Rle Tmsl Rmsl f mslmorph).
        setoid_rewrite H.
        symmetry.
        apply V_meet.

      + unfold compose.
        unfold bottom, msl_bot, FFrame, Bot. simpl.
        assert (pointwise_relation nat Feq (fun _ => f ⊥) (fun _ => ⊥)).
        unfold pointwise_relation ; intro.
        apply mslmorph_bot. assumption.
        rewrite H.
        apply V_bot.

      + unfold compose.
        unfold top, msl_top, FFrame. simpl.
        rewrite V_top. reflexivity.
        exists O. unfold Top. apply mslmorph_top.
        apply mslmorph.

    - intro.
      unfold compose.
      rewrite <- V_pair.
      apply V_morphism ; intro.
      unfold V, FFrame, Vc, bijNN1, bijNN2.
      reflexivity.
  Qed.

  Definition fframe_mslmorph := fmorph_mslmorph FFrame RFrame fframe_ext.
  Proposition fframe_factoring : fframe_ext ∘ inj_gen = f.
  Proof.
    unfold equiv, ext_equiv, respectful.
    intros.
    unfold inj_gen, fframe_ext, compose.
    rewrite <- H.
    apply V_const.
  Qed.

  Arguments fframe_factoring : default implicits.

  (** Now the uniqueness part of the universality:
     if we have another such frame morphism,
     then it is equal to fframe_ext. *)

  Variable other_fact : (nat -> T) -> R.
  Variable other_morph : FMorphism FFrame RFrame other_fact.
  Existing Instance other_morph.
  Instance other_mslmorph : MSLMorphism MSL_for_FFrame Rmsl other_fact := fmorph_mslmorph FFrame RFrame other_fact.
  Instance other_morph_po : POMorphism other_fact.
  Proof.
    apply (mslmorph_pomorph MSL_for_FFrame Rmsl).
  Qed.

  Variable other_commutes : other_fact ∘ inj_gen = f.

  Existing Instance Covrel_le.
  Instance coveq_R : Equiv (nat -> R) := @ext_equiv nat (≡) R (=).

  Proposition other_fact_equal : forall u, other_fact u = fframe_ext u.
  Proof.
    intro.
    assert (other_fact u = other_fact (V (fun n => inj_gen (u n)))).
    rewrite V_inj_gen ; reflexivity.
    rewrite H.
    rewrite morph_V.
    unfold fframe_ext, compose.
    apply V_morphism.
    intro.
    unfold equiv, ext_equiv, respectful in other_commutes.
    apply other_commutes ; reflexivity.
    assumption.
  Qed.

  (** This shows the correctness of our construction. *)

End Free_Frame.


(*Javier Enriquez Mendoza
Semanal 6
Semántica y Verificación*)

Variable A:Type.

Inductive btree:Type :=
  | empty : btree
  | nodo : A -> btree -> btree -> btree.

Fixpoint inTree (a:A) (t:btree) : Prop :=
  match t with
    | empty => False
    | nodo y l r => (eq y a) \/ (inTree a l) \/ (inTree a r)
  end.

Fixpoint isEmpty (t:btree): bool :=
  match t with
    | empty => true
    | nodo _ _ _ => false
  end.

Lemma true_is_empty: forall (t:btree), ((isEmpty t) = true) -> (t = empty).
Proof.
  intros.
  destruct t.
  trivial.
  simpl in H.
  inversion H.
Qed.

Theorem cuatro : forall (t:btree), ((isEmpty t) = true) <-> (forall (x:A), ~(inTree x t)).
Proof.
  intros.
  split.
  (*->*)
  intros.
  unfold not.
  intros.
  assert (t = empty).
  apply true_is_empty.
  trivial.
  rewrite H1 in H0.
  simpl in H0.
  trivial.
  (*<-*)
  intros.
  destruct t.
  reflexivity.
  simpl inTree in H.
  edestruct H.
  intuition. (*Como mi variable ?x esta libre en la meta es equivalente al forall de la
premisa H por lo tanto lo que quiero probar es falso, Pero no supe como poner eso correctamente
asi que mejor use intuition, pero entiendo que es lo que esta haciendo y por que asi que podria
decir que lo use correctamente jeje *)
Qed.


(**
{0, 1}* のうち0の出現数が1の出現数の丁度2倍であるような列だけを集めた集合は、
S = SS | 00S1 | 1S00 | 0S1S0 | ε というCFGで書き表せることを証明せよ。

https://twitter.com/pi8027/status/476708668239384576

このCFDで生成される文字列の 0の数は 1の数の2倍であることを示す。
（これで、問題の趣旨に合っている？）
*)

Require Import ssreflect ssrnat ssrbool eqtype seq.

Inductive S : Set :=
| ss of S & S
| oosi of S
| isoo of S
| osiso of S
| ε.

Fixpoint icount (l : S) : nat :=
  match l with
    | ss m n => (icount m) + (icount n)
    | oosi m => (icount m).+1
    | isoo m => (icount m).+1
    | osiso m => (icount m).+1
    | ε => 0
  end.

Fixpoint ocount (l : S) : nat :=
  match l with
    | ss m n => (ocount m) + (ocount n)
    | oosi m => (ocount m).+2
    | isoo m => (ocount m).+2
    | osiso m => (ocount m).+2
    | ε => 0
  end.

Goal forall l : S, (icount l).*2 = ocount l.
Proof.
  elim;
  first                                     (* SS *)
    (move=> l H l' H'; by rewrite /= doubleD H H');
  last                                      (* ε *)
    by [];
  (move=> l H /=; by rewrite doubleS H).
Qed.

(* END *)


Require Import set.
Require Import equal.

Inductive belong : set -> set -> Prop :=
|   Belong  : forall (a:Type) (f:a -> set) (x:a), belong (f x) (mkset a f)
|   BelongR : forall (x x' y:set), x == x' -> belong x' y -> belong x y
.

Lemma BelongL: forall (x y' y:set), belong x y' -> y' == y -> belong x y'.
Proof.
    intros x y' y H E. induction H.
    - constructor.
    - apply BelongR with x'.
        + assumption.
        + apply IHbelong. assumption.
Qed.

Notation "x % y" := (belong x y) (at level 0, no associativity).

(*
Lemma belong_crit : forall (x:set) (a:Type) (f:a -> set),
    x % (mkset a f) -> exists (z:a), x = f z.
Proof.
    intros x a f H. remember (mkset a f) as y eqn:E.
    revert E. revert f. revert a. destruct H.
    - intros b g H. inversion H. subst. exists x. reflexivity.
    -

Show.
*)


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (z : natural) (y : natural) (lf1 : natural) (lf2 : natural)
  : natural := plus Zero (plus lf2 z).


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Coq_Cats.Type_Cat.Type_Cat.

Section Arrow.
  Local Open Scope morphism_scope.

  (** The type accomodating all arrows of a category C. *)
  Record Arrow (C : Category) :=
    {
      Orig : Obj;
      Targ : Obj;
      Arr : Orig –≻ Targ
    }.

  Arguments Orig {_} _ : clear implicits.
  Arguments Targ {_} _ : clear implicits.
  Arguments Arr {_} _ : clear implicits.

  Coercion Arr : Arrow >-> Hom.

  (** An arrow (in the appropriate category, e.g., comma)
    from arrow f : a -> b to arrow g : c -> d is a pair of arrows h1 : a -> c
    and h2 : b -> d that makes the following diagram commute:
#

          f
   a ———————————> b
   |              |
h1 |              | h2
   |              |
   ↓              ↓
   c ———————————> d
          g

#
 *)
  Record Arrow_Hom {C : Category} (a b : Arrow C) :=
    {
      Arr_H : (Orig a) –≻ (Orig b);
      Arr_H' : (Targ a) –≻ (Targ b);
      Arr_Hom_com : Arr_H' ∘ (Arr a) = (Arr b) ∘ Arr_H
    }.
  Arguments Arr_H {_ _ _} _ : clear implicits.
  Arguments Arr_H' {_ _ _} _ : clear implicits.
  Arguments Arr_Hom_com {_ _ _} _ : clear implicits.

  Context (C : Category).

  Section Arrow_Hom_eq_simplify.
    Context {a b : Arrow C} (f g : Arrow_Hom a b).

    (** Two arrow homomorphisms are equal if the arrows between theor domains
        and codomain are respectively equal. In other words, we don't care about
        the proof of the diagram commuting. *)
    Lemma Arrow_Hom_eq_simplify : Arr_H f = Arr_H g → Arr_H' f = Arr_H' g → f = g.
    Proof.
      destruct f; destruct g.
      basic_simpl.
      ElimEq.
      PIR.
      reflexivity.
    Qed.

  End Arrow_Hom_eq_simplify.

  Section Compose_id.
    Context {x y z} (h : Arrow_Hom x y) (h' : Arrow_Hom y z).

    (** Composition of arrow homomorphisms. We basicall need to show that in the
        following diagram, the bigger diagram commutes if the smaller ones do.
#

           f
    a ———————————> b
    |              |
 h1 |              | h2
    |              |
    ↓              ↓
    c ———————————> d
    |      g       |
h1' |              | h2'
    |              |
    ↓              ↓
    c ———————————> d
           h

#
*)
    Program Definition Arrow_Hom_compose : Arrow_Hom x z :=
      {|
        Arr_H := (Arr_H h') ∘ (Arr_H h);
        Arr_H' := (Arr_H' h') ∘ (Arr_H' h)
      |}.

    Next Obligation. (* Arr_Hom_com *)
    Proof.
      destruct h as [hh hh' hc]; destruct h' as [h'h h'h' h'c]; cbn.
      rewrite assoc.
      rewrite hc.
      repeat rewrite assoc_sym.
      rewrite h'c.
      auto.
    Qed.

    (** The identity arrow morphism. We simply need to show that the following
        diagram commutes:
#

          f
   a ———————————> b
   |              |
id |              | id
   |              |
   ↓              ↓
   a ———————————> b
          f

#
which is trivial.
 *)
    Program Definition Arrow_id : Arrow_Hom x x :=
      {|
        Arr_H := id;
        Arr_H' := id
      |}.

  End Compose_id.

End Arrow.

Hint Extern 1 (?A = ?B :> Arrow_Hom _ _) => apply Arrow_Hom_eq_simplify; simpl.

Arguments Orig {_} _ : clear implicits.
Arguments Targ {_} _ : clear implicits.
Arguments Arr {_} _ : clear implicits.

Arguments Arr_H {_ _ _} _ : clear implicits.
Arguments Arr_H' {_ _ _} _ : clear implicits.
Arguments Arr_Hom_com {_ _ _} _ : clear implicits.

(** an arrow in a category is also an arrow in the opposite category.
    The domain and codomain are simply swapped. *)
Program Definition Arrow_to_Arrow_OP (C : Category) (ar : Arrow C) :
  Arrow (C ^op) :=
  {|
    Arr := ar
  |}.

(** The type of arrows of a category and the type of arrows of its opposite are
     isomorphic. *)
Program Definition Arrow_OP_Iso (C : Category) :
  ((Arrow C) ≃≃ (Arrow (C ^op)) ::> Type_Cat)%isomorphism :=
  {|
    iso_morphism := Arrow_to_Arrow_OP C;
    inverse_morphism := Arrow_to_Arrow_OP (C ^op)
  |}.


Require Import Coq.Lists.List.

Lemma Forall_map:
  forall {a b} P (f : a -> b) xs,
  Forall P (map f xs) <-> Forall (fun x => P (f x)) xs.
Proof.
  intros.
  induction xs; simpl.
  * split; intro; constructor.
  * split; intro H; inversion_clear H; constructor; try apply IHxs; assumption.
Qed.

Lemma Forall_cons_iff:
  forall  {a} (P : a -> Prop) x xs,
  Forall P (x :: xs) <-> P x /\ Forall P xs.
Proof.
  intros.
  intuition; inversion H; intuition.
Qed.

(* The termination checker does not like recursion through [Forall], but
   through [map] is fine... oh well. *)
Definition Forall' {a} (P : a -> Prop) xs := Forall id (map P xs).

Lemma Forall'_Forall:
  forall  {a} (P : a -> Prop) xs,
  Forall' P xs <-> Forall P xs.
Proof.
  intros.
  unfold Forall'.
  unfold id.
  rewrite Forall_map.
  reflexivity.
Qed.


(* https://softwarefoundations.cis.upenn.edu/lf-current/Lists.html *)

From LF Require Export B_Induction.

Module NatList.

Inductive natprod : Type :=
    | pair (n_1 n_2 : nat).

Check (pair 3 5) : natprod.

Definition first (p : natprod) : nat :=
    match p with
    | pair x y => x
    end.

Definition second (p : natprod) : nat :=
    match p with
    | pair x y => y
    end.

Compute (first (pair 5 3)).
Compute (second (pair 5 3)).

Notation "( x , y )" := (pair x y).

Compute (first (3, 5)).
Compute (second (3, 5)).

Definition swap_pair (p : natprod) : natprod :=
    match p with
    | (x, y) => (y, x)
    end.

Theorem surjective_pairing : forall (p : natprod),
    p = (first p, second p).
Proof.
    intros p. destruct p as [n m].
    simpl. reflexivity.
Qed.

Theorem second_first_is_swap : forall (p : natprod),
    (second p, first p) = swap_pair p.
Proof.
    intros p. destruct p as [n m].
    simpl. reflexivity.
Qed.

Theorem first_swap_is_second : forall (p : natprod),
    first (swap_pair p) = second p.
Proof.
    intros p. destruct p as [n m].
    simpl. reflexivity.
Qed.

Inductive natlist : Type :=
    | empty
    | cons (n : nat) (l : natlist).

Check (cons 1 (cons 2 (cons 3 empty))) : natlist.

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).

Notation "[ ]" := empty.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y empty) ..).

Fixpoint repeat (n count : nat) : natlist :=
    match count with
    | 0 => empty
    | S count' => n :: (repeat n count')
    end.

Compute repeat 5 10.

Fixpoint length (l : natlist) : nat :=
    match l with
    | empty => 0
    | cons n cdr => 1 + (length cdr)
    end.

Compute length (repeat 5 10).
Compute length empty.

Fixpoint append (l_1 l_2 : natlist) : natlist :=
    match l_1 with
    | empty => l_2
    | h :: t => h :: (append t l_2)
    end.

Compute append [1;2;3] [4;5;6].
Compute append [1;2;3] empty.

Notation "x ++ y" := (append x y)
                     (at level 60, right associativity).

Example test_app1: [1;2;3] ++ [4;5] = [1;2;3;4;5].
Proof. reflexivity. Qed.
Example test_app2: empty ++ [4;5] = [4;5].
Proof. reflexivity. Qed.
Example test_app3: [1;2;3] ++ empty = [1;2;3].
Proof. reflexivity. Qed.

Definition car (default : nat) (l : natlist) : nat :=
    match l with
    | empty => default
    | h :: t => h
    end.

Definition cdr (l : natlist) : natlist :=
    match l with
    | empty => empty
    | h :: t => t
    end.

Example test_hd1: car 0 [1;2;3] = 1.
Proof. reflexivity. Qed.
Example test_hd2: car 0 [] = 0.
Proof. reflexivity. Qed.
Example test_tl: cdr [1;2;3] = [2;3].
Proof. reflexivity. Qed.

Fixpoint nonzeros (l:natlist) : natlist :=
    match l with
    | empty => empty
    | 0 :: t => nonzeros t
    | h :: t => h :: (nonzeros t)
    end.

Example test_nonzeros: nonzeros [0;1;0;2;3;0;0] = [1;2;3].
Proof. reflexivity. Qed.

Fixpoint oddmembers (l:natlist) : natlist :=
    match l with
    | empty => empty
    | h :: t => match (odd h) with
        | true => h :: (oddmembers t)
        | false => oddmembers t
        end
    end.

Example test_oddmembers: oddmembers [0;1;0;2;3;0;0] = [1;3].
Proof. reflexivity. Qed.

Definition countoddmembers (l:natlist) : nat :=
    length (oddmembers l).

Example test_countoddmembers1: countoddmembers [1;0;3;1;4;5] = 4.
Proof. reflexivity. Qed.
Example test_countoddmembers2: countoddmembers [0;2;4] = 0.
Proof. reflexivity. Qed.
Example test_countoddmembers3: countoddmembers empty = 0.
Proof. reflexivity. Qed.

Fixpoint alternate (l1 l2 : natlist) : natlist :=
    match l1 with
    | empty => l2
    | h1 :: t1 => match l2 with
        | empty => l1
        | h2 :: t2 => h1 :: h2 :: (alternate t1 t2)
        end
    end.

Example test_alternate1: alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
Proof. reflexivity. Qed.
Example test_alternate2: alternate [1] [4;5;6] = [1;4;5;6].
Proof. reflexivity. Qed.
Example test_alternate3: alternate [1;2;3] [4] = [1;4;2;3].
Proof. reflexivity. Qed.
Example test_alternate4: alternate [] [20;30] = [20;30].
Proof. reflexivity. Qed.

Definition bag := natlist.

Fixpoint count (v : nat) (s : bag) : nat :=
    match s with
    | empty => 0
    | h :: t => (count v t) + match (v =? h) with
        | true => 1
        | false => 0
        end
    end.

Example test_count1: count 1 [1;2;3;1;4;1] = 3.
Proof. reflexivity. Qed.
Example test_count2: count 6 [1;2;3;1;4;1] = 0.
Proof. reflexivity. Qed.

Definition sum : bag -> bag -> bag :=
    append.

Example test_sum1: count 1 (sum [1;2;3] [1;4;1]) = 3.
Proof. reflexivity. Qed.

Definition add (v : nat) (s : bag) : bag :=
    v :: s.

Example test_add1: count 1 (add 1 [1;4;1]) = 3.
Proof. reflexivity. Qed.
Example test_add2: count 5 (add 1 [1;4;1]) = 0.
Proof. reflexivity. Qed.

Definition member (v : nat) (s : bag) : bool :=
    match (count v s) with
    | 0 => false
    | _ => true
    end.

Example test_member1: member 1 [1;4;1] = true.
Proof. reflexivity. Qed.
Example test_member2: member 2 [1;4;1] = false.
Proof. reflexivity. Qed.

Fixpoint remove_one (v : nat) (s : bag) : bag :=
    match s with
    | empty => empty
    | h :: t => match (h =? v) with
        | true => t
        | false => h :: remove_one v t
        end
    end.

Example test_remove_one1: count 5 (remove_one 5 [2;1;5;4;1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_one2: count 5 (remove_one 5 [2;1;4;1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_one3: count 4 (remove_one 5 [2;1;4;5;1;4]) = 2.
Proof. simpl. reflexivity. Qed.
Example test_remove_one4: count 5 (remove_one 5 [2;1;5;4;5;1;4]) = 1.
Proof. reflexivity. Qed.

Fixpoint remove_all (v:nat) (s:bag) : bag :=
    match s with
    | empty => empty
    | h :: t => match (h =? v) with
        | true => remove_all v t
        | false => h :: remove_all v t
        end
    end.

Example test_remove_all1: count 5 (remove_all 5 [2;1;5;4;1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_all2: count 5 (remove_all 5 [2;1;4;1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_all3: count 4 (remove_all 5 [2;1;4;5;1;4]) = 2.
Proof. reflexivity. Qed.
Example test_remove_all4: count 5 (remove_all 5 [2;1;5;4;5;1;4;5;1;4]) = 0.
Proof. reflexivity. Qed.

Fixpoint included (s1 : bag) (s2 : bag) : bool :=
    match s1 with
    | empty => true
    | h :: t => match (member h s2) with
        | true => included t (remove_one h s2)
        | false => false
        end
    end.

Example test_included1: included [1;2] [2;1;4;1] = true.
Proof. reflexivity. Qed.
Example test_included2: included [1;2;2] [2;1;4;1] = false.
Proof. reflexivity. Qed.

Lemma beq_nat_refl : forall n,
    true = (n =? n).
Proof.
    intros n. induction n as [| n' IHn' ].
    - (* n = 0 *)
        simpl. reflexivity.
    - (* n = S n' *)
        simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem add_inc_count : forall v : nat, forall s : bag,
    count v (add v s) = 1 + (count v s).
Proof.
    intros v s. simpl.
    rewrite <- beq_nat_refl.
    rewrite -> add_comm. reflexivity.
Qed.

Theorem nil_app : forall l : natlist,
    [] ++ l = l.
Proof. reflexivity. Qed.

Theorem tl_length_pred : forall l:natlist,
  pred (length l) = length (cdr l).
Proof.
  intros l. destruct l as [| n l'].
  - (* l = nil *)
    reflexivity.
  - (* l = cons n l' *)
    reflexivity.
Qed.

Theorem app_assoc : forall l1 l2 l3 : natlist,
    (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
    intros l1 l2 l3. induction l1 as [| n l' IHl' ].
    - (* l1 = empty *)
        simpl. reflexivity.
    - (* l1 = cons n l1' *)
        simpl. rewrite -> IHl'. reflexivity.
Qed.

Fixpoint rev (l:natlist) : natlist :=
    match l with
    | empty => empty
    | h :: t => rev t ++ [h]
    end.

Example test_rev1: rev [1;2;3] = [3;2;1].
Proof. reflexivity. Qed.
Example test_rev2: rev empty = empty.
Proof. reflexivity. Qed.

Theorem app_length : forall l1 l2 : natlist,
    length (l1 ++ l2) = (length l1) + (length l2).
Proof.
    (* WORKED IN CLASS *)
    intros l1 l2. induction l1 as [| n l1' IHl1'].
    - (* l1 = nil *)
        reflexivity.
    - (* l1 = cons *)
        simpl. rewrite -> IHl1'. reflexivity.
Qed.

Theorem rev_length : forall l : natlist,
    length (rev l) = length l.
Proof.
    intros l. induction l as [| n l' IHl' ].
    - (* l = empty *)
        simpl. reflexivity.
    - (* l = cons n l' *)
        simpl.
        rewrite -> app_length, IHl', add_comm.
        simpl. reflexivity.
Qed.

Theorem app_nil_r : forall l : natlist,
    l ++ [] = l.
Proof.
    intros l. induction l as [| n l' IHl' ].
    - (* l = empty *)
        simpl. reflexivity.
    - (* l = cons n l' *)
        simpl. rewrite -> IHl'. reflexivity.
Qed.

Theorem rev_app_distr: forall l1 l2 : natlist,
    rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
    intros l1 l2. induction l1 as [| n1 l1' IHl1' ].
    - (* l1 = empty *)
        simpl. rewrite -> app_nil_r. reflexivity.
    - (* l1 = cons n l1' *)
        simpl. rewrite -> IHl1'. rewrite -> app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall l : natlist,
    rev (rev l) = l.
Proof.
    intros l. induction l as [| n l' IHl' ].
    - (* l = empty *)
        simpl. reflexivity.
    - (* l = cons n l' *)
        simpl. rewrite -> rev_app_distr, IHl'.
        simpl. reflexivity.
Qed.

Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist,
    l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
    intros l1 l2 l3 l4.
    rewrite -> app_assoc, app_assoc. reflexivity.
Qed.

Lemma nonzeros_app : forall l1 l2 : natlist,
    nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
    intros l1 l2. induction l1 as [| n1 l1' IHl1' ].
    - (* l1 = empty *)
        simpl. reflexivity.
    - (* l1 = cons n1 l1' *)
        induction n1 as [| n1' IHn1' ].
        -- (* n1 = 0 *)
            simpl. rewrite -> IHl1'. reflexivity.
        -- (* n1 = S n' *)
            simpl. rewrite -> IHl1'. reflexivity.
Qed.

Fixpoint eqblist (l1 l2 : natlist) : bool :=
    match l1 with
    | empty => match l2 with
        | empty => true
        | _ => false
        end
    | h1 :: t1 => match l2 with
        | empty => false
        | h2 :: t2 => andb (eqb h1 h2) (eqblist t1 t2)
        end
    end.

Example test_eqblist1 : (eqblist empty empty = true).
Proof. reflexivity. Qed.
Example test_eqblist2 : eqblist [1;2;3] [1;2;3] = true.
Proof. reflexivity. Qed.
Example test_eqblist3 : eqblist [1;2;3] [1;2;4] = false.
Proof. reflexivity. Qed.

Theorem eqblist_refl : forall l:natlist,
    true = eqblist l l.
Proof.
    intros l. induction l as [| n l' IHl' ].
    - (* l = empty *)
        simpl. reflexivity.
    - (* l = cons n l' *)
        simpl. rewrite -> eqb_refl. rewrite <- IHl'.
        simpl. reflexivity.
Qed.

Theorem count_member_nonzero : forall (s : bag),
    1 <=? (count 1 (1 :: s)) = true.
Proof.
    intros s. rewrite -> add_inc_count.
    simpl. reflexivity.
Qed.

Theorem leb_n_Sn : forall n,
    n <=? (S n) = true.
Proof.
    intros n. induction n as [| n' IHn' ].
    - (* n = 0 *)
        simpl. reflexivity.
    - (* n = S n' *)
        simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem remove_does_not_increase_count: forall (s : bag),
    (count 0 (remove_one 0 s)) <=? (count 0 s) = true.
Proof.
    intros s. induction s as [| n s' IHs' ].
    - (* s = empty *)
        simpl. reflexivity.
    - (* s = cons n s' *)
        induction n as [| n' IHn' ].
        -- (* n = 0 *)
            simpl. rewrite -> add_comm. rewrite -> leb_n_Sn. reflexivity.
        -- (* n = S n' *)
            simpl. rewrite -> add_0_r, add_0_r, IHs'. reflexivity.
Qed.

Theorem bag_count_sum  : forall (s1 s2 : bag) (v : nat),
    count v (sum s1 s2) = (count v s1) + (count v s2).
Proof.
    intros s1 s2 v. induction s1 as [| n1 s1' IHs1' ].
    - (* s1 = empty *)
        simpl. reflexivity.
    - (* s1 = cons n s1' *)
        simpl. destruct (v =? n1).
        -- rewrite -> add_comm. assert (count v s1' + 1 = 1 + count v s1') as H.
            {
                rewrite -> add_comm. reflexivity.
            }
            rewrite -> H. rewrite -> IHs1'. rewrite -> add_assoc. reflexivity.
        -- rewrite -> add_0_r, add_0_r. rewrite -> IHs1'. reflexivity.
Qed.

Theorem involution_injective : forall (f : nat -> nat),
    (forall n : nat, n = f (f n)) -> (forall n1 n2 : nat, f n1 = f n2 -> n1 = n2).
Proof.
    intros f n n1 n2 H. assert (n1 = f (f n1)) as Hn1.
        {
            rewrite <- n. reflexivity.
        }
    rewrite -> Hn1.
    assert (n2 = f (f n2)) as Hn2.
        {
            rewrite <- n. reflexivity.
        }
    rewrite -> Hn2.
    rewrite -> H. reflexivity.
Qed.

Theorem rev_injective : forall (l1 l2 : natlist),
    rev l1 = rev l2 -> l1 = l2.
Proof.
    intros l1 l2 H.
    rewrite <- rev_involutive.
    rewrite <- H.
    rewrite -> rev_involutive. reflexivity.
Qed.

Inductive natoption : Type :=
    | Some (n : nat)
    | None.

Fixpoint nth_error (l : natlist) (n : nat) : natoption :=
    match l with
    | empty => None
    | h :: t => match n with
        | O => Some h
        | S n' => nth_error t n'
        end
    end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [4;5;6;7] 3 = Some 7.
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [4;5;6;7] 9 = None.
Proof. reflexivity. Qed.

Definition option_elim (d : nat) (o : natoption) : nat :=
    match o with
    | Some n' => n'
    | None => d
    end.

Definition hd_error (l : natlist) : natoption :=
    match l with
    | empty => None
    | h :: t => Some h
    end.

Example test_hd_error1 : hd_error [] = None.
Proof. reflexivity. Qed.
Example test_hd_error2 : hd_error [1] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_error3 : hd_error [5;6] = Some 5.
Proof. reflexivity. Qed.

Theorem option_elim_hd : forall (l : natlist) (default : nat),
    car default l = option_elim default (hd_error l).
Proof.
    intros l default. induction l as [| h t ].
    - simpl. reflexivity.
    - simpl. reflexivity.
Qed.

End NatList.

Inductive id : Type :=
    | Id (n : nat).

Definition eqb_id (x1 x2 : id) : bool :=
    match x1, x2 with
    | Id n1, Id n2 => n1 =? n2
    end.

Theorem eqb_id_refl : forall (x : id),
    eqb_id x x = true.
Proof.
    intros x. destruct x. simpl.
    rewrite -> eqb_refl. reflexivity.
Qed.

Module PartialMap.
Export NatList.

Inductive partial_map : Type :=
    | empty
    | record (i : id) (v : nat) (m : partial_map).

Definition update (d : partial_map) (x : id) (value : nat) : partial_map :=
    record x value d.

Fixpoint find (x : id) (d : partial_map) : natoption :=
    match d with
    | empty => None
    | record y v d' => if eqb_id x y
                       then Some v
                       else find x d'
    end.

Theorem update_eq : forall (d : partial_map) (x : id) (v: nat),
    find x (update d x v) = Some v.
Proof.
    intros d x v. destruct x. simpl.
    rewrite -> eqb_refl. reflexivity.
Qed.

Theorem update_neq : forall (d : partial_map) (x y : id) (o: nat),
    eqb_id x y = false -> find x (update d y o) = find x d.
Proof.
    intros d x y o H. simpl. rewrite -> H. reflexivity.
Qed.

End PartialMap.

Inductive baz : Type :=
    | Baz1 (x : baz)
    | Baz2 (y : baz) (b : bool).

(*
    The baz type cannot have any
    elements. Because both of its
    constructors take in a baz instance,
    it is impossible to use either to
    construct a baz instance.
*)


(** *** Advanced exercise sheet for lecture 4: Tactics in Coq. *)

(**
    This is the material for the advisors with solutions.
*)

(** Some exercises about equivalences - recall from the course that associativity
    for products of types is not available "on the nose", i.e., just with equality.

    Exercises originally suggested by Benedikt Ahrens and Anders Mörtberg
    (for UniMath school 2017) and elaborated by Ralph Matthes (CNRS, IRIT,
    Univ. Toulouse, France)
*)
Require Import UniMath.Foundations.PartA.

Locate "≃". (** typed in as [\simeq] *)
Print weq.
Print isweq.
Print hfiber.

Section weqdef.

Parameters (X Y: UU).
Eval compute in (X ≃ Y).
(** there is a function [f] so that for given image [y] one can find the preimage [x] uniquely,
    but not only as element of [X] but even the pair consisting of the preimage and the proof
    that it is the preimage is unique. *)
End weqdef.

(** Prove that the identity function is an equivalence *)
Lemma idisweq (X : UU) : isweq (idfun X).
Proof.
  unfold isweq.
  intro y.
  unfold iscontr.
  unfold hfiber.
  use tpair.
  - exists y.
    apply idpath.
  - cbn.
    intro p.
    induction p as [x H].
    rewrite H.
    apply idpath.
Defined.

(** Package this up as an equivalence *)
Definition idweq (X : UU) : X ≃ X.
Proof.
  exists (idfun X).
  apply idisweq.
Defined.

(** alternative proof with [isweq_iso] that is extremely useful *)
Lemma idisweq_alt (X : UU) : isweq (idfun X).
Proof.
  use isweq_iso.
  - exact (fun x => x).
  - cbn. intros x. apply idpath.
  - cbn. intros x. apply idpath.
Defined.

(** Prove that any map to empty is an equivalence *)
Lemma isweqtoempty {X : UU} (f : X -> ∅) : isweq f.
Proof.
  unfold isweq.
  intro y.
  induction y.
Defined.

(** Package this up as an equivalence *)
Definition weqtoempty {X : UU} (f : X -> ∅) : X ≃ ∅.
Proof.
  use tpair.
  - exact f.
  - cbn. apply isweqtoempty.
Defined.

(** Prove that the composition of equivalences is an equivalence.

This is rather difficult to do directly from the definition. Important lemmas
to reason on equality of pairs in a sigma type are given by [base_paths] and
[fiber_paths] that are elimination rules (that use given equality of pairs)
and [total2_paths2_f] that is an introduction rule allowing to establish an
equation between pairs. There, transport arises, but transport along the
identity path is always the identity, and this already computationally, which
means that [cbn] gets rid of it. *)
Theorem compisweq {X Y Z : UU} (f : X -> Y) (g : Y -> Z)
        (isf : isweq f) (isg : isweq g) : isweq (g ∘ f).
Proof.
  unfold isweq.
  intro z.
  unfold iscontr.
  unfold hfiber.
  set (isginst := isg z).
  induction isginst as [cntrg Hg].
  induction cntrg as [y yeq].
  induction yeq. (** do this as early as possible *)
  set (isfinst := isf y).
  induction isfinst as [cntrf Hf].
  induction cntrf as [x xeq].
  induction xeq. (** again an early induction on an equation *)
  use tpair.
  - exists x.
    apply idpath. (** thanks to the induction on equations, this is trivial *)
  - cbn.
    intro p.
    induction p as [x' Hx'].
    set (hfg := (f x',, Hx'): hfiber g (g (f x))).
    set (Hginst := Hg hfg).
    set (x'eq := base_paths _ _ Hginst).
    cbn in x'eq.
    set (hff := (x',,x'eq): hfiber f (f x)).
    set (Hfinst := Hf hff).
    set (x'eq' := base_paths _ _ Hfinst).
    cbn in x'eq'.
    assert (Hypg := fiber_paths Hginst). (** use [assert] to forget the definition *)
    cbn in Hypg.
    change (base_paths hfg (f x,, idpath (g (f x))) Hginst) with x'eq in Hypg.
    assert (Hypf := fiber_paths Hfinst).
    cbn in Hypf.
    change (base_paths hff (x,, idpath (f x)) Hfinst) with x'eq' in Hypf.
    induction x'eq'. (** this is now possible, after sufficient abstraction *)
    use total2_paths2_f. (** a rather trivial instance *)
    + apply idpath.
    + cbn.
      cbn in Hypf.
      rewrite Hypf in Hypg.
      cbn in Hypg.
      exact Hypg.
Defined.

(** a proof that is less aggressive on induction on identities - not completed *)
Lemma compisweq_alt_incomplete {X Y Z : UU} (f : X -> Y) (g : Y -> Z)
        (isf : isweq f) (isg : isweq g) : isweq (g ∘ f).
Proof.
  unfold isweq.
  intro z.
  unfold iscontr.
  unfold hfiber.
  set (isginst := isg z).
  induction isginst as [cntrg Hg].
  induction cntrg as [y yeq].
  set (isfinst := isf y).
  induction isfinst as [cntrf Hf].
  induction cntrf as [x xeq].
  use tpair.
  - exists x.
    unfold funcomp.
    intermediate_path (g y).
    + apply maponpaths.
      apply xeq.
    + apply yeq.
  - cbn.
    intro p.
    induction p as [x' Hx'].
    set (hfg := (f x',, Hx'): hfiber g z).
    set (Hginst := Hg hfg).
    set (x'eq := base_paths _ _ Hginst).
    cbn in x'eq.
    set (hff := (x',,x'eq): hfiber f y).
    set (Hfinst := Hf hff).
    set (x'eq' := base_paths _ _ Hfinst).
    cbn in x'eq'.
    set (Hypg := fiber_paths Hginst).
    cbn in Hypg.
    change (base_paths hfg (y,, yeq) Hginst) with x'eq in Hypg.
    set (Hypf := fiber_paths Hfinst).
    cbn in Hypf.
    change (base_paths hff (x,, xeq) Hfinst) with x'eq' in Hypf.
    use total2_paths2_f.
    + exact x'eq'.
    +

      intermediate_path (transportf (λ x0 : hfiber f y, (g ∘ f) (pr1 x0) = z) Hfinst Hx').
      { apply pathsinv0. unfold x'eq'. unfold base_paths. use functtransportf. }

      assert (Hypg' : transportf (λ y0 : hfiber g z, g (pr1 y0) = z) Hginst Hx' = yeq).
      { rewrite <- Hypg. unfold x'eq. unfold base_paths. use functtransportf. }

      (** Who is willing to complete this proof? *)
Abort.

(** Package this up as an equivalence *)
Definition weqcomp {X Y Z : UU} (w1 : X ≃ Y) (w2 : Y ≃ Z) : X ≃ Z.
Proof.
  induction w1 as [f isf].
  induction w2 as [g isg].
  use tpair.
  - exact (g ∘ f).
  - cbn.
    exact (compisweq _ _ isf isg).
Defined.


Require Import List.

Section MapFilter.

  Lemma not_in_map_not_in_map_filter :
    forall (A B : Type) (l : list A) (f1 : A -> bool) (f2 : A -> B) (e : B),
      ~ In e (map f2 l) -> ~ In e (map f2 (filter f1 l)).
  Proof.
    intros.
    induction l.
    - simpl; auto.
    - simpl in H.
      apply Decidable.not_or in H.
      destruct H.
      simpl.
      remember (f1 a) as b; destruct b.
      + simpl.
        unfold not; intro.
        destruct H1.
        * apply H; apply H1.
        * apply IHl.
          apply H0.
          apply H1.
      + apply IHl.
        apply H0.
  Qed.

  Lemma nodup_map_filter
    : forall (A B : Type) (l : list A) (f1 : A -> bool) (f2 : A -> B),
      NoDup (map f2 l) -> NoDup (map f2 (filter f1 l)).
  Proof.
    intros.
    induction l.
    - simpl; auto.
    - simpl.
      simpl in H.
      rewrite NoDup_cons_iff in H.
      destruct H.
      remember (f1 a) as b; destruct b.
      + simpl.
        rewrite NoDup_cons_iff.
        split.
        apply not_in_map_not_in_map_filter.
        apply H.
        apply IHl.
        apply H0.
      + apply IHl.
        simpl in H.
        apply H0.
  Qed.

End MapFilter.


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

Require Import List Arith NArith NPeano Ascii String.

Set Implicit Arguments.

Local Open Scope string_scope.

Local Definition natToDigit (n : nat) : string :=
  match n with
    | 0 => "0"
    | 1 => "1"
    | 2 => "2"
    | 3 => "3"
    | 4 => "4"
    | 5 => "5"
    | 6 => "6"
    | 7 => "7"
    | 8 => "8"
    | _ => "9"
  end.

Local Definition NToDigit (n : N) := natToDigit (N.to_nat n).

Local Fixpoint writeNatAux (time n : nat) (acc : string) : string :=
  let acc' := natToDigit (n mod 10) ++ acc in
  match time with
    | 0 => acc'
    | S time' =>
      match n / 10 with
        | 0 => acc'
        | n' => writeNatAux time' n' acc'
      end
  end.

Local Fixpoint writeNAux (time : nat) (n : N) (acc : string) : string :=
  let acc' := NToDigit (n mod 10)%N ++ acc in
  match time with
    | 0 => acc'
    | S time' =>
      match (n / 10)%N with
        | N0 => acc'
        | n' => writeNAux time' n' acc'
      end
  end.

Section N_to_string.

  Let loop := fix loop l n s :=
    let (d,r) := N.div_eucl n 10 in
    let s'    := String (ascii_of_N (48+r)) s
    in match d, l with
         | N0, _   => s'
         | _ , 0   => s'
         | _ , S l => loop l d s'
    end.

  (* We limit the display of N to 10^12 *)

  Definition string_of_N n :=
    match n with
      | N0 => "0"
      | _  => loop 12 n EmptyString
    end.

End N_to_string.

Definition string_of_nat n := writeNatAux n n "".

(*
Eval compute in string_of_N 123456789012309271072.
*)