(* ***************************************************************** *)
(*                                                                   *)
(* Released: 2021/06/07.                                             *)
(* Due: 2020/06/25, 23:59:59, CST.                                   *)
(*                                                                   *)
(* 0. Read instructions carefully before start writing your answer.  *)
(*                                                                   *)
(* 1. You should not add any hypotheses in this assignment.          *)
(*    Necessary ones have been provided for you.                     *)
(*                                                                   *)
(* 2. In order to check whether you have finished all tasks or not,  *)
(*    just see whether all "Admitted" has been replaced.             *)
(*                                                                   *)
(* 3. You should submit this file (Quiz2.v) on CANVAS.               *)
(*                                                                   *)
(* 4. Only valid Coq files are accepted. In other words, please      *)
(*    make sure that your file does not generate a Coq error. A      *)
(*    way to check that is: click "compile buffer" for this file     *)
(*    and see whether an "Quiz2.vo" file is generated.               *)
(*                                                                   *)
(* 5. You should answer questions individually. You should not       *)
(*    discuss with others or try finding answers online.             *)
(*                                                                   *)
(* ***************************************************************** *)

Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import PL.RTClosure PL.Imp PL.Lambda.
Import ListNotations.

Module OptF.

Definition add {A: Type} (f g: A -> option Z): A -> option Z :=
  fun st =>
    match f st, g st with
    | Some v1, Some v2 => Some (v1 + v2)
    | _, _ => None
    end.

Definition sub {A: Type} (f g: A -> option Z): A -> option Z :=
  fun st =>
    match f st, g st with
    | Some v1, Some v2 => Some (v1 - v2)
    | _, _ => None
    end.

Definition mul {A: Type} (f g: A -> option Z): A -> option Z :=
  fun st =>
    match f st, g st with
    | Some v1, Some v2 => Some (v1 * v2)
    | _, _ => None
    end.

End OptF.

(* ################################################################# *)
(** * Task 1: Control flow programs with pointers *)

Module ImpCFPointer.

(** Here we define a programming language with break, continue, addresses and
    pointers. *)

Definition var: Type := nat.

Inductive aexp : Type :=
  | ANum (n : Z)
  | AId (X : var)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp)
  | ADeref (a1: aexp)
  | AAddr (a1: aexp).

Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BNot (b : bexp)
  | BAnd (b1 b2 : bexp).

Inductive com : Type :=
  | CSkip
  | CAss (a1 a2 : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CWhile (b : bexp) (c : com)
  | CBreak
  | CCont.

(** Its expressions' denotations can be defined as we taught in the lecture of
    Pointer_And_Address. *)

Definition var2addr (X: var): Z := Z.of_nat X + 1.

Definition state: Type := Z -> option Z.

Fixpoint aevalR (a: aexp): state -> option Z :=
  match a with
  | ANum n => fun _ => Some n
  | AId X => fun st => st (var2addr X)
  | APlus a1 a2 => OptF.add (aevalR a1) (aevalR a2)
  | AMinus a1 a2  => OptF.sub (aevalR a1) (aevalR a2)
  | AMult a1 a2 => OptF.mul (aevalR a1) (aevalR a2)
  | ADeref a1 => fun st =>
                   match aevalR a1 st with
                   | Some n1 => st n1
                   | None => None
                   end
  | AAddr a1 => aevalL a1
  end
with aevalL (a: aexp): state -> option Z :=
  match a with
  | ANum n => fun _ => None
  | AId X => fun st => Some (var2addr X)
  | APlus a1 a2 => fun _ => None
  | AMinus a1 a2  => fun _ => None
  | AMult a1 a2 => fun _ => None
  | ADeref a1 => aevalR a1
  | AAddr a1 => fun _ => None
  end.

Record bexp_denote: Type := {
  true_set: state -> Prop;
  false_set: state -> Prop;
  error_set: state -> Prop;
}.

Definition opt_test (R: Z -> Z -> Prop) (X Y: state -> option Z): bexp_denote :=
{|
  true_set := fun st =>
                   match X st, Y st with
                   | Some n1, Some n2 => R n1 n2
                   | _, _ => False
                   end;
  false_set := fun st =>
                   match X st, Y st with
                   | Some n1, Some n2 => ~ R n1 n2
                   | _, _ => False
                   end;
  error_set := fun st =>
                   match X st, Y st with
                   | Some n1, Some n2 => False
                   | _, _ => True
                   end;
|}.

Fixpoint beval (b: bexp): bexp_denote :=
  match b with
  | BTrue =>
      {| true_set := Sets.full;
         false_set := Sets.empty;
         error_set := Sets.empty;
      |}
  | BFalse =>
      {| true_set := Sets.empty;
         false_set := Sets.full;
         error_set := Sets.empty;
      |}
  | BEq a1 a2 =>
      opt_test Z.eq (aevalR a1) (aevalR a2)
  | BLe a1 a2 =>
      opt_test Z.le (aevalR a1) (aevalR a2)
  | BNot b =>
      {| true_set := false_set (beval b);
         false_set := true_set (beval b);
         error_set := error_set (beval b);
      |}
  | BAnd b1 b2 =>
      {| true_set := Sets.intersect
                       (true_set (beval b1))
                       (true_set (beval b2));
         false_set := Sets.union
                        (false_set (beval b1))
                        (Sets.intersect
                           (true_set (beval b1))
                           (false_set (beval b2)));
         error_set := Sets.union
                        (error_set (beval b1))
                        (Sets.intersect
                           (true_set (beval b1))
                           (error_set (beval b2)));
      |}
  end.

(** The commands' denotations are also records. *)

Record denote: Type := {
  NormalExit: state -> state -> Prop;
  BreakExit: state -> state -> Prop;
  ContExit: state -> state -> Prop;
  ErrorExit: state -> Prop;
}.

Definition skip_sem: denote :=
  {|
     NormalExit := BinRel.id;
     BreakExit := BinRel.empty;
     ContExit := BinRel.empty;
     ErrorExit := Sets.empty
  |}.

Definition asgn_sem (DA1 DA2: state -> option Z): denote :=
  {|
     NormalExit :=
       fun st1 st2 =>
         exists a v,
           DA1 st1 = Some a /\
           DA2 st1 = Some v /\
           st1 a <> None /\
           st2 a = Some v /\
           forall a', a <> a' -> st1 a' = st2 a';
     BreakExit := BinRel.empty;
     ContExit := BinRel.empty;
     ErrorExit :=
       fun st =>
         DA1 st = None \/ DA2 st = None \/
         (exists a, DA1 st = Some a /\ st a = None)
  |}.

(** We define the semantics of skips and assignments for you. Your task is to
    define the denotations of break, continue, sequential composition and
    if-then-else. *)

(** **** Exercise: 1 star, standard (break_sem) *)

Definition break_sem: denote :=
  {|
     NormalExit := BinRel.empty;
     BreakExit := BinRel.id;
     ContExit := BinRel.empty;
     ErrorExit := Sets.empty
  |}.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** **** Exercise: 1 star, standard (cont_sem) *)

Definition cont_sem: denote :=
  {|
     NormalExit := BinRel.empty;
     BreakExit := BinRel.empty;
     ContExit := BinRel.id;
     ErrorExit := Sets.empty
  |}.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** **** Exercise: 2 stars, standard (seq_sem) *)

Definition seq_sem (d1 d2: denote): denote :=
  {|
     NormalExit := BinRel.concat (NormalExit d1) (NormalExit d2);
     BreakExit := BinRel.union
                  (BreakExit d1)
                  (BinRel.concat (NormalExit d1) (BreakExit d2));
     ContExit := BinRel.union
                  (ContExit d1)
                  (BinRel.concat (NormalExit d1) (ContExit d2));
     ErrorExit := Sets.union
                  (ErrorExit d1)
                  (BinRel.dia (NormalExit d1) (ErrorExit d2))
  |}.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** **** Exercise: 2 stars, standard (if_sem) *)

Definition if_sem (db: bexp_denote) (d1 d2: denote): denote :=
  {|
     NormalExit := BinRel.union
                  (BinRel.concat
                     (BinRel.test_rel (true_set db))
                     (NormalExit d1))
                  (BinRel.concat
                     (BinRel.test_rel (false_set db))
                     (NormalExit d2));
     BreakExit := BinRel.union
                  (BinRel.concat
                      (BinRel.test_rel (true_set db))
                      (BreakExit d1))
                  (BinRel.concat
                      (BinRel.test_rel (false_set db))
                      (BreakExit d2));
     ContExit := BinRel.union
                  (BinRel.concat
                    (BinRel.test_rel (true_set db))
                    (ContExit d1))
                  (BinRel.concat
                    (BinRel.test_rel (false_set db))
                    (ContExit d2));
     ErrorExit := Sets.union
                  (error_set db)
                  (Sets.union
                      (BinRel.dia
                         (BinRel.test_rel (true_set db))
                         (ErrorExit d1))
                      (BinRel.dia
                         (BinRel.test_rel (false_set db))
                         (ErrorExit d2)))
|}.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

End ImpCFPointer.

(* ################################################################# *)
(** * Task 2: Call by value semantics of lambda calculus *)

Module CBVLambda.
Import LambdaIB.
Local Open Scope Z.
Local Open Scope string.

(** Consider the following lambda expressions. *)

Definition TRUE: tm := abs "t" (abs "f" "t").
Definition FALSE: tm := abs "t" (abs "f" "f").
Definition IFTHENELSE: tm := abs "b" (abs "x" (abs "y" (app (app "b" "x") "y"))).
Definition ZERO: tm := abs "F" (abs "x" "x").
Definition ONE: tm := abs "F" (abs "x" (app "F" "x")).

(** Please describe the evaluation process of the following expressions. *)

(** **** Exercise: 2 stars, standard *)

Definition expr1: tm := app (app (app IFTHENELSE TRUE) ZERO) ONE.

Definition process_1: list tm :=
[
  app (app (app IFTHENELSE TRUE) ZERO) ONE;
  app (app (abs "x" (abs "y" (app (app TRUE "x") "y"))) ZERO) ONE;
  app (abs "y" (app (app (abs "t" (abs "f" "t")) ZERO) "y")) ONE;
  app (app (abs "t" (abs "f" "t")) ZERO) ONE;
  app (abs "f" ZERO) ONE;
  ZERO
].
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** **** Exercise: 2 stars, standard *)

Definition expr2: tm := app ONE ONE.

Definition process_2: list tm :=
[
  app ONE ONE;
  abs "x" (app ONE "x")
].
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

End CBVLambda.

(* ################################################################# *)
(** * Task 3: General Questions regarding compilers *)

Module Compiler.

(** **** Exercise: 1 star, standard  *)

(** Suppose you write a program in a software company and the company uses
    compiler [G]. If your program should have behavior [A] according the
    language's standard documentation [D] but does have behavior [B] when you
    compiler it and run it, which statements below about compiler [G] and
    language standard [D] are correct?

    1. The standard [D] is wrong and should be fixed.

    2. The compiler [G] has a bug.

    3. If the program is designed to have behavior [A], you should modify the
       program.

    This is a multiple-choice problem. You should use an ascending Coq list to
    describe your answer, e.g. [1; 2; 3], [1; 3], [2]. *)

Definition my_choice1: list Z := [2; 3].
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** **** Exercise: 1 star, standard  *)

(** Suppose a verification tool [V] is developed in Coq to verify programs, and
    these programs will be compiled by compiler [G]. If a program is proved in
    Coq to have behavior [A] via [V] but turns our to have behavior [B] when
    developers compile it and run it, which statement below is correct?

    1. The verification tool [V] does not correctly formalize programs'
       behavior.

    2. The compiler [G] has a bug. *)

Definition my_choice2: Z := 1.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

End Compiler.

(* 2021-06-09 22:50 *)


Definition AtomVars := nat.

Inductive Fo :=
 |Atom (p:AtomVars) : Fo
 |Bot :Fo
 |Conj:Fo->Fo->Fo
 |Disj:Fo->Fo->Fo
 |Impl:Fo->Fo->Fo
.

Notation " x -/\ y ":=(Conj x y) (at level 80).
Notation " x -\/ y ":=(Disj x y) (at level 80).
Notation " x --> y ":=(Impl x y) (at level 80).

Definition Top:Fo := Bot --> Bot.

Definition Valuations := AtomVars -> bool.

Section foIb_sec.
Context (v:AtomVars -> bool).
Fixpoint foIb (f:Fo) : bool
:= match f with
   | Atom p => v p
   | Bot => false
   | f1 -/\ f2 => andb (foIb f1) (foIb f2)
   | f1 -\/ f2 => orb (foIb f1) (foIb f2)
   | f1 --> f2 => implb (foIb f1) (foIb f2)
   end.
End foIb_sec.

(*Proof.
destruct f.
Show Proof.
Definition isTauto := forall.
Proof.
Defined.*)


Set Implicit Arguments.
Require Import ZArith Psatz.
Require Import Znumtheory.
Require Import List Sorting Permutation.
Require Import MiniCooper.MyTactics.
Import ListNotations.
Open Scope list_scope.
Open Scope Z_scope.

(* Normalization procedure on linear combinations. *)

Module Type LinVar.
  Parameter t : Type.
  Parameter eqdec : forall (v1 v2 : t), { v1 = v2 } + { v1 <> v2 }.
  Parameter leb : t -> t -> bool.
  Parameter leb_total : forall a b, is_true (leb a b) \/ is_true (leb b a).
End LinVar.

Module NatVar <: LinVar.
  Definition t := nat.
  Definition eqdec := Nat.eq_dec.
  Definition leb := Nat.leb.
  Lemma leb_total : forall a b, is_true (Nat.leb a b) \/ is_true (Nat.leb b a).
  Proof.
    intros. unfold is_true. rewrite !Nat.leb_le. lia.
  Qed.
End NatVar.

Module LinSimpl (Var : LinVar).

(* A monom is a variable multiplied by a constant coefficient *)
Notation monom := (Var.t * Z)%type.

(* A linear combination is a list of monoms, and should be interpreted as their
   sum. *)
Definition lin := list monom.

Definition interpret_lin (var : Var.t -> Z) (l : lin) : Z :=
  fold_right (fun '(v, k) acc =>
    acc + k * var v
  ) 0 l.

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

Definition add (l1 l2 : lin) :=
  l1 ++ l2.

Lemma interpret_add:
  forall var l1 l2,
  interpret_lin var (add l1 l2) =
  interpret_lin var l1 + interpret_lin var l2.
Proof.
  induction l1 as [|[? ?]]; intros; simpl in *; rewrite ?IHl1; eauto.
Qed.

Definition mul (k : Z) (l : lin) :=
  map (fun '(v, k') => (v, k * k')) l.

Lemma interpret_mul:
  forall var k l,
  interpret_lin var (mul k l) = k * interpret_lin var l.
Proof.
  induction l as [|[? ?]]; intros; simpl in *; rewrite ?IHl; lia.
Qed.

Definition sub (l1 l2 : lin) :=
  add l1 (mul (-1) l2).

Lemma interpret_sub:
  forall var l1 l2,
  interpret_lin var (sub l1 l2) =
  interpret_lin var l1 -
  interpret_lin var l2.
Proof.
  intros; unfold sub; rewrite interpret_add, interpret_mul; lia.
Qed.

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

Definition clear_zeros (l : lin) : lin :=
  filter (fun '(v, k) => negb (Z.eqb k 0)) l.

(* Compaction: merges coefficients of monoms with the same variable.
   This assumes [l] to be sorted. *)
Fixpoint compact_with (m : monom) (l : lin) : lin :=
  let '(v, k) := m in
  match l with
  | [] =>
    [m]
  | (v', k') :: l' =>
    if Var.eqdec v v' then
      compact_with (v, k + k') l'
    else
      m :: compact_with (v', k') l'
  end.

Definition compact (l : lin) : lin :=
  match l with
  | [] =>
    []
  | m :: l' =>
    compact_with m l'
  end.

Module MonomOrder <: Orders.TotalLeBool.
  Definition t := monom.
  Definition leb (x y : t) := Var.leb (fst x) (fst y).
  Lemma leb_total : forall a b, is_true (leb a b) \/ is_true (leb b a).
  Proof.
    destruct a, b; unfold leb; simpl.
    destruct (Var.leb_total t0 t1); eauto.
  Qed.
End MonomOrder.

Module MonomSort := Sort MonomOrder.

Definition simpl (l : lin) : lin :=
  let l := MonomSort.sort l in
  let l := compact l in
  clear_zeros l.

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

Local Ltac rew :=
  rewrite
     ?Nat.eqb_eq, ?Nat.eqb_neq,
     ?Bool.negb_false_iff, ?Bool.negb_true_iff,
     ?Z.eqb_eq, ?Z.eqb_neq
  in *.

Lemma interpret_clear_zeros:
  forall var l,
  interpret_lin var (clear_zeros l) = interpret_lin var l.
Proof.
  induction l as [| [? ?]]; intros; simpl in *; eauto.
  case_if; simpl; rew; subst; lia.
Qed.

Lemma interpret_compact_with:
  forall var l k v,
  interpret_lin var (compact_with (v,k) l) =
  k * var v + interpret_lin var l.
Proof.
  induction l as [| [? ?]]; intros; simpl in *; eauto.
  case_if; simpl; rewrite IHl; rew; subst; nia.
Qed.

Lemma interpret_compact:
  forall var l,
  interpret_lin var (compact l) = interpret_lin var l.
Proof.
  intros. unfold compact. destruct l as [|[? ?]]; eauto.
  rewrite interpret_compact_with. simpl. nia.
Qed.

Lemma interpret_lin_permutation:
  forall var l1 l2,
  Permutation l1 l2 ->
  interpret_lin var l1 = interpret_lin var l2.
Proof.
  intros * HP. induction HP;
  repeat match goal with x: (_ * _)%type |- _ => destruct x end;
  simpl; auto.
Qed.

Lemma interpret_simpl:
  forall var l,
  interpret_lin var (simpl l) =
  interpret_lin var l.
Proof.
  intros. unfold simpl.
  rewrite interpret_clear_zeros, interpret_compact.
  rewrite interpret_lin_permutation with (l1:=l) (l2:=(MonomSort.sort l));
  auto using MonomSort.Permuted_sort.
Qed.

End LinSimpl.


Require Export Utf8_core.
Require Import HoTT TruncType.
Require Import hit.Connectedness hit.Truncations.

Set Universe Polymorphism.

Local Open Scope path_scope.
(* Local Open Scope equiv_scope. *)

Section Images.

  (* Definition 3 *)
  Definition Im {A B} (f : A -> B) := {b : B & Trunc (-1) (hfiber f b)}.

  Definition toIm {A B} (f : A -> B) : A -> Im f := fun a => (f a; tr (a;idpath)).

  Definition fromIm {A B} (f : A -> B) : Im f -> B := fun im => pr1 im.

End Images.

Section Embeddings.

  (* In this section, we define IsEmbedding two other way, then prove that they are all three equivalent *)
  Context `{fs: Funext}.

  Definition IsMono {A B : Type} (f : A -> B)
    := forall x y, IsEquiv (ap f (x:=x) (y:=y)).

  Definition IsMonof {A B : Type} (f : A -> B)
    := forall (X:Type) (x y : X -> A), IsEquiv (ap (fun u => f o u) (x:=x) (y:=y)).

  Lemma IsEmbedding_IsMono {A B : Type} (f : A -> B)
    : IsEmbedding f <-> IsMono f.
    split.
    - intros H x y.
      apply isequiv_fcontr. intro q.
      pose (Y := equiv_path_hfiber (x;1) (y;q^)); cbn in Y.
      simple refine (contr_equiv' (∃ q0 : x = y, 1 = ap f q0 @ q^) _).
      simple refine (equiv_functor_sigma_id _); intro a.
      pose (ff:= (equiv_inverse (BuildEquiv _ _ _ (isequiv_moveL_pV q 1 (ap f a))))).
      rewrite concat_1p in ff.
      exact (equiv_compose' (equiv_path_inverse q (ap f a)) ff).
      simple refine (@contr_equiv' ((x; 1) = (y; q^)) _ (equiv_inverse Y) _).
    - intros H b x y; simpl. pose (Y:=equiv_path_hfiber x y).
      simple refine (@contr_equiv' _ _ Y _).
      pose (fcontr_isequiv (ap f) (H x.1 y.1) (x.2@y.2^)).
      match goal with
      |[ i : Contr ?AA |- Contr ?BB ] => assert (X: AA <~> BB)
      end.
      simple refine (equiv_functor_sigma_id _); intro a.
      pose (ff:= (equiv_inverse (BuildEquiv _ _ _ (isequiv_moveL_pV y.2 (ap f a) x.2)))).
      exact (equiv_compose' (equiv_path_inverse (ap f a @ y.2) x.2) ff).
      simple refine (@contr_equiv' _ _ X _).
  Qed.

  Definition IsMonof_to_isMono {A B : Type} (f : A -> B) : IsMonof f -> IsMono f.
    intro H. intros x y.
    unfold IsMonof in H.
    specialize (H A). specialize (H (fun _ => x) (fun _ => y)).
    destruct H as [inv retr sect _].
    simple refine (isequiv_adjointify _ _ _ _).
    - intro H.
      simple refine (apD10 (f := λ _, x) (g := λ _, y) (inv _) _).
      apply path_forall; intro u; exact H. exact x.
    - intro u.
      etransitivity; try exact (ap10_ap_postcompose f (g:=(λ _ : A, x)) (g' := (λ _ : A, y)) (inv (path_forall (λ _ : A, f x) (λ _ : A, f y) (λ _ : A, u))) x)^.
      rewrite retr.
      unfold ap10. unfold path_forall.
      rewrite eisretr.
      reflexivity.
    - intro u. destruct u; simpl in *.
      rewrite path_forall_1.
      apply (transport (fun u => ap10 u x = 1) (sect 1)^).
      reflexivity.
  Defined.

  Definition IsMono_to_IsMonof {A B : Type} (f : A -> B) : IsMono f -> IsMonof f.
    intro H.
    intros X a b.
    pose (φ := fun p => path_forall a b (fun x => equiv_inv (IsEquiv := H (a x) (b x)) (ap10 p x))).
    apply isequiv_adjointify with (g:= φ).
    - intro p.
      unfold φ.
      apply (@equiv_inj _ _ _ (isequiv_apD10 _ _ _ _)).
      apply path_forall; intro u.
      apply (transport (λ U, U = ap10 p u) (ap10_ap_postcompose f _ u)^).
      unfold ap10 at 1, path_forall. rewrite eisretr. rewrite eisretr. reflexivity.
    - intro p; unfold φ; destruct p. simpl.
      pose (foo := path_forall _ _ (fun y =>  (@eissect _ _ _ (H (a y) (a y)) idpath))).
      simpl in foo. rewrite foo.
      apply path_forall_1.
  Qed.

  Definition apf_Mono {T U : Type} (f: T -> U) (fMono : IsMonof f) X (x y : X -> T) (e e' : x = y) :
    ap (fun u => f o u) e = ap (fun u => f o u) e' -> e = e'.
    intro.
    rewrite <- (@eissect _ _ _ (fMono _ _ _) e).
    rewrite <- (@eissect _ _ _ (fMono _ _ _) e'). exact (ap _ X0).
  Defined.

  Lemma compose_equiv {A B C D:Type} (φ : A -> B) (u v : B -> C) (f : C -> D)
        (equiv_compose_φ : IsEquiv (ap (λ x, x o φ) (x:= f o u) (y := f o v)))
        (Mono_f : IsMono f)
    : IsEquiv (ap (λ x, x o φ) (x:=u) (y:=v)).
  Proof.
    pose (Monof_f := IsMono_to_IsMonof f Mono_f).
    unfold IsMonof in *; simpl in *.

    pose (e1 := (Monof_f B u v)).
    pose (e2 := (equiv_compose_φ)).
    pose (e3 := @isequiv_inverse _ _ _ (Monof_f A (u o φ) (v o φ))).

    assert (X: ((ap (λ u0 : A → C, f o u0))^-1 o (ap (λ x : B → D, x o φ) o (ap (λ u0 : B → C, f o u0) (x:=u) (y:=v)))) = (ap (λ x : B → C, x o φ))).
    apply path_forall; intro p.
    apply (@equiv_inj _ _ _ (Monof_f A (u o φ) (v o φ))). rewrite eisretr.
    destruct p; reflexivity.

    destruct X. exact (@isequiv_compose _ _ _ (@isequiv_compose _ _ _ e1 _ _ e2) _ _ e3).
  Qed.

End Embeddings.

Section Surjections.

  (* Some lemmas about surjections *)
  Context `{ua: Univalence}.
  Context `{fs: Funext}.

  Lemma IsSurjection_toIm (X Y:Type) (f:X -> Y)
  : IsSurjection (toIm f).
    apply BuildIsSurjection.
    intros [b p]; generalize dependent p.
    apply Trunc_ind.
    intro a; apply istrunc_truncation.
    intros [a p].
    apply tr.
    exists a. apply path_sigma' with p.
    apply path_ishprop.
  Defined.

  Lemma epi_prod (W X Y Z:Type) (f:X -> Y) (g:W -> Z) (epif : IsSurjection f) (epig : IsSurjection g)
  : IsSurjection (λ x, (f (fst x), g (snd x))).
  Proof.
    apply BuildIsSurjection.
    intros [y z].
    specialize (epif y); specialize (epig z).
    generalize dependent (center _ (Contr_internal := epif)); apply Trunc_ind; intro x; try apply istrunc_truncation.
    generalize dependent (center _ (Contr_internal := epig)); apply Trunc_ind; intro w; try apply istrunc_truncation.
    apply tr.
    exists (x.1,w.1). simpl.
    apply path_prod; [exact x.2 | exact w.2].
  Qed.

  Lemma epi_two_out_of_three_1 (A B C:Type) (f:A -> B) (g:B -> C) (h : A -> C) (π : forall a,  g (f a) = h a)
  : IsSurjection f -> IsSurjection g -> IsSurjection h.
    intros Ef Eg.
    apply BuildIsSurjection.
    intros c.
    generalize dependent (@center _ (Eg c)).
    apply Trunc_rec. intros [b p].
    generalize dependent (@center _ (Ef b)).
    apply Trunc_rec. intros [a q].
    apply tr.
    exists a.
    rewrite <- (π a).
    rewrite q.
    exact p.
  Qed.

  Lemma epi_two_out_of_three_2 (A B C:Type) (f:A -> B) (g:B -> C) (h : A -> C) (π : forall a,  g (f a) = h a)
  : IsSurjection f -> IsSurjection h -> IsSurjection g.
    intros Ef Eh.
    apply BuildIsSurjection.
    intros c.
    generalize dependent (@center _ (Eh c)).
    apply Trunc_rec. intros [a p].
    apply tr.
    exists (f a).
    exact ((π a) @ p).
  Qed.

  Definition IsEpi A B (f:A -> B)
    := forall C:Type, forall (x y : B -> C) , IsEquiv (ap (fun u => u o f) (x:=x) (y:=y)).

End Surjections.


From Containers Require Import Maps MapFacts.
Require Import Arith.

Record Multiset (A:Type) {H:OrderedType A} : Type :=
  {
    ms :> Map[A,nat];
    ms_safe : forall x n, find x ms = Some n -> n >= 1
  }.

Definition null (A:Type) {H:OrderedType A} (m:Multiset A) : bool :=
  is_empty (ms _ m).

Definition mempty (A:Type) {H:OrderedType A} : Multiset A.
  refine(Build_Multiset A _ (@empty A H _ nat) _).
  abstract(intros;vm_compute in H0;discriminate).
Defined.

Lemma null_correct : forall (A:Type) {H:OrderedType A}, null A (mempty A) = true.
Proof.
  intros.
  unfold null. simpl. vm_compute. reflexivity.
Qed.

Check @add.

Lemma msingleton_aux:
  forall (A : Type) (H:OrderedType A) (x : A),
  forall (x0 : A) (n : nat), (([]) [x <- 1]) [x0] = Some n -> n >= 1.
Proof.
  intros.
  destruct(eq_dec x x0);intros.
  + pose proof (@add_eq_o A _ _ _ _ ([]) x x0 1 H1).
    rewrite H2 in H0. injection H0. intros. subst. auto with arith.
  + apply find_mapsto_iff in H0.
    apply add_mapsto_iff in H0.
    destruct H0.
    destruct H0. contradiction.
    destruct H0. apply empty_mapsto_iff in H2. elim H2.
Qed.

Definition msingleton (A:Type) {H:OrderedType A} (x:A) : Multiset A.
  refine(Build_Multiset A _ (@add A H _ nat x 1 (@empty A H _ nat))  _).
  abstract(intros;eapply msingleton_aux;eauto).
Defined.

Definition munion (A:Type) {H:OrderedType A} (m1 m2 : Multiset A) : Multiset A.

Print msingleton.


From mathcomp.ssreflect
Require Import ssreflect ssrfun ssrbool ssrnat seq eqtype.
From mathcomp
Require Import path.
Require Import pred.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(****************************************************)
(* A theory of permutations over non-equality types *)
(****************************************************)

Section Permutations.
Variable A : Type.

Lemma in_split (x : A) (s : seq A) :
        x \In s -> exists s1, exists s2, s = s1 ++ x :: s2.
Proof.
elim:s=>[|y s IH] //=; rewrite InE.
case=>[<-|]; first by exists [::]; exists s.
by case/IH=>s1 [s2] ->; exists (y :: s1); exists s2.
Qed.

Inductive perm (s1 s2 : seq A) : Prop :=
| permutation_nil of s1 = [::] & s2 = [::]
| permutation_skip x t1 t2 of s1 = x :: t1 & s2 = x :: t2 & perm t1 t2
| permutation_swap x y t of s1 = x :: y :: t & s2 = y :: x :: t
| permutation_trans t of perm s1 t & perm t s2.

Lemma perm_nil (s : seq A) : perm [::] s <-> s = [::].
Proof.
split=>[H|]; last by move=>->; apply: permutation_nil.
move: {1 2}[::] s H (erefl (Nil A)).
apply: perm_ind=>[|s1 s2 x t1 t2 ->|s1 s2 x y t ->|s1 s2 t _ IH1 _ IH2] //.
by move/IH1; move/IH2.
Qed.

Lemma perm_refl (s : seq A) : perm s s.
Proof.
elim:s=>[|e s IH]; first by apply: permutation_nil.
by apply: (permutation_skip (x:=e)) IH.
Qed.

Hint Resolve perm_refl.

Lemma perm_sym s1 s2 : perm s1 s2 <-> perm s2 s1.
Proof.
suff L: forall s1 s2, perm s1 s2 -> perm s2 s1 by split; apply: L.
apply: perm_ind=>s1' s2'.
- by move=>->->; apply: permutation_nil.
- by move=>x t1 t2 -> -> H1; apply: permutation_skip.
- by move=>x y t -> ->; apply: permutation_swap.
by move=>t _ H1 _ H2; apply: permutation_trans H2 H1.
Qed.

Lemma perm_trans s2 s1 s3 : perm s1 s2 -> perm s2 s3 -> perm s1 s3.
Proof. by apply: permutation_trans. Qed.

Lemma perm_in s1 s2 x : perm s1 s2 -> x \In s1 -> x \In s2.
Proof.
move: s1 s2; apply: perm_ind=>s1 s2.
- by move=>->->.
- move=>y t1 t2 -> -> H; rewrite !InE; tauto.
- by move=>y z t -> ->; rewrite !InE; tauto.
by move=>t _ IH1 _ IH2; move/IH1; move/IH2.
Qed.

Lemma perm_cat2lL s s1 s2 : perm s1 s2 -> perm (s ++ s1) (s ++ s2).
Proof. by elim:s=>[|e s IH] //=; move/IH; apply: permutation_skip. Qed.

Lemma perm_cat2rL s s1 s2 : perm s1 s2 -> perm (s1 ++ s) (s2 ++ s).
Proof.
move=>H; move: s1 s2 H s; apply: perm_ind=>s1 s2.
- by move=>->->.
- by move=>x t1 t2 -> -> H IH s /=; apply: permutation_skip.
- by move=>x y t -> -> s /=; apply: permutation_swap.
by move=>t H1 IH1 H2 IH2 s; apply: permutation_trans (IH2 s).
Qed.

Lemma perm_catL s1 t1 s2 t2 :
        perm s1 s2 -> perm t1 t2 -> perm (s1 ++ t1) (s2 ++ t2).
Proof.
move=>H; move: s1 s2 H t1 t2; apply: perm_ind=>s1 s2.
- by move=>->->.
- move=>x t1 t2 -> -> H IH r1 r2.
  by move/IH; apply: permutation_skip.
- move=>x y t -> -> t1 t2 H.
  by apply: (permutation_trans (t:=[:: x, y & t] ++ t2));
     [apply: perm_cat2lL | simpl; apply: permutation_swap].
move=>t H1 IH1 H2 IH2 t1 t2 H.
by apply: permutation_trans (IH2 _ _ H); apply: IH1.
Qed.

Lemma perm_cat_consL s1 t1 s2 t2 x :
        perm s1 s2 -> perm t1 t2 -> perm (s1 ++ x :: t1) (s2 ++ x :: t2).
Proof.
by move=>H1 H2; apply: perm_catL H1 _; apply: permutation_skip H2.
Qed.

Lemma perm_catC s1 s2 : perm (s1 ++ s2) (s2 ++ s1).
Proof.
elim:s1 s2=>[|x s1 IH1] s2 /=; first by rewrite cats0.
apply: (@perm_trans (x::s2++s1)); first by apply: permutation_skip (IH1 s2).
elim: s2=>[|y s2 IH2] //=.
apply: (@perm_trans (y::x::s2++s1)); first by apply: permutation_swap.
by apply: permutation_skip IH2.
Qed.

Hint Resolve perm_catC.

Lemma perm_cons_catCA s1 s2 x : perm (x :: s1 ++ s2) (s1 ++ x :: s2).
Proof.
rewrite -cat_rcons -cats1 -cat_cons -cat1s.
by apply: perm_cat2rL; apply: perm_catC.
Qed.

Lemma perm_cons_catAC s1 s2 x : perm (s1 ++ x :: s2) (x :: s1 ++ s2).
Proof. by apply/perm_sym; apply: perm_cons_catCA. Qed.

Hint Resolve perm_cons_catCA perm_cons_catAC.

Lemma perm_cons_cat_consL s1 s2 s x :
        perm s (s1 ++ s2) -> perm (x :: s) (s1 ++ x :: s2).
Proof.
case: s1=>[|a s1] /= H; first by apply: permutation_skip.
apply: (@perm_trans (x::a::s1++s2)); first by apply: permutation_skip.
apply: (@perm_trans (a::x::s1++s2)); first by apply: permutation_swap.
by apply: permutation_skip=>//; apply: perm_catCA.
Qed.

(* a somewhat generalized induction principle *)
Lemma perm_ind2 (P : seq A -> seq A -> Prop) :
        P [::] [::] ->
        (forall x s1 s2, perm s1 s2 -> P s1 s2 ->
           P (x :: s1) (x :: s2)) ->
        (forall x y s1 s2, perm s1 s2 -> P s1 s2 ->
           P (y :: x :: s1) (x :: y :: s2)) ->
        (forall s2 s1 s3, perm s1 s2 -> P s1 s2 ->
           perm s2 s3 -> P s2 s3 -> P s1 s3) ->
        forall s1 s2, perm s1 s2 -> P s1 s2.
Proof.
move=>H1 H2 H3 H4; apply: perm_ind=>s1 s2; last 1 first.
- by move=>t; apply: H4.
- by move=>->->.
- by move=>x t1 t2 -> ->; apply: H2.
move=>x y t -> ->.
have R : forall t, P t t by elim=>[|e t1 IH] //; apply:  H2.
apply: (H4 (y :: x :: t))=>//; last by apply: H3.
by apply: permutation_swap.
Qed.

Lemma perm_size l1 l2: perm l1 l2 -> size l1 = size l2.
Proof.
move: l1 l2; apply: perm_ind=>s1 s2=>[|x t1 t2|x y t|t]; first by move=>->->.
- by move=>->->{s1 s2} _ /=->.
- by move=>->->{s1 s2}/=.
- by move=>_->_->.
Qed.

(* Now the hard part; the opposite implications *)
Lemma perm_cat_consR s1 t1 s2 t2 x :
        perm (s1 ++ x :: t1) (s2 ++ x :: t2) -> perm (s1 ++ t1) (s2 ++ t2).
Proof.
move: s1 t1 s2 t2 x.
suff H:
  forall r1 r2, perm r1 r2 -> forall x s1 t1 s2 t2,
    r1 = s1 ++ x :: t1 -> r2 = s2 ++ x :: t2 -> perm (s1 ++ t1) (s2 ++ t2).
- by move=>s1 t1 s2 t2 x; move/H; apply.
apply: perm_ind2; last 1 first.
- move=>s2 s1 s3 H1 IH1 H2 IH2 x r1 t1 r2 t2 E1 E2.
  case: (@in_split x s2).
  - apply: perm_in H1 _; rewrite E1; apply: (@perm_in (x::r1++t1))=>//.
  by rewrite InE; left.
  move=>s4 [s5] E; apply: (@perm_trans (s4++s5)); first by apply: IH1 E1 E.
  by apply: IH2 E E2.
- by move=>x [].
- move=>x t1 t2 H IH y s1 s2 p1 p2 E1 E2.
  case: s1 E1=>[|b s1] /=; case: p1 E2=>[|c p1] /= E1 E2.
  - by case: E1 E2=><- <- [<-].
  - apply: (@perm_trans (p1 ++ c :: p2))=>//.
    by case: E1 H=><- ->; case: E2=><- ->.
  - case: E1 E2 H=><- <- [<-] ->; apply: (@perm_trans (s1 ++ x:: s2)).
    by apply: perm_cons_cat_consL.
  case: E1 E2 H IH=><- -> [<-] -> H IH.
  by apply: permutation_skip=>//; apply: IH.
move=>x y p1 p2 H IH z s1 t1 s2 t2 E1 E2.
case: s1 E1 H IH=>[|b s1]; case: s2 E2=>[|c s2]=>/=.
- by case=><- <- [<-] <- H IH; apply: permutation_skip.
- case=><-; case: s2=>[|b s2] /=.
  - by case=><- <-; case=><- H IH; apply: permutation_skip H.
  case=><- -> [<-] <- H IH.
  by apply: permutation_skip=>//; apply: perm_trans H _.
- case=><- <- [<-]; case: s1=>[|a s1] /=.
  - by case=><- H IH; apply: permutation_skip.
  by case=><- -> H IH; apply: permutation_skip=>//; apply: perm_trans H.
case=><-; case: s2=>[|a s2] /=; case: s1=>[|d s1] /=.
- by case=><- <- [<-] <- <- H IH; apply: permutation_skip.
- case=><- <- [<-] <- -> H IH.
  apply: (@perm_trans (x::y::s1 ++ t1)); first by apply: permutation_swap.
  by apply: permutation_skip=>//; apply: perm_trans H.
- case=><- -> [<-] <- <- H IH.
  apply: (@perm_trans (y::x::s2++t2)); last by apply: permutation_swap.
  by apply: permutation_skip=>//; apply: perm_trans H _.
case=><- -> [<-] <- -> H IH.
apply: (@perm_trans (x::y::s1++t1)); first by apply: permutation_swap.
by apply: permutation_skip=>//; apply: permutation_skip=>//; apply: IH.
Qed.

Lemma perm_cons x s1 s2 : perm (x :: s1) (x :: s2) <-> perm s1 s2.
Proof.
split; last by apply: permutation_skip.
by move/(@perm_cat_consR [::] s1 [::] s2 x).
Qed.

Lemma perm_cons_cat_cons x s1 s2 s :
        perm (x :: s) (s1 ++ x :: s2) <-> perm s (s1 ++ s2).
Proof.
split=>[|H]; first by by move/(@perm_cat_consR [::] s s1 s2 x).
by apply: (@perm_trans (x :: s1++s2))=>//; apply: permutation_skip.
Qed.

Lemma perm_cat_cons x s1 s2 t1 t2 :
        perm (s1 ++ x :: t1) (s2 ++ x :: t2) <-> perm (s1 ++ t1) (s2 ++ t2).
Proof.
split=>[|H]; first by apply: perm_cat_consR.
apply: (@perm_trans (x::s1++t1))=>//; apply: (@perm_trans (x::s2++t2))=>//.
by apply/perm_cons.
Qed.

Lemma perm_cat2l s1 s2 s3: perm (s1 ++ s2) (s1 ++ s3) <-> perm s2 s3.
Proof.
split; last by apply: perm_cat2lL.
elim: s1 s2 s3=>[|x s1 IH] s2 s3 //= H.
by apply: IH; move/perm_cons: H.
Qed.

Lemma perm_cat2r s1 s2 s3 : perm (s2 ++ s1) (s3 ++ s1) <-> perm s2 s3.
Proof.
split; last by apply: perm_cat2rL.
elim: s1 s2 s3=>[|x s1 IH] s2 s3 /=; first by rewrite !cats0.
by move=>H; apply: IH; apply: perm_cat_consR H.
Qed.

Lemma perm_catAC s1 s2 s3 : perm ((s1 ++ s2) ++ s3) ((s1 ++ s3) ++ s2).
Proof. by move=>*; rewrite -!catA perm_cat2l. Qed.

Lemma perm_catCA s1 s2 s3 : perm (s1 ++ s2 ++ s3) (s2 ++ s1 ++ s3).
Proof. by move=>*; rewrite !catA perm_cat2r. Qed.

End Permutations.

Hint Resolve perm_refl perm_catC perm_cons_catCA
             perm_cons_catAC perm_catAC perm_catCA.

(* perm and map *)

Lemma perm_map A B (f : A -> B) (s1 s2 : seq A) :
        perm s1 s2 -> perm (map f s1) (map f s2).
Proof.
set P := fun s1 s2 => perm (map f s1) (map f s2).
suff {s1 s2} L: forall s1 s2, perm s1 s2 -> P s1 s2 by apply: L.
apply: perm_ind2=>//; last 1 first.
- move=>s2 s1 s3 _ IH1 _ IH2.
  by apply: perm_trans IH1 IH2.
- by move=>x s1 s2 H IH; rewrite /P perm_cons.
move=>x1 x2 s1 s2 H IH.
have L: perm [:: f x2, f x1 & map f s1] ([:: f x1] ++ [:: f x2 & map f s1]).
- by apply/perm_cons_cat_cons.
by apply: perm_trans L _; rewrite !perm_cons.
Qed.

(* mapping to ssreflect decidable perm *)

Lemma perm_eq_perm (A : eqType) (s1 s2 : seq A) :
        reflect (perm s1 s2) (perm_eq s1 s2).
Proof.
apply: (iffP idP); last first.
- elim: s1 s2 /; last 1 first.
  - by move=>s1 s2 t _ H2 _; apply: perm_eq_trans H2.
  - by move=>s1 s2 ->->.
  - by move=>s1 s2 x t1 t2 ->-> H1 H2; rewrite seq.perm_cons.
  move=>s1 s2 x y t ->->.
  by rewrite -(perm_rot 1) /rot /= seq.perm_cons seq.perm_catC.
elim: s1 s2=>[|x s1 IH] /= s2.
- move/perm_eq_mem=>H; apply/perm_nil.
  by case: s2 H=>// a s2 /(_ a); rewrite inE eq_refl.
move=>H; move: (perm_eq_mem H x); rewrite inE eq_refl; move/esym=>/= H'.
move/(perm_eq_trans H): {H} (perm_to_rem H'); rewrite seq.perm_cons.
move/IH/(perm_cons x)=>H; apply: perm_trans H _.
elim: s2 x H'=>[|y s2 IH2] //= x.
rewrite inE; case/orP; first by move/eqP=><-; rewrite eq_refl.
case: eqP=>[->//|_ H]; move/(perm_cons y): (IH2 _ H).
by apply: perm_trans; apply: permutation_swap.
Qed.


Require Import Setoid.

Variable X : Set.

Variable f : X -> X.
Variable g : X -> X -> X.
Variable h : nat -> X -> X.

Variable lem0 : forall x, f (f x) = f x.
Variable lem1 : forall x, g x x = f x.
Variable lem2 : forall n x, h (S n) x = g (h n x) (h n x).
Variable lem3 : forall x, h 0 x = x.

Hint Rewrite lem0 lem1 lem2 lem3 : rew.

Goal forall x, h 10 x = f x.
Proof.
  intros.
  Time autorewrite with rew. (* 0.586 *)
  reflexivity.
Time Qed. (* 0.53 *)

Goal forall x, h 6 x = f x.
intros.
  Time rewrite_strat topdown lem2.
  Time rewrite_strat topdown lem1.
  Time rewrite_strat topdown lem0.
  Time rewrite_strat topdown lem3.
  reflexivity.
Undo 5.
  Time rewrite_strat topdown (choice lem2 lem1).
  Time rewrite_strat topdown (choice lem0 lem3).
  reflexivity.
Undo 3.
  Time rewrite_strat (topdown (choice lem2 lem1); topdown (choice lem0 lem3)).
  reflexivity.
Undo 2.
  Time rewrite_strat (topdown (choice lem2 (choice lem1 (choice lem0 lem3)))).
  reflexivity.
Undo 2.
  Time rewrite_strat (topdown (choice lem2 (choice lem1 (choice lem0 lem3)))).
  reflexivity.
Qed.

Goal forall x, h 10 x = f x.
Proof.
  intros.
  Time rewrite_strat topdown (hints rew). (* 0.38 *)
  reflexivity.
Time Qed. (* 0.06 s *)

Set Printing All.
Set Printing Depth 100000.