(* -*- mode: coq; mode: visual-line -*-  *)
Require Import HoTT.Basics.
Require Import Groupoid.
Require Import Types.Prod.

(** * Quotient of a Type by a groupoid

We aim to model:
<<
Inductive quotient1 : Type :=
   | point : A -> quotient1
   | cell : forall x y, morphism x y -> point x = point y
   | cell_compose : forall x y z (f : morphism x y) (g : morphism y z),
                    cell (g o f) = cell f @ cell g
   | quotient1_trunc : IsTrunc 1 quotient1
>>
*)

Module Export Quotient1.
Section Domain.
  Variable A : Type.
  Variable R : A -> A -> Type.
  Context {R_HSet : forall x y, IsHSet (R x y)}
          {R_refl : Reflexive R}
          {R_trans : Transitive R}
          {R_symm : Symmetric R}.
  Variable G : groupoid A R.

  Local Open Scope groupoid_scope.

  Private Inductive quotient1 (R : A -> A -> Type)
                    (*`{IsHSet A}*) `{R_HSet : forall x y, IsHSet (R x y)}
                    `{Reflexive _ R} `{Transitive _ R} `{Symmetric _ R}
                     (G : groupoid A R) : Type :=
  | point : A -> quotient1 R G
  .
  Axiom cell : forall {x y}, R x y -> point R G x = point R G y.
  Axiom cell_compose : forall {x y z} (f : R x y) (g : R y z),
        cell (g o f)%groupoid = cell f @ cell g.
  Axiom quotient1_trunc : IsTrunc 1 (quotient1 R G).
  Global Existing Instance quotient1_trunc.

  (* The induction principle for groupoid quotients *)
  Section quotient1_ind.

    Variable P : quotient1 R G -> Type.
    Context {P_1Type : forall a, IsTrunc 1 (P a)}.
    Variable P_point : forall x, P (point R G x).
    Variable P_cell : forall {x y} (f : R x y),
                      cell f # P_point x = P_point y.
    Variable P_compose : forall x y z (f : R x y) (g : R y z),
             P_cell _ _ (g o f)
           = transport2 P (cell_compose f g) (P_point x)
           @ (transport_pp _ _ _ _
           @ ap _ (P_cell _ _ f)
           @ P_cell _ _ g).

    Definition quotient1_ind (a : quotient1 R G) : P a :=
      ( match a with
        | point x => fun _ _ _ => P_point x
        end ) P_1Type P_cell P_compose.

    Axiom quotient1_ind_cell : forall {x y} (f : R x y),
          apD quotient1_ind (cell f) = P_cell _ _ f.

    Let quotient1_ind_compose' : forall {x y z} (f : R x y) (g : R y z),
        apD quotient1_ind (cell (g o f))
      = transport2 P (cell_compose f g) (quotient1_ind (point R G x))
      @ apD quotient1_ind (cell f @ cell g).
    Proof.
      intros.
      refine (quotient1_ind_cell (g o f) @ _).
      refine (P_compose _ _ _ f g @ _).
      refine (1 @@ _).
      refine (1 @@ ap _ (quotient1_ind_cell f)^ @@ (quotient1_ind_cell g)^ @ _).
      refine (apD_pp _ _ _)^.
    Defined.

    Axiom quotient1_ind_compose : forall x y z (f : R x y) (g : R y z),
          apD02 quotient1_ind (cell_compose f g)
        = quotient1_ind_compose' f g.

  End quotient1_ind.

Lemma transport_const_pp : forall {A B} {x1 x2 x3 : A} (p : x1 = x2) (q : x2 = x3) (y : B),
      transport_const (p @ q) y
    = transport_pp (fun _ => B) p q y
    @ (ap _ (transport_const p y)
    @ transport_const q y).
Proof.
  destruct p. destruct q. intros.
  auto.
Qed.

Lemma transport_const_inv : forall {A B} {x1 x2 : A}
                                   (p : x1 = x2) {y1 y2 : B} (q : y1 = y2),
      transport_const p y1 @ q
    = ap (transport (fun _ => B) p) q
    @ transport_const p y2.
Proof.
  destruct p; destruct q; auto.
Qed.

Lemma apD_const' : forall {A B} {x y : A} (f : A -> B) (p : x = y),
      ap f p = (transport_const p (f x))^ @ apD f p.
Proof. intros.
       apply moveL_Vp.
       apply (apD_const _ _)^.
Defined.

  (** The recursion principle for groupoid quotients *)
  Section quotient1_rec.

    Variable C : Type.
    Variable C_point : A -> C.
    Variable C_cell : forall {x y}, R x y -> C_point x = C_point y.
    Variable C_compose : forall {x y z} (f : R x y) (g : R y z),
      C_cell _ _ (g o f) = C_cell _ _ f @ C_cell _ _ g.
    Context {C_1Type : IsTrunc 1 C}.

    Let C_cell' : forall {x y} (f : R x y),
      cell f # C_point x = C_point y.
    Proof.
      intros.
      refine (transport_const (cell f) (C_point x) @ C_cell _ _ f).
    Defined.

    Let C_compose' : forall {x y z} (f : R x y) (g : R y z),
        C_cell' (g o f)
      = transport2 (fun _ => C) (cell_compose f g) (C_point x)
      @ ((transport_pp (fun _ => C) (cell f) (cell g) (C_point x)
      @ ap (transport (fun _ => C) (cell g)) (C_cell' f))
      @ C_cell' g).
    Proof.
      intros.
      unfold C_cell'.
        refine (transport2_const (cell_compose f g) _ @@ 1 @ _).
        refine (concat_pp_p _ _ _ @ _).
        refine (1 @@ _).
        refine (1 @@ C_compose _ _ _ f g @ _).
        refine (transport_const_pp _ _ _ @@ 1 @ _).
        set (p := transport_pp (fun _ => C) (cell f) (cell g) (C_point x)).
        set (q := C_cell y z g).
        set (r := C_cell x y f).
        refine (_ @ ((1 @@ (ap_pp _ _ _)^) @@ 1)).
        set (s := ap (transport (fun _ => C) (cell g)) (transport_const (cell f) (C_point x))).
        refine (concat_pp_p _ _ _ @ (1 @@ _) @ concat_p_pp _ _ _).
        refine (concat_pp_p _ _ _ @ (1 @@ _) @ concat_p_pp _ _ _).
        refine (concat_p_pp _ _ _ @ (_ @@ 1) @ concat_pp_p _ _ _).
        apply transport_const_inv.
    Defined.

    Definition quotient1_rec : quotient1 R G -> C.
    Proof.
      apply quotient1_ind with (P_point := C_point) (P_cell := @C_cell'); intros.
      - exact C_1Type.
      - apply C_compose'.
     Defined.

    Lemma quotient1_rec_cell : forall {x y} (f : R x y),
        ap quotient1_rec (cell f) = C_cell _ _ f.
    Proof.
      intros.
      refine (apD_const' _ _ @ _).
      refine (1 @@ quotient1_ind_cell _ _ _ _ _ @ _).
      unfold C_cell'.
      refine (concat_p_pp _ _ _ @ _).
      refine (concat_Vp _ @@ 1 @ _).
      apply concat_1p.
    Qed.

    Let quotient1_rec_compose' : forall {x y z} (f : R x y) (g : R y z),
        ap quotient1_rec (cell (g o f)) = ap quotient1_rec (cell f @ cell g).
    Proof.
      intros.
      refine (_ @ (ap_pp _ _ _)^).
      refine ( quotient1_rec_cell (g o f)
             @ _
             @ ((quotient1_rec_cell f)^ @@ (quotient1_rec_cell g)^)).
      apply C_compose.
    Defined.

    Let quotient1_rec_compose'' : forall {x y z} (f : R x y) (g : R y z),
        apD quotient1_rec (cell (g o f))
      = transport2 (fun _ => C) (cell_compose f g) (quotient1_rec (point R G x))
      @ apD quotient1_rec (cell f @ cell g).
    Proof.
      intros.
      refine (quotient1_ind_cell _ _ _ _ (g o f) @ _).
      refine (C_compose' f g @ _).
      refine (1 @@ _).
      refine (1 @@ ap _ (quotient1_ind_cell _ _ _ _ f)^ @@ (quotient1_ind_cell _ _ _ _ g)^ @ _).
      refine (apD_pp _ _ _)^.
    Defined.

    Lemma quotient1_rec_compose : forall {x y z} (f : R x y) (g : R y z),
        apD02 quotient1_rec (cell_compose f g) = quotient1_rec_compose'' f g.
    Proof.
      intros.
      apply quotient1_ind_compose.
    Qed.

  End quotient1_rec.

  (* The recursion principle can be simplified when the property is a set *)
  Section quotient1_rec_set.

    Variable C : Type.
    Variable C_point : A -> C.
    Variable C_cell : forall {x y}, R x y -> C_point x = C_point y.
    Context {C_set : IsHSet C}.

    Definition quotient1_rec_set : quotient1 R G -> C.
    Proof.
      apply quotient1_rec with (C_point := C_point) (C_cell := C_cell);
      intros.
      - apply C_set.
      - apply trunc_succ.
    Defined.
  End quotient1_rec_set.

  (* The induction principle can be simplified when the property is a set *)
  Section quotient1_ind_set.

    Variable P : quotient1 R G -> Type.
    Context {P_set : forall a, IsHSet (P a)}.
    Variable P_point : forall x, P (point R G x).
    Variable P_cell : forall {x y} (f : R x y),
                      cell f # P_point x = P_point y.

    Definition quotient1_ind_set : forall (q : quotient1 R G), P q.
    Proof.
      apply quotient1_ind with (P_point := P_point) (P_cell := P_cell); intros.
      - apply trunc_succ.
      - apply P_set.
    Defined.
  End quotient1_ind_set.

  (** Inversion principles on paths and quotient types. *)
  Section quotient1_inv.

    Lemma concat_Vp_inversion : forall {A} {x y : A} (p : x = y) (q : y = x),
          p @ q = 1 ->
          p^ = q.
    Proof.
      intros B x y p q H.
      set (H' := moveR_Vp _ _ _ H^).
      rewrite concat_p1 in H'.
      exact H'.
    Qed.

    Lemma concat_V_idempotent : forall {A} {x : A} (p : x = x),
          p @ p^ = p -> p = 1.
    Proof.
      intros B x p H.
      refine (H^ @ _).
      apply concat_pV.
    Qed.

    Lemma concat_p_p : forall {A} {x : A} (p : x = x),
        p @ p = p -> p = 1.
    Proof.
      intros B x p H.
      apply concat_V_idempotent.
      refine ((H^ @@ 1) @ _).
      refine (concat_pp_p _ _ _ @ _).
      refine (1 @@ concat_pV _ @ _).
      apply concat_p1.
    Qed.

    Lemma quotient1_1 : forall x, cell 1 = (1 : point _ _ x = point _ _ x).
    Proof.
      intros x.
      apply concat_p_p.
      rewrite <- cell_compose.
      apply ap.
      apply (g_1_l G 1).
    Qed.

    Lemma quotient1_inv : forall x y (f : R x y),
                                     (cell f)^%path = cell (f^)%groupoid.
    Proof.
      intros x y f.
      apply concat_Vp_inversion.
      rewrite <- cell_compose.
      rewrite g_V_l; auto.
      apply quotient1_1.
    Qed.

  End quotient1_inv.

End Domain.

Arguments quotient1 {A} {R} (*{IsHSet}*) {R_HSet} {reflR transR symmR} G : rename.
Arguments point {A} {R} (*{IsHSet}*) {R_HSet} {reflR transR symmR} G : rename.
Arguments cell {A} {R} (*{IsHSet}*) {R_HSet} {reflR transR symmR} G {x y} : rename.
Arguments cell_compose {A} {R} (*{IsHSet}*) {R_HSet} {reflR transR symmR} G {x y z} : rename.
Arguments quotient1_ind {A R (*A_set*) R_HSet R_refl R_trans R_symm G} P {P_1Type}.
Arguments quotient1_rec {A R (*A_set*) R_HSet R_refl R_trans R_symm G}.
Arguments quotient1_ind_set {A R (*A_set*) R_HSet R_refl R_trans R_symm G} P {P_set}.
Arguments quotient1_rec_set {A R (*A_set*) R_HSet R_refl R_trans R_symm G}.

End Quotient1.

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

(* We establish several specialized inducition principles for pairs of
groupoids.*)
Section Quotient1_multi.
  Open Scope groupoid_scope.

  Variable A : Type.
  Variable R_A : A -> A -> Type.
  Context (*{A_set : IsHSet A} *)
          {R_A_HSet : forall x y, IsHSet (R_A x y)}
          {R_A_refl : Reflexive R_A}
          {R_A_trans : Transitive R_A}
          {R_A_symm : Symmetric R_A}.
  Variable G_A : groupoid A R_A.

  Variable B : Type.
  Variable R_B : B -> B -> Type.
  Context (*{B_set : IsHSet B} *)
          {R_B_HSet : forall x y, IsHSet (R_B x y)}
          {R_B_refl : Reflexive R_B}
          {R_B_trans : Transitive R_B}
          {R_B_symm : Symmetric R_B}.
  Variable G_B : groupoid B R_B.

  (* Induction over a pair of quotient types *)
  Section quotient1_ind2.
    Variable P : quotient1 G_A -> quotient1 G_B -> Type.
    Context {P_1Type : forall q r, IsTrunc 1 (P q r)}.
    Variable P_point : forall x y, P (point G_A x) (point G_B y).

    Let P_HSet : forall {x y} (pf1 pf2 : P x y), IsHSet (pf1 = pf2).
    Proof.
      intros x y pf1 pf2. do 2 intro. simpl.
      apply P_1Type.
    Qed.

    Variable P_cell_l : forall {x x' y} (f : R_A x x'),
                        transport (fun r => P r (point G_B y)) (cell G_A f) (P_point x y)
                      = P_point x' y.

    Variable P_cell_r : forall x {y y'} (f : R_B y y'),
                        transport (P (point G_A x)) (cell G_B f) (P_point x y)
                      = P_point x y'.

    Variable P_compose_l : forall {x1 x2 x3 y} (f : R_A x1 x2) (g : R_A x2 x3),
             P_cell_l x1 x3 y (g o f)
           = transport2 _ (cell_compose G_A f g) (P_point x1 y)
           @ (transport_pp _ _ _ _
           @ ap _ (P_cell_l _ _ y f)
           @ P_cell_l _ _ y g).

    Variable P_compose_r : forall {x y1 y2 y3} (f : R_B y1 y2) (g : R_B y2 y3),
             P_cell_r x _ _ (g o f)
           = transport2 _ (cell_compose G_B f g) (P_point x y1)
           @ (transport_pp _ _ _ _
           @ ap _ (P_cell_r x _ _ f)
           @ P_cell_r x _ _ g).

    Let P_point' (q : quotient1 G_A) : forall y, P q (point G_B y).
    Proof.
      intros y.
      generalize dependent q.
      set (Q := fun r => P r (point G_B y)).
      transparent assert (P_point0 : (forall x, P (point G_A x) (point G_B y))).
      { intros x. exact (P_point x y). }
      transparent assert (P_cell0 : (forall {x x'} (f : R_A x x'),
                 transport Q (cell _ f) (P_point0 x) = P_point0 x')).
      { intros x x' f. unfold Q, P_point0.
        apply P_cell_l.
      }
      apply quotient1_ind with (P_point1 := P_point0) (P_cell := P_cell0);
        unfold Q; auto.
      intros x1 x2 x3 f g.
      unfold P_cell0.
      apply P_compose_l.
    Defined.

    (* It might be possible to get rid of this hypothesis? *)
    Variable P_cell_r_eq : forall {x x' y y'} (f : R_A x x') (g : R_B y y'),
        transport (fun r => transport (P r) (cell _ g) (P_point' r y) = P_point' r y')
                  (cell _ f) (P_cell_r x y y' g)
      = P_cell_r x' y y' g.

    Let P_cell_r' q : forall {y y'} (g : R_B y y'),
                      transport (P q) (cell _ g) (P_point' q y)
                    = P_point' q y'.
    Proof.
      intros.
      generalize dependent q.
      set (Q := fun r => transport (P r) (cell _ g) (P_point' r y) = P_point' r y').
      transparent assert (Q_point : (forall x, Q (point G_A x))).
      { intros; unfold Q. simpl.
        apply P_cell_r.
      }
      apply quotient1_ind_set with (P_point0 := Q_point).
      - unfold Q. intros. apply P_HSet.
      - intros. apply P_cell_r_eq.
    Defined.

    Let P_cell' : forall (q : quotient1 G_A) {x' y'} (f : R_B x' y'),
                  cell _ f # P_point' q x' = P_point' q y'.
    Proof.
      intros.
      generalize dependent q.
      set (P0 := fun r => transport (P r) (cell _ f) (P_point' r x') = P_point' r y').
      transparent assert (P_point0 : (forall x, P0 (point _ x))).
      { intros x. apply P_cell_r. }
      apply quotient1_ind_set with (P_point1 := P_point0); intros; unfold P0; auto.
      unfold P_point0.
      apply P_cell_r_eq.
    Defined.

    Let Q {x y z} (f : R_B x y) (g : R_B y z) q :=
                    P_cell' q (g o f)
                   = transport2 (P q) (cell_compose _ f g) (P_point' q x)
                   @ ((transport_pp (P q) (cell _ f) (cell _ g) (P_point' q x)
                   @ ap (transport (P q) (cell _ g)) (P_cell' q f))
                   @ P_cell' q g).

    Let Q_point : forall {y1 y2 y3} (f : R_B y1 y2) (g : R_B y2 y3) x,
                  Q f g (point G_A x).
    Proof.
      intros; unfold Q.
      simpl.
      apply P_compose_r.
    Defined.

    Let P_compose' : forall {x y z} (f : R_B x y) (g : R_B y z) q,
                     Q f g q.
    Proof.
      intros.
      generalize dependent q.
      apply quotient1_ind_set with (P_point0 := Q_point f g); intros.
      - apply trunc_succ.
      - unfold Q_point.
        set (X := P_compose_r y0 x y z f g).
        set (H := P_HSet _ _ (P_cell_r y0 x z (g o f))).
        simpl in H.
        apply H.
    Defined.

    Definition quotient1_ind2 : forall q r, P q r.
    Proof.
      intros q.
      apply quotient1_ind with (P_point0 := P_point' q) (P_cell := @P_cell' q);
        intros; auto.
      apply P_compose'.
    Defined.
  End quotient1_ind2.

  (* Induction principle over a pair of quotient types whith a set-valued property *)
  Section quotient1_ind2_set.
    Variable P : quotient1 G_A -> quotient1 G_B -> Type.
    Context {P_set : forall q r, IsHSet (P q r)}.
    Variable P_point : forall x y, P (point G_A x) (point G_B y).

    Variable P_cell_l : forall {x x' y} (f : R_A x x'),
                        transport (fun r => P r (point G_B y)) (cell G_A f) (P_point x y)
                      = P_point x' y.

    Variable P_cell_r : forall x {y y'} (f : R_B y y'),
                        transport (P (point G_A x)) (cell G_B f) (P_point x y)
                      = P_point x y'.

    Let P_compose_l : forall {x1 x2 x3 y} (f : R_A x1 x2) (g : R_A x2 x3),
             P_cell_l x1 x3 y (g o f)
           = transport2 _ (cell_compose G_A f g) (P_point x1 y)
           @ (transport_pp _ _ _ _
           @ ap _ (P_cell_l _ _ y f)
           @ P_cell_l _ _ y g).
    Proof.
      intros.
      apply P_set.
    Qed.

    Let P_1Type : forall q r, IsTrunc 1 (P q r).
    Proof.  intros q r. exact _. Qed.

    Definition quotient1_ind2_set : forall q r, P q r.
    Proof.
      apply quotient1_ind2 with (P_1Type := P_1Type)
                                (P_point := P_point)
                                (P_cell_l := P_cell_l)
                                (P_cell_r := P_cell_r)
                                (P_compose_l := @P_compose_l).
      * intros. apply P_set.
      * intros. apply P_set.
    Defined.

  End quotient1_ind2_set.

  (* Quotients are functors *)
  Section quotient1_map.

    Variable f : A -> B.
    (* Want: quotient f G_A G_B : (A/G_A) (B/G_B) *)

    Variable map_cell : forall {x y}, R_A x y -> R_B (f x) (f y).
    Variable map_1 : forall x, map_cell x x 1 = 1.
    Variable map_compose : forall {x y z} (f : R_A x y) (g : R_A y z),
             map_cell x z (g o f) = map_cell _ _ g o map_cell _ _ f.

    Definition quotient1_map : quotient1 G_A -> quotient1 G_B.
    Proof.
      apply quotient1_rec
        with (C_point := fun a => point G_B (f a))
             (C_cell := fun x y pf => cell G_B (map_cell _ _ pf)).
      * intros.
        simpl.
        fold (g o f0).
        refine (ap (cell G_B) (map_compose _ _ _ _ _) @ cell_compose _ _ _).
      * apply quotient1_trunc.
    Defined.

    Lemma quotient1_map_point : forall a,
          quotient1_map (point G_A a) = point G_B (f a).
    Proof.
      intros a. reflexivity.
    Qed.

  End quotient1_map.

  Instance R_pair_HSet {A1 A2} (R_A1 : A1 -> A1 -> Type) (R_A2 : A2 -> A2 -> Type)
                            `{forall x y, IsHSet (R_A1 x y)}
                            `{forall x y, IsHSet (R_A2 x y)}
           : forall x y, IsHSet (R_pair R_A1 R_A2 x y).
  Proof.
    intros [a b] [a' b'].
    unfold R_pair.
    apply trunc_prod; auto.
  Qed.

  (* Map a pair of quotient types to a quotient of the pair of the underlying
  groupoids *)
  Section quotient1_curry.

    Let C_point_a_b (a : A) (b : B) : quotient1 (g_pair G_A G_B) :=
      point (g_pair G_A G_B) (a,b).
    Let C_cell_a (b : B) : forall a a', R_A a a' ->
          point (g_pair G_A G_B) (a,b) = point (g_pair G_A G_B) (a',b).
    Proof.
      intros a a' f.
      apply cell.
      split; [exact f | exact 1].
    Defined.

    Let C_compose_a b : forall x y z (f : R_A x y) (g : R_A y z),
        C_cell_a b x z (g o f) = C_cell_a b x y f @ C_cell_a b y z g.
    Proof.
      intros x y z f g.
      unfold C_cell_a.
      set (k := (g o f, 1) : R_pair R_A R_B (x,b) (z,b)).
      set (k2 := (g,1) : R_pair R_A R_B (y,b) (z,b)).
      set (k1 := (f,1) : R_pair R_A R_B (x,b) (y,b)).
      assert (pf : k = k2 o k1).
      { unfold k, k1, k2.
        simpl.
        unfold R_trans.
        fold (1 : R_B b b).
        fold (1 o 1 : R_B b b).
        rewrite (g_1_l G_B).
        reflexivity.
      }
      rewrite pf.
      apply cell_compose.
    Qed.

    Let C_point_b : quotient1 G_A -> B -> quotient1 (g_pair G_A G_B).
    Proof.
      intros q_a b.
      generalize dependent q_a.
      apply quotient1_rec
        with (C_point := fun a => point (g_pair G_A G_B) (a,b))
             (C_cell := C_cell_a b);
        [ | apply quotient1_trunc].
      apply (C_compose_a b).
    Defined.

    Let P0 {b1 b2} (f : R_B b1 b2) (q_a : quotient1 G_A) : Type :=
                                   C_point_b q_a b1 = C_point_b q_a b2.
    Let P_point0 {b1 b2} (f : R_B b1 b2) : forall a, P0 f (point G_A a).
    Proof.
      intros.
      unfold P0. simpl.
      apply cell.
      split; [exact 1 | exact f].
    Defined.

    Lemma transport_path : forall {A B} (P0 P1 : A -> B) {a b} (p : a = b)
                                  (p' : P0 a = P1 a),
      transport (fun x => P0 x = P1 x) p p' = ap P0 p^ @ p' @ ap P1 p.
    Proof.
      destruct p. intros. simpl.
      refine ((concat_1p _)^ @ (concat_p1 _)^).
    Defined.

    Let P_cell0 {b b'} (g : R_B b b') : forall a a' (f : R_A a a'),
        transport (P0 g) (cell _ f) (P_point0 g a) = (P_point0 g a').
    Proof.
      intros a a' f.
      unfold P0.
      set (Q0 := fun q_a => C_point_b q_a b).
      set (Q1 := fun q_a => C_point_b q_a b').
      rewrite (transport_path Q0 Q1).
      rewrite ap_V.

      unfold Q0.
      rewrite quotient1_rec_cell.
      unfold Q1.
      rewrite quotient1_rec_cell.
      unfold C_cell_a, P_point0.
      rewrite quotient1_inv.
      repeat rewrite <- cell_compose.
      apply ap.

      Opaque transitivity reflexivity symmetry.
      rewrite g_pair_sym.
      repeat rewrite g_pair_trans.
      simpl.
      repeat rewrite (g_1_l G_B).
      repeat rewrite (g_1_l G_A).
      rewrite (g_V_r G_A).
      rewrite (g_1_v _ _ G_B).
      rewrite (g_1_r G_B).
      Transparent transitivity reflexivity symmetry.
      reflexivity.
    Defined.

    Let C_cell_curry q_a : forall y y', R_B y y' ->
        C_point_b q_a y = C_point_b q_a y'.
    Proof.
      intros y y' g.
      generalize dependent q_a.
      apply quotient1_ind with (P := P0 g)
                               (P_point := P_point0 g)
                               (P_cell := P_cell0 g).
      * intros q_a. unfold P0.
        apply trunc_succ.
      * intros. apply quotient1_trunc.
    Defined.

    Let C_compose_curry q_a : forall x y z (f : R_B x y) (g : R_B y z),
        C_cell_curry q_a x z (g o f)
      = C_cell_curry q_a x y f @ C_cell_curry q_a y z g.
    Proof.
      intros.
      generalize dependent q_a.

      set (P1 q_a :=
        C_cell_curry q_a x z (g o f)
      = C_cell_curry q_a x y f @ C_cell_curry q_a y z g).

      assert (P_point1 : forall a, P1 (point _ a)).
      { intros. unfold P1. simpl.
        fold (g o f).
        unfold P_point0.
        refine (_ @ cell_compose _ _ _).
        apply ap.
        simpl. unfold R_trans.
        fold (g o f).
        apply (ap (fun h => (h,g o f))).
        fold (1 : R_A a a). fold ((1 : R_A a a) o 1).
        apply (g_1_l G_A _)^.
      }

      apply quotient1_ind_set with (P := P1)
                                   (P_point := P_point1).
      * intros q_a. apply trunc_succ.
      * intros. apply quotient1_trunc.
    Defined.

    Definition quotient1_curry
             : quotient1 G_A -> quotient1 G_B -> quotient1 (g_pair G_A G_B).
    Proof.
      intros q_a.
      apply quotient1_rec
        with (C_point := C_point_b q_a)
             (C_cell := C_cell_curry q_a);
      [ apply C_compose_curry | apply quotient1_trunc].
    Defined.

    Lemma quotient1_curry_point : forall a b,
      quotient1_curry (point G_A a) (point G_B b) = C_point_a_b a b.
    Proof.
      intros. reflexivity.
    Qed.

    Lemma ap2_ap_ap : forall {A B C} (P : A -> B -> C)
                             {a a' : A} {b b' : B} (p : a = a') (q : b = b'),
      ap2 P p q = ap (fun x => P x b) p @ ap (fun y => P a' y) q.
    Proof.
      destruct p; destruct q; reflexivity.
    Qed.
    Lemma ap2_sym : forall {A B C} (P : A -> B -> C)
                           {a a' : A} {b b' : B} (p : a = a') (q : b = b'),
      ap2 P p q = ap2 (fun y x => P x y) q p.
    Proof.
      destruct p; destruct q; reflexivity.
    Qed.

    Lemma quotient1_curry_cell : forall a a' b b' (f : R_A a a') (g : R_B b b'),
      ap2 quotient1_curry (cell G_A f) (cell G_B g)
    = cell (g_pair G_A G_B) ((f,g) : R_pair R_A R_B (a,b) (a',b')).
    Proof.
      intros.
      unfold quotient1_curry.
      rewrite ap2_ap_ap.
      rewrite quotient1_rec_cell. simpl.
      unfold C_point_b.
      rewrite quotient1_rec_cell.
      unfold C_cell_a, P_point0.
      rewrite <- cell_compose.
      apply ap.
      rewrite g_pair_trans.
      rewrite (g_1_l G_A).
      rewrite (g_1_r G_B).
      reflexivity.
    Qed.

  End quotient1_curry.

  (* A recursion principle over a pair of groupoid quotients, which
  significantly simplifies the assumptions of the corresponding induction
  principle. *)
  Section quotient1_rec2.

    Variable C : Type.
    Context {C_1Type : IsTrunc 1 C}.
    Variable C_point : A -> B -> C.
    Variable C_cell : forall {x x' y y'} (f : R_A x x') (g : R_B y y'),
             C_point x y = C_point x' y'.

    Variable C_compose : forall {x1 x2 x3 y1 y2 y3}
                                (f1 : R_A x1 x2) (f2 : R_A x2 x3)
                                (g1 : R_B y1 y2) (g2 : R_B y2 y3),
             C_cell _ _ _ _ (f2 o f1) (g2 o g1)
           = C_cell _ _ _ _ f1 g1 @ C_cell _ _ _ _ f2 g2.

    Let C_HSet : forall (pf1 pf2 : C), IsHSet (pf1 = pf2).
    Proof.
      intros.
      intros x y. simpl.
      apply C_1Type.
    Qed.

    Let C_point' (z : A * B) : C :=
      let (a,b) := z in C_point a b.
    Let C_cell' (z z' : A*B) : R_pair R_A R_B z z' -> C_point' z = C_point' z'.
    Proof.
      destruct z as [a b], z' as [a' b'].
      intros [pf_a pf_b]; simpl in *.
      unfold C_point'.
      apply (C_cell _ _ _ _ pf_a pf_b).
    Defined.

    Let quotient1_rec2_curry : quotient1 (g_pair G_A G_B) -> C.
    Proof.
      apply quotient1_rec
        with (C_point0 := C_point')
             (C_cell0 := C_cell'); auto.
      intros [a1 b1] [a2 b2] [a3 b3] [a12 b12] [a13 b13].
      unfold C_cell'. simpl.
      fold (a13 o a12).
      fold (b13 o b12).
      apply C_compose.
    Defined.

    Lemma ap2_curry : forall {A1 A2 C} (P : A1 -> A2 -> C) {x1 y1 : A1} {x2 y2 : A2}
                            (p1 : x1 = y1) (p2 : x2 = y2),
        ap2 P p1 p2
      = ap (fun (z : A1 * A2) => let (z1,z2) := z in P z1 z2) (ap2 pair p1 p2).
    Proof.
      destruct p1, p2.
      reflexivity.
    Qed.

    Definition quotient1_rec2 : quotient1 G_A -> quotient1 G_B -> C.
    Proof.
      intros a b.
      apply quotient1_rec2_curry.
      apply (quotient1_curry a b).
    Defined.

    Lemma quotient1_rec2_point : forall a b,
        quotient1_rec2 (point G_A a) (point G_B b) = C_point a b.
    Proof.
      intros. reflexivity.
    Qed.

    Lemma quotient1_rec2_cell : forall a a' b b' (f : R_A a a') (g : R_B b b'),
      ap2 quotient1_rec2 (cell G_A f) (cell G_B g)
    = C_cell _ _ _ _ f g.
    Proof.
      intros.
      rewrite ap2_curry.
      unfold quotient1_rec2.
      rewrite ap_compose.

      rewrite <- ap2_curry.
      rewrite quotient1_curry_cell.

      unfold quotient1_rec2_curry.
      rewrite quotient1_rec_cell.

      unfold C_cell'.
      reflexivity.
    Qed.

  End quotient1_rec2.

  (* A map of type A -> B -> C can be lifted to a map of type
     quotient1 A -> quotient1 B -> quotient1 C *)
  Section quotient1_map2.

    Variable C : Type.
    Variable R_C : C -> C -> Type.
    Context (*{C_set : IsHSet C} *)
            {R_C_HSet : forall x y, IsHSet (R_C x y)}
            {R_C_refl : Reflexive R_C}
            {R_C_trans : Transitive R_C}
            {R_C_symm : Symmetric R_C}.
    Variable G_C : groupoid C R_C.

    Variable f : A -> B -> C.
    (* Want: quotient G_A G_B G_C f : A/G_A -> B/G_B -> C/G_C *)
    Variable map_cell : forall {a a' b b'},
             R_A a a' -> R_B b b' -> R_C (f a b) (f a' b').

    Variable map_compose : forall {a1 a2 a3 b1 b2 b3}
                                  (a12 : R_A a1 a2) (a23 : R_A a2 a3)
                                  (b12 : R_B b1 b2) (b23 : R_B b2 b3),
        map_cell _ _ _ _ (a23 o a12) (b23 o b12)
     = (map_cell _ _ _ _ a23 b23) o (map_cell _ _ _ _ a12 b12).

    Let C_point0 := fun a b => point G_C (f a b).
    Let C_cell0 : forall x x' y y', R_A x x' -> R_B y y' ->
                  point G_C (f x y) = point G_C (f x' y').
    Proof.
      intros. apply cell. apply map_cell; auto.
    Defined.

    Let C_compose0 : forall (x1 x2 x3 : A) (y1 y2 y3 : B) (f1 : R_A x1 x2)
                            (f2 : R_A x2 x3) (g1 : R_B y1 y2) (g2 : R_B y2 y3),
        C_cell0 x1 x3 y1 y3 (f2 o f1) (g2 o g1) =
        C_cell0 x1 x2 y1 y2 f1 g1 @ C_cell0 x2 x3 y2 y3 f2 g2.
    Proof.
      intros.
      unfold C_cell0.
      refine (ap (cell G_C) _ @ cell_compose _ _ _).
      apply map_compose.
    Defined.

    Definition quotient1_map2 : quotient1 G_A -> quotient1 G_B -> quotient1 G_C.
    Proof.
      apply quotient1_rec2 with (C_point := C_point0)
                                (C_cell := C_cell0);
        [ apply quotient1_trunc | apply C_compose0 ].
    Defined.

    Lemma quotient1_map2_point : forall a b,
        quotient1_map2 (point G_A a) (point G_B b) = point G_C (f a b).
    Proof.
      intros.
      reflexivity.
    Qed.

    Lemma quotient1_map2_cell : forall a a' b b' (f : R_A a a') (g : R_B b b'),
      ap2 quotient1_map2 (cell G_A f) (cell G_B g)
    = cell G_C (map_cell _ _ _ _ f g).
    Proof.
      intros.
      unfold quotient1_map2.
      apply quotient1_rec2_cell.
    Qed.

  End quotient1_map2.

End Quotient1_multi.


Require Export Metalib.Metatheory.

(** Syntax **)

Inductive typ : Set :=
  | t_int : typ
  | t_arrow : typ -> typ -> typ
  | t_bvar  : nat -> typ
  | t_fvar  : var -> typ
  | t_all   : typ -> typ
  | t_ref   : typ -> typ
  | t_unit  : typ
.

Inductive exp : Set :=
  | e_bvar   : nat -> exp
  | e_fvar   : var -> exp
  | e_lit    : nat -> exp
  | e_unit   : exp
  | e_anno   : exp -> typ -> exp
  | e_app    : exp -> exp -> exp
  | e_abs    : typ -> exp  -> exp
  | e_tabs   : exp -> exp
  | e_tapp   : exp -> typ -> exp
  | e_loc    : nat -> exp
  | e_ref    : exp -> exp
  | e_get    : exp -> exp
  | e_set    : exp -> exp -> exp
.

Coercion t_bvar : nat >-> typ.
Coercion t_fvar : atom >-> typ.
Coercion e_bvar : nat >-> exp.
Coercion e_fvar : atom >-> exp.

Inductive dirflag : Set :=  (*r checking direction *)
 | Inf : dirflag
 | Chk : dirflag.

(** Opening up a type binder occuring in a type *)

Fixpoint open_tt_rec (K : nat) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | t_int         => t_int
  | t_bvar J      => if K == J then U else (t_bvar J)
  | t_fvar X      => t_fvar X
  | t_arrow T1 T2 => t_arrow (open_tt_rec K U T1) (open_tt_rec K U T2)
  | t_all T       => t_all (open_tt_rec (S K) U T)
  | t_ref T1      => t_ref (open_tt_rec K U T1)
  | t_unit        => t_unit
  end.

Fixpoint open_te_rec (k : nat) (f : typ) (e : exp) {struct e} : exp :=
  match e with
  | e_bvar i       => e_bvar i
  | e_fvar x       => e_fvar x
  | e_lit i        => e_lit i
  | e_unit        => e_unit
  | e_loc x      => e_loc x
  | e_app e1 e2    => e_app (open_te_rec k f e1) (open_te_rec k f e2)
  | e_abs A e1   => e_abs (open_tt_rec k f A) (open_te_rec k f e1)
  | e_anno e1 A    => e_anno (open_te_rec k f e1) (open_tt_rec k f A)
  | e_tabs e1     => e_tabs (open_te_rec (S k) f e1)
  | e_tapp e1 A     => e_tapp (open_te_rec k f e1) (open_tt_rec k f A)
  | e_ref e1     => e_ref (open_te_rec k f e1)
  | e_get e1     => e_get (open_te_rec k f e1)
  | e_set e1 e2     => e_set (open_te_rec k f e1) (open_te_rec k f e2)
  end.

(** Opening up a expr binder occuring in a expr *)

Fixpoint open_ee_rec (k : nat) (f : exp) (e : exp) {struct e} : exp :=
  match e with
  | e_bvar i       => if k == i then f else (e_bvar i)
  | e_fvar x       => e_fvar x
  | e_loc x      => e_loc x
  | e_lit i        => e_lit i
  | e_unit        => e_unit
  | e_app e1 e2    => e_app (open_ee_rec k f e1) (open_ee_rec k f e2)
  | e_abs A e1   => e_abs A (open_ee_rec (S k) f e1)
  | e_anno e1 A    => e_anno (open_ee_rec k f e1) A
  | e_tabs e1     => e_tabs (open_ee_rec k f e1)
  | e_tapp e1 A     => e_tapp (open_ee_rec k f e1) A
  | e_ref e1     => e_ref (open_ee_rec k f e1)
  | e_get e1     => e_get (open_ee_rec k f e1)
  | e_set e1 e2     => e_set (open_ee_rec k f e1) (open_ee_rec k f e2)
  end.

Definition open_tt T U := open_tt_rec 0 U T.
Definition open_te e T := open_te_rec 0 T e.
Definition open_ee e1 e2 := open_ee_rec 0 e2 e1.

(** Notation for opening up binders with type or expr variables *)

Notation "T 'open_tt_var' X" := (open_tt T (t_fvar X)) (at level 67).

Notation "t 'open_ee_var' x" := (open_ee t (e_fvar x)) (at level 67).

Notation "t 'open_te_var' a" := (open_te t (t_fvar a)) (at level 67).

(** Types as locally closed pre-types *)

Inductive type : typ -> Prop :=
  | type_lit :
      type t_int
  | type_unit :
      type t_unit
  | type_var : forall X,
      type (t_fvar X)
  | type_arrow : forall T1 T2,
      type T1 ->
      type T2 ->
      type (t_arrow T1 T2)
  | type_all : forall L T2,
      (forall X, X \notin L -> type (T2 open_tt_var X)) ->
      type (t_all T2)
  | type_ref : forall T,
      type T ->
      type (t_ref T)
.

(** exprs as locally closed pre-exprs *)

Inductive expr : exp -> Prop :=
  | expr_var : forall x,
      expr (e_fvar x)
  | expr_nat : forall i,
      expr (e_lit i)
  | expr_unit :
      expr e_unit
  | expr_abs : forall L e1 A,
      type A ->
      (forall x, x \notin L -> expr (e1 open_ee_var x)) ->
      expr (e_abs A e1)
  | expr_app : forall e1 e2,
      expr e1 ->
      expr e2 ->
      expr (e_app e1 e2)
  | expr_tabs : forall L e,
      (forall x, x \notin L -> expr (e open_te_var x)) ->
      expr (e_tabs e)
  | expr_tapp : forall e A,
      expr e ->
      type A ->
      expr (e_tapp e A)
  | expr_anno : forall e A,
      expr e ->
      type A ->
      expr (e_anno e A)
  | expr_loc : forall l,
      expr (e_loc l)
  | expr_ref : forall e,
      expr e ->
      expr (e_ref e)
  | expr_get : forall e,
      expr e ->
      expr (e_get e)
  | expr_set : forall e1 e2,
      expr e1 ->
      expr e2 ->
      expr (e_set e1 e2)
.

(** Environment is an associative list of bindings. *)

Inductive binding : Set :=
  | bind_tvar : binding
  | bind_typ : typ -> binding
.

Notation env := (list (atom * binding)).
Notation empty := (@nil (atom * binding)).

Definition sto := list exp.
Definition phi := list typ.

Notation "x ~tvar" := (x ~ bind_tvar)
  (at level 23, left associativity) : env_scope.
Notation "x ~: T" := (x ~ bind_typ T)
  (at level 23, left associativity) : env_scope.

(** A type T is well formed under environment E *)

Inductive wf_typ : env -> typ -> Prop :=
  | wf_typ_int : forall E,
      wf_typ E t_int
  | wf_typ_unit : forall E,
      wf_typ E t_unit
  | wf_typ_var : forall E x,
      binds x bind_tvar E ->
      wf_typ E (t_fvar x)
  | wf_typ_arrow : forall E A1 A2,
      wf_typ E A1 ->
      wf_typ E A2 ->
      wf_typ E (t_arrow A1 A2)
  | wf_typ_all : forall L E A,
      (forall X, X \notin L ->
            wf_typ (X ~tvar ++ E) (A open_tt_var X)) ->
      wf_typ E (t_all A)
  | wf_typ_ref : forall E A,
      wf_typ E A ->
      wf_typ E (t_ref A)
.

(** A environment E is well-formed if it contains no duplicate bindings and well-foremd types *)

Inductive wf_env : env -> Prop :=
  | wf_env_empty :
      wf_env empty
  | wf_env_tvar : forall E x,
      wf_env E ->
      x `notin` dom E ->
      wf_env (x ~tvar ++ E)
  | wf_env_typ : forall E x A,
      wf_env E ->
      wf_typ E A ->
      x `notin` dom E ->
      wf_env (x ~: A ++ E)
.

(** eqent *)

Inductive eq: env -> typ -> typ -> Prop :=
  | eq_int : forall E,
      wf_env E ->
      eq E t_int t_int
  | eq_unit : forall E,
      wf_env E ->
      eq E t_unit t_unit
  | eq_var : forall E x,
      wf_env E ->
      wf_typ E (t_fvar x) ->
      eq E (t_fvar x) (t_fvar x)
  | eq_fun : forall E A1 A2 B1 B2,
      eq E B1 A1 ->
      eq E A2 B2 ->
      eq E (t_arrow A1 A2) (t_arrow B1 B2)
  | eq_all: forall L E A B ,
      (forall x, x \notin L ->
      eq (x ~tvar ++ E) (A open_tt_var x) (B open_tt_var x)) ->
      eq E (t_all A) (t_all B)
  | eq_ref : forall E A B,
      eq E A B ->
      eq E (t_ref A) (t_ref B)
.

Definition store_Tlookup (n:nat) (ST: phi) :=
  nth n ST t_unit.

(** Typing *)

Inductive typing : env -> phi -> exp -> dirflag -> typ -> Prop :=
| typ_var : forall E P x T,
    wf_env E ->
    binds x (bind_typ T) E ->
    typing E P (e_fvar x) Inf T
| typ_nat : forall E P i,
    wf_env E ->
    typing E P (e_lit i) Inf (t_int)
| typ_unit : forall E P,
    wf_env E ->
    typing E P e_unit Inf t_unit
| typ_loc : forall E P l,
    wf_env E ->
    l < length P ->
    wf_typ E (store_Tlookup l P) ->
    typing E P (e_loc l) Inf (t_ref (store_Tlookup l P))
| typ_app : forall E P e1 e2 A B,
    typing E P e1 Inf (t_arrow A B) ->
    typing E P e2 Chk A ->
    typing E P (e_app e1 e2) Inf B
| typ_abs : forall L E P A B e,
    (forall x, x \notin L ->
            typing (x ~: A ++ E) P (e open_ee_var x) Inf B) ->
    typing E P (e_abs A e) Inf (t_arrow A B)
| typ_anno : forall E P e A,
    typing E P e Chk A ->
    typing E P (e_anno e A) Inf A
| typ_tabs : forall E P e A L,
    ( forall a , a \notin  L  ->
    typing  ( a ~tvar ++ E) P ( e open_te_var a )  Inf  ( A open_tt_var a )  )  ->
    typing E P (e_tabs e) Inf (t_all A)
| typ_tapp : forall E P e A B,
    wf_typ E A ->
    typing E P e Inf (t_all B) ->
    typing E P (e_tapp e A) Inf  (open_tt B A )
| typ_eq : forall E P e A,
    typing E P e Inf A ->
    typing E P e Chk A
| typ_ref : forall E P e A,
    typing E P e Inf A ->
    typing E P (e_ref e) Inf (t_ref A)
| typ_get : forall E P e A1,
    typing E P e Inf (t_ref A1) ->
    typing E P (e_get e) Inf A1
| typ_set : forall E P e1 e2 A1,
    typing E P e1 Inf (t_ref A1) ->
    typing E P e2 Chk A1->
    typing E P (e_set e1 e2) Inf t_unit
.

Inductive atyping : env -> phi -> exp -> typ -> Prop :=
| atyp_var : forall E P x T,
    wf_env E ->
    binds x (bind_typ T) E ->
    atyping E P (e_fvar x) T
| atyp_nat : forall E P i,
    wf_env E ->
    atyping E P (e_lit i) (t_int)
| atyp_unit : forall E P,
    wf_env E ->
    atyping E P e_unit t_unit
| atyp_loc : forall E P l,
    wf_env E ->
    l < length P ->
    wf_typ E (store_Tlookup l P) ->
    atyping E P (e_loc l) (t_ref (store_Tlookup l P))
| atyp_app : forall E P e1 e2 A B,
    atyping E P e1 (t_arrow A B) ->
    atyping E P e2 A ->
    atyping E P (e_app e1 e2) B
| atyp_abs : forall L E P A B e,
    (forall x, x \notin L ->
            atyping (x ~: A ++ E) P (e open_ee_var x) B) ->
    atyping E P (e_abs A e) (t_arrow A B)
| atyp_anno : forall E P e A,
    atyping E P e A ->
    atyping E P (e_anno e A) A
| atyp_tabs : forall E P e A L,
    ( forall a , a \notin  L  ->
    atyping  ( a ~tvar ++ E) P ( e open_te_var a )   ( A open_tt_var a )  )  ->
    atyping E P (e_tabs e) (t_all A)
| atyp_tapp : forall E P e A B,
    wf_typ E A ->
    atyping E P e (t_all B) ->
    atyping E P (e_tapp e A)  (open_tt B A )
| atyp_ref : forall E P e A,
    atyping E P e A ->
    atyping E P (e_ref e) (t_ref A)
| atyp_get : forall E P e A1,
    atyping E P e (t_ref A1) ->
    atyping E P (e_get e) A1
| atyp_set : forall E P e1 e2 A1,
    atyping E P e1 (t_ref A1) ->
    atyping E P e2 A1->
    atyping E P (e_set e1 e2) t_unit
.

(* defns FLikes *)
Inductive FL : typ -> Prop :=    (* defn FL *)
 | fl_abs : forall A B,
   FL (t_arrow A B).

Fixpoint principle_type (e : exp) : typ :=
match e with
| (e_anno e A) => A
| _ => t_unit
end.

Definition store_lookup (n:nat) (st:sto) :=
  nth n st e_unit.

Inductive pvalue : exp -> Prop :=    (* defn ptype *)
| pv_unit :
    pvalue e_unit
| pv_int : forall (i5:nat),
    pvalue (e_lit i5)
| pv_arr : forall (A:typ) (e:exp),
    expr (e_abs A e) ->
    pvalue (e_abs A e)
| pv_all : forall (e:exp),
    expr (e_tabs e) ->
    pvalue  (e_tabs e)
| pv_loc : forall l,
    pvalue  (e_loc l).

Inductive value : exp -> Prop :=    (* defn value *)
| v_anno : forall u,
    pvalue u ->
    value u.

Inductive sto_ok : sto -> Prop :=
  | sto_ok_empty : sto_ok nil
  | sto_ok_push : forall mu t,
      sto_ok mu -> value t ->
      sto_ok (t :: mu).

Definition sto_typing P mu :=
     sto_ok mu /\
     length P = length mu /\
     (forall l, l < length mu ->
      typing empty P (store_lookup l mu) Inf (store_Tlookup l P)).

Notation "P |== mu" := (sto_typing P mu) (at level 68).

(* defns Principal *)
Inductive ptype : sto -> exp -> typ -> Prop :=    (* defn ptype *)
| pt_int : forall mu (i5:nat),
    ptype mu (e_lit i5) t_int
| pt_unit : forall mu,
    ptype mu e_unit t_unit
| pt_arr : forall mu (A:typ) (e:exp) (B:typ),
    expr (e_abs A e) ->
    ptype mu ( (e_abs A e ) )  (t_arrow A B)
| pt_loc : forall l A mu,
    principle_type (store_lookup l mu) = A ->
    ptype mu (e_loc l) (t_ref A)
| pt_anno : forall (u:exp) (A:typ) mu,
    expr u ->
    ptype mu (e_anno u A) A
| pt_all : forall mu (e:exp) (A:typ),
    expr (e_tabs e) ->
    ptype mu (e_tabs e)  (t_all A).

Inductive svalue : exp -> Prop :=
| sv_arr : forall (A:typ) (e:exp) ,
    expr (e_abs A e) ->
    svalue (e_abs A e)
.

Inductive ssvalue : exp -> Prop :=    (* defn ssvalue *)
| sv_int : forall (i5:nat),
    ssvalue (e_lit i5)
| sv_all : forall (e:exp),
    expr (e_tabs e) ->
    ssvalue  (e_tabs e)
| sv_loc : forall l,
    ssvalue  (e_loc l)
| sv_unit :
    ssvalue  (e_unit)
.

Inductive res : Set :=
 | r_e (e:exp)
 | r_blame.

Definition conf := (exp * sto)%type.
Definition confr := (res * sto)%type.

(* defns TypedReduces *)
Inductive TypedReduce : conf -> typ -> confr -> Prop :=    (* defn TypedReduce *)
 | TReduce_sim : forall mu u A B C,
     pvalue u ->
     ptype mu u C ->
     eq  nil  C B ->
     TypedReduce ((e_anno u A),mu) B ((r_e (e_anno u B)),mu)
 | TReduce_nsim : forall (u:exp) (A B:typ) (C:typ) mu,
      pvalue u ->
     ptype mu u C ->
      not (  eq  nil  C B  )  ->
     TypedReduce ((e_anno u A),mu) B (r_blame,mu)
.

Definition ltyp : Set := list typ.

(* defns MultiTypedReduces *)
Inductive TypeLists : conf -> ltyp -> confr -> Prop :=    (* defn TypeLists *)
 | TLists_nil : forall v mu,
     TypeLists (v,mu)  nil ((r_e v),mu)
 | TLists_baseb : forall (v:exp) (AA:ltyp) (A:typ) mu,
     TypedReduce (v,mu) A (r_blame,mu) ->
     TypeLists (v,mu)  (cons  A   AA ) (r_blame,mu)
 | TLists_cons : forall (v:exp) (AA:ltyp) (A:typ) (v':exp) r mu,
     TypedReduce (v,mu) A ((r_e v'),mu) ->
     TypeLists (v',mu) AA (r,mu) ->
     TypeLists (v,mu)  (cons A AA ) (r,mu)
.

Inductive ctx_item : Type :=
  | appCtxL : exp -> ctx_item
  | appCtxR : exp -> ctx_item
  | tappCtx : typ -> ctx_item
  | refCtx :  ctx_item
  | getCtx : ctx_item
  | setCtxL : exp -> ctx_item
  | setCtxR : exp -> ctx_item
  | annoCtx : typ -> ctx_item
.

Inductive wellformed : ctx_item -> Prop :=
     | wf_appCtxL : forall (e : exp),
                    expr e ->
                    wellformed (appCtxL e)
     | wf_appCtxR : forall (v : exp),
                    value v ->
                    wellformed (appCtxR v)
     | wf_tappCtx : forall A,
                    type A ->
                    wellformed (tappCtx A)
     | wf_setCtxL : forall e,
                    expr e ->
                    wellformed (setCtxL e)
     | wf_setCtxR : forall e,
                    value e ->
                    wellformed (setCtxR e)
     | wf_refCtx :
                    wellformed refCtx
     | wf_getCtx :
                    wellformed getCtx
    | wf_annoCtx : forall A,
                    type A ->
                    wellformed (annoCtx A)
.

Definition fill (E : ctx_item) (e : exp) : exp :=
     match E with
     | appCtxL e2 => e_app e e2
     | appCtxR v1 => e_app v1 e
     | tappCtx A => e_tapp e A
     | setCtxL e2 => e_set e e2
     | setCtxR v1 => e_set v1 e
     | refCtx => e_ref e
     | getCtx => e_get e
     | annoCtx A => e_anno e A
     end.

Fixpoint replace {A:Type} (n:nat) (x:A) (l:list A) : list A :=
  match l with
  | nil => nil
  | h :: t =>
    match n with
    | O => x :: t
    | S n' => h :: replace n' x t
    end
  end.

(* defns Reduces *)

Inductive step : conf -> conf -> Prop :=    (* defn step *)
 | step_eval : forall mu mu' F e1 e2,
     wellformed F ->
     step (e1, mu) ((e2), mu') ->
     step ((fill F e1), mu) (( (fill F e2)), mu')
  | step_beta : forall (A1:typ) (e:exp)  u mu,
     sto_ok mu ->
     value u ->
     expr (e_abs A1 e ) ->
     step ((e_app  (e_abs A1 e ) u), mu) ((open_ee  e u ), mu)
 | step_annov : forall u A1 mu,
     sto_ok mu ->
     value u ->
     step ((e_anno u A1), mu) (u, mu)
 | step_tap : forall (e:exp) (C:typ) mu,
     expr (e_tabs e) ->
     step ((e_tapp (e_tabs e) C),mu) ((open_te e C ),mu)
 | step_set : forall l mu u,
     sto_ok mu ->
     value u ->
     step (e_set (e_loc l) u , mu) ((e_unit), (replace l u mu))
 | step_new : forall (v:exp) mu,
     sto_ok mu ->
     value v ->
     step ((e_ref v), mu) (( (e_loc (length mu))), (mu ++ v::nil))
 | step_get : forall l mu,
     sto_ok mu ->
     step ((e_get (e_loc l)), mu) ((store_lookup l mu), mu)
.

Inductive extends : phi -> phi -> Prop :=
  | extends_nil : forall ST',
      extends ST' nil
  | extends_cons : forall x ST' ST,
      extends ST' ST ->
      extends (x::ST') (x::ST).

Hint Constructors  atyping type expr eq wf_typ wf_env typing
FL ptype pvalue value ssvalue svalue TypedReduce TypeLists
wellformed step sto_ok extends : core.


Require Import Arith.

Inductive Loc : Set :=
| LLoc : nat -> Loc
.

Inductive SemTagType : Set :=
| SC : SemTagType
| SF : SemTagType
| SP : nat -> SemTagType
.

Definition SemTagTypeEq (t1 t2:SemTagType) : bool :=
  match t1, t2 with
  | SC, SC     => true
  | SF, SF     => true
  | SP n, SP m => beq_nat n m
  | _, _       => false
  end.

Inductive SemName : Set :=
| SName : nat -> SemName
.

Definition SemNameEq (n m:SemName) : bool :=
  match n with
  | SName n     =>
    match m with
    | SName m   => beq_nat n m
    end
  end.

Inductive SemTag : Set :=
| STag : SemTagType -> SemName -> SemTag
.

Definition SemTagEq (t1 t2:SemTag) : bool :=
  match t1, t2 with
  | STag t1 s1, STag t2 s2  => SemTagTypeEq t1 t2 && SemNameEq s1 s2
  end.

Inductive Value : Set :=
| VInt  : nat    -> Value
| VWord : nat    -> Value
| VBool : bool   -> Value
| VLoc  : Loc    -> Value
| VUnit : Value
| VBot  : Value
| VNode : SemTag -> list Value -> Value
.

Inductive Env : Set :=
| EEnv : (SemName -> Value) -> Env
.

Definition emptyEnv : Env := EEnv (fun n => VBot).

Inductive Heap : Set :=
| HHeap : nat -> (Loc -> Value) -> Heap
.

Definition emptyHeap : Heap := HHeap 0 (fun l => VBot).

Definition extendEnv (r:Env) (n:SemName) (v:Value) : Env :=
  EEnv (fun x =>
    if (SemNameEq x n) then v else
      match r with
      | EEnv f  => f x
      end)
.


From Cat Require Export Cat.
From Cat.Universal Require Import Initial Terminal Product Coproduct.
From Cat Require Export Instances.SETOID.

Set Implicit Arguments.

Class Graph : Type :=
{
  vertices : Setoid';
  edges : Setoid';
  src : SetoidHom edges vertices;
  tgt : SetoidHom edges vertices;
}.

Coercion vertices : Graph >-> Setoid'.

Arguments vertices _ : clear implicits.
Arguments edges _ : clear implicits.

Ltac graphob X := try intros until X;
match type of X with
| Graph =>
  let a := fresh X "_V" in
  let b := fresh X "_E" in
  let c := fresh X "_src" in
  let d := fresh X "_tgt" in destruct X as [a b c d]
| Ob _ => progress cbn in X; graphob X
end; cbn in *.

Ltac graphobs := repeat
match goal with
| X : Graph |- _ => graphob X
| X : Ob _ |- _ => graphob X
end.

Class GraphHom (X Y : Graph) : Type :=
{
  fver: SetoidHom (vertices X) (vertices Y);
  fed : SetoidHom (edges X) (edges Y);
  pres_src : forall e : edges X, src (fed e) == fver (src e);
  pres_tgt : forall e : edges X, tgt (fed e) == fver (tgt e);
}.

Arguments fver [X Y] _.
Arguments fed [X Y] _.

Ltac graphhom f := try intros until f;
match type of f with
| GraphHom _ _ =>
  let a := fresh f "_fver" in
  let b := fresh f "_fed" in
  let c := fresh f "_pres_src" in
  let d := fresh f "_pres_tgt" in destruct f as [a b c d]
| Hom _ _ => progress cbn in f; graphhom f
end; cbn in *.

Ltac graphhoms := intros; repeat
match goal with
| f : GraphHom _ _ |- _ => graphhom f
| f : Hom _ _ |- _ => graphhom f
| _ => idtac
end.

Ltac graph' := repeat (graphobs || graphhoms || cat).
Ltac graph := try (graph'; fail).

#[refine]
#[export]
Instance GraphHomSetoid (X Y : Graph) : Setoid (GraphHom X Y) :=
{
  equiv := fun f g : GraphHom X Y =>
    (forall v : vertices X, fver f v == fver g v)
      /\
    (forall e : edges X, fed f e == fed g e)
}.
Proof.
  now solve_equiv; intro; rewrite ?H, ?H2, ?H0, ?H1.
Defined.

#[refine]
#[export]
Instance GraphComp (X Y Z : Graph) (f : GraphHom X Y) (g : GraphHom Y Z) : GraphHom X Z :=
{
  fver := SetoidComp (fver f) (fver g);
  fed := SetoidComp (fed f) (fed g);
}.
Proof.
  - now cbn; intros; rewrite !pres_src.
  - now cbn; intros; rewrite !pres_tgt.
Defined.

#[refine]
#[export]
Instance GraphId (X : Graph) : GraphHom X X :=
{
  fver := SetoidId (vertices X);
  fed := SetoidId (edges X);
}.
Proof. all: easy. Defined.

#[refine]
#[export]
Instance GraphCat : Cat :=
{
  Ob := Graph;
  Hom := GraphHom;
  HomSetoid := GraphHomSetoid;
  comp := GraphComp;
  id := GraphId;
}.
Proof.
  - intros A B C f f' [Hf1 Hf2] g g' [Hg1 Hg2]; cbn in *.
    split; intros.
    + now rewrite Hf1, Hg1.
    + now rewrite Hf2, Hg2.
  - now cbn.
  - now cbn.
  - now cbn.
Defined.

(** Now we define the free category for the given graph G. *)

(** Morphisms are finite walks. *)
Inductive Walk {G : Graph} : vertices G -> vertices G -> Type :=
| Stop : forall v : vertices G, Walk v v
| Step :
  forall {v1 v2 v3 : vertices G} {e : edges G},
    src e = v1 -> tgt e = v2 -> Walk v2 v3 -> Walk v1 v3.

Arguments Stop {G v}.
Arguments Step {G v1 v2 v3 e} _ _ _.

Fixpoint wapp
  {G : Graph} {v1 v2 v3 : vertices G}
  (w1 : Walk v1 v2) : Walk v2 v3 -> Walk v1 v3 :=
match w1 with
| Stop => fun w2 => w2
| Step p1 p2 w1' => fun w2 => Step p1 p2 (wapp w1' w2)
end.

#[refine]
#[export]
Instance FreeCat (G : Graph) : Cat :=
{
  Ob := vertices G;
  Hom := Walk;
  id := @Stop G;
  comp := @wapp G;
}.
Proof.
  - intros v1 v2.
    split with (fun w1 w2 => w1 = w2).
    now split; red; [| | apply transitivity].
  - now intros v1 v2 v3 w12 w12' <- w23 w23' <-; cbn.
  - induction f as [| v1 v2 v3 e p1 p2 f']; cbn; intros.
    + easy.
    + now rewrite IHf'.
  - now cbn.
  - induction f as [| v1 v2 v3 e p1 p2 f']; cbn.
    + easy.
    + now rewrite IHf'.
Defined.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_inequalitysymmetric_1 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_ray_2 : (forall A B P : Universe, ((out_ A B P /\ (P <> B /\ ~(betS_ A P B))) -> betS_ A B P)).

Theorem lemma_ray1_3 : (forall A B P : Universe, (out_ A B P -> (betS_ A P B \/ (B = P \/ betS_ A B P)))).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e452m3_17limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e336m17_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e488m17_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e221m3_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


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

From Coq
  Require Import Arith List Lia.

From KruskalTrees
  Require Import notations tactics list_utils.

Import ListNotations.

Set Implicit Arguments.

#[local] Reserved Notation "'⟨' x '|' l '⟩ₗ'" (at level 0, l at level 200, format "⟨ x | l ⟩ₗ").

Section ltree.

  Variable (X : Type).

  Unset Elimination Schemes.

  Inductive ltree : Type :=
    | ltree_cons : X -> list ltree -> ltree.

  Set Elimination Schemes.

  Notation "⟨ x | l ⟩ₗ" := (ltree_cons x l).

  Definition ltree_node t := match t with ⟨x|_⟩ₗ => x end.
  Definition ltree_sons t := match t with ⟨_|l⟩ₗ => l end.

  Fact ltree_cons_inj x l y m : ⟨x|l⟩ₗ = ⟨y|m⟩ₗ -> x = y /\ l = m.
  Proof.
    intros H; split.
    + now apply f_equal with (f := ltree_node) in H.
    + now apply f_equal with (f := ltree_sons) in H.
  Qed.

  Section ltree_rect.

    (** The subtree relations between nodes and their sons *)

    Let is_subtree s t := s ∈ ltree_sons t.

    (* Same proof as below, but ltac style *)
    Local Fact is_subtree_wf_ltac : well_founded is_subtree.
    Proof.
      refine (fix is_subtree_wf_ltac t { struct t } := _).
      constructor; destruct t as [ x l ].
      cbn; clear x.
      intros s Hs.
      induction l as [ | r l IHl ].
      + destruct Hs.                (* match Hs with end *)
      + destruct Hs as [ e | Hs ].  (* match Hs with or_intro ... end *)
        * (* Beware calling is_subtree_wf_ltac on r, sub-term of l, NOT on s *)
          subst s.                  (* match e with eq_refl => ... end *)
          exact (is_subtree_wf_ltac r).
        * exact (IHl Hs).           (* sons_wf _ _ Hs *)
    Qed.

    (** The is_subtree relation is well_founded.
        The proof critically uses a nested fixpoint *)
    Let is_subtree_wf : well_founded is_subtree :=
      fix is_subtree_wf t : Acc is_subtree t :=
        Acc_intro t ((fix sons_wf l :=
          match l return forall r, r ∈ l -> _ with
            | []   => fun _ Hs => match Hs with end
            | r::l => fun s Hs =>
            match Hs with
              | or_introl e    => match e with eq_refl => is_subtree_wf r end
              | or_intror Hs   => sons_wf _ _ Hs
            end
          end) (ltree_sons t)).

    Variable (P : ltree -> Type)
             (HP : forall x l, (forall t, t ∈ l -> P t) -> P ⟨x|l⟩ₗ).

    (** Now the recursor on tree, by well founded induction using <ist *)

    Let Fixpoint ltree_Acc_rect t (a : Acc is_subtree t) : P t :=
      match t return Acc is_subtree t -> P t with
        | ⟨x|l⟩ₗ => fun a => HP _ _ (fun _ h => ltree_Acc_rect (Acc_inv a h))
      end a.

    Arguments ltree_Acc_rect : clear implicits.

    (** And we combine the recursor with well-foundedness *)

    Definition ltree_rect t : P t := ltree_Acc_rect t (is_subtree_wf t).

    Section ltree_rect_fix.

      Hypothesis HP_ext : forall x l f g, (forall x Hx, f x Hx = g x Hx) -> HP x l f = HP x l g.

      (** The Acc based recursor is proof-irrelevant *)

      Let Fixpoint ltree_Acc_rect_eq t a a' : ltree_Acc_rect t a = ltree_Acc_rect t a'.
      Proof.
        destruct a; destruct a'; destruct t; simpl.
        apply HP_ext.
        intros; apply ltree_Acc_rect_eq.
      Qed.

      (** From which we deduce the fixpoint equation *)

      Lemma ltree_rect_fix x l : ltree_rect ⟨x|l⟩ₗ = HP x l (fun t _ => ltree_rect t).
      Proof.
        unfold ltree_rect; destruct (is_subtree_wf ⟨x|l⟩ₗ); simpl.
        apply HP_ext.
        intros; apply ltree_Acc_rect_eq.
      Qed.

    End ltree_rect_fix.

  End ltree_rect.

  Definition ltree_rec (P : _ -> Set) := ltree_rect P.
  Definition ltree_ind (P : _ -> Prop) := ltree_rect P.

  Section ltree_eq_dec.

    (** As an application of ltree_rect, the discreteness of
        ltree X follows from that of X *)

    Hypothesis eqX_dec : forall x y : X, { x = y } + { x <> y }.

    Theorem ltree_eq_dec (t₁ t₂ : ltree) : { t₁ = t₂ } + { t₁ <> t₂ }.
    Proof.
      revert t₂; induction t₁ as [ x ll IH ]; intros [ y mm ].
      destruct (eqX_dec x y) as [ <- | H1 ].
      2: now right; contradict H1; inversion H1.
      destruct (list_eq_dect ll mm) as [ <- | H2 ]; auto.
      now right; contradict H2; inversion H2.
    Qed.

  End ltree_eq_dec.

  Section ltree_recursion.

    (** A non-dependent recursor for trees, using a direct nested fixpoint,
        the nesting occurs with the external (list) map function *)

    Variable (Y : Type) (f : X -> list ltree -> list Y -> Y).

    Fixpoint ltree_recursion (t : ltree) : Y :=
      match t with
        | ⟨x|l⟩ₗ => f x l (map ltree_recursion l)
      end.

  End ltree_recursion.

  Section ltree_fall_exst.

    Variable (P Q : X -> list ltree -> Prop).

    Definition ltree_fall : ltree -> Prop.
    Proof.
      induction 1 as [ x l lP ] using ltree_recursion.
      exact (P x l /\ forall h, h ∈ lP -> h).
    Defined.

    Fact ltree_fall_fix x l : ltree_fall ⟨x|l⟩ₗ <-> P x l /\ forall t, t ∈ l -> ltree_fall t.
    Proof.
      clear Q.
      simpl; apply and_equiv; try tauto; split.
      + intros H t Hl.
        apply H, in_map_iff; exists t; auto.
      + intros H h; rewrite in_map_iff.
        intros (t & <- & ?); auto.
    Qed.

    Definition ltree_exst : ltree -> Prop.
    Proof.
      induction 1 as [ x l lQ ] using ltree_recursion.
      exact (Q x l \/ exists h, h ∈ lQ /\ h).
    Defined.

    Fact ltree_exst_fix x l : ltree_exst ⟨x|l⟩ₗ <-> Q x l \/ exists t, t ∈ l /\ ltree_exst t.
    Proof.
      clear P.
      simpl; apply or_equiv; try tauto; split.
      + intros (? & (? & <- & ?)%in_map_iff & ?); eauto.
      + intros (t & H1 & H2).
        exists (ltree_exst t); split; trivial.
        apply in_map_iff; eauto.
    Qed.

    Section ltree_fall_rect.

      Variables (K : ltree -> Type)
                (HK : forall x l, P x l
                               -> (forall t, t ∈ l -> ltree_fall t)
                               -> (forall t, t ∈ l -> K t)
                               -> K ⟨x|l⟩ₗ).

      Theorem ltree_fall_rect t : ltree_fall t -> K t.
      Proof.
        induction t as [ x l IH ]; intros H.
        rewrite ltree_fall_fix in H; destruct H; auto.
      Qed.

    End ltree_fall_rect.

    Section ltree_fall_exst.

      Hypothesis HPQ : forall x l, P x l \/ Q x l.

      Fact ltree_fall_exst t : ltree_fall t \/ ltree_exst t.
      Proof.
        induction t as [ x l IH ].
        apply list_choice in IH as [ Hl | (t & Ht & Hl) ];
          [ destruct (HPQ x l) as [ H | H ] | ].
        1: left; apply ltree_fall_fix; auto.
        all: right; apply ltree_exst_fix; eauto.
      Qed.

    End ltree_fall_exst.

    Section ltree_fall_exst_t.

      Hypothesis HPQ : forall x l, { P x l } + { Q x l }.

      Fact ltree_fall_exst_t t : { ltree_fall t } + { ltree_exst t }.
      Proof.
        induction t as [ x l IH ].
        apply list_choice_t in IH as [ Hl | (t & Ht & Hl) ];
          [ destruct (HPQ x l) as [ H | H ] | ].
        1: left; apply ltree_fall_fix; auto.
        all: right; apply ltree_exst_fix; eauto.
      Qed.

    End ltree_fall_exst_t.

    Section ltree_fall_exst_absurd.

      Hypothesis HPQ : forall x l, P x l -> Q x l -> False.

      Fact ltree_fall_exst_absurd t : ltree_fall t -> ltree_exst t -> False.
      Proof.
        induction 1 as [ x l Hx Hl IHl ] using ltree_fall_rect.
        intros [ | (? & ? & ?) ]%ltree_exst_fix; eauto.
      Qed.

    End ltree_fall_exst_absurd.

  End ltree_fall_exst.

  Section ltree_weight.

    Variable (w : X -> nat).

    Implicit Type l : list ltree.

    Definition ltree_weight : ltree -> nat.
    Proof.
      apply ltree_recursion.
      exact (fun x _ m => w x+list_sum (fun x => x) m).
    Defined.

    Fact ltree_weight_fix x l : ltree_weight ⟨x|l⟩ₗ = w x + list_sum ltree_weight l.
    Proof.
      unfold ltree_weight at 1; simpl; f_equal.
      clear x; induction l; simpl; auto.
    Qed.

    Fact ltree_weight_0_fall t : ltree_weight t = 0 -> ltree_fall (fun x _ => w x = 0) t.
    Proof.
      induction t as [ x l IHl ]; rewrite ltree_weight_fix, ltree_fall_fix; split; tlia.
      intros t Ht.
      apply IHl; auto.
      generalize (list_sum_in ltree_weight _ _ Ht); lia.
    Qed.

    Fact ltree_weight_0_exst t : ltree_weight t = 0 -> ltree_exst (fun x _ => w x = 0) t.
    Proof. induction t; rewrite ltree_weight_fix, ltree_exst_fix; lia. Qed.

    Hypothesis (Hw : forall x, 0 < w x).

    Fact ltree_weight_gt t : 0 < ltree_weight t.
    Proof.
      destruct t as [ x l ]; rewrite ltree_weight_fix.
      generalize (Hw x); lia.
    Qed.

  End ltree_weight.

End ltree.

Fact ltree_fall_dec X (P : X -> list (ltree X) -> Prop) :
        (forall x l, { P x l } + { ~ P x l })
     -> (forall t, { ltree_fall P t } + { ~ ltree_fall P t }).
Proof.
  intros H t.
  apply ltree_fall_exst_t with (t := t) in H.
  destruct H as [ H | H ]; auto.
  right; intros H1; revert H1 H.
  apply ltree_fall_exst_absurd; auto.
Qed.

Module ltree_notations.

  Notation "⟨ x | l ⟩ₗ" := (ltree_cons x l).

End ltree_notations.

Import ltree_notations.


Require Import Coq.Strings.String.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Psatz.
Require Import compcert.lib.Integers.
Require Import PL.SetsDomain.
Require Import PL.DenotationalSemantics.
Local Open Scope bool.
Local Open Scope string.
Local Open Scope Z.
Local Open Scope sets_scope.

(** **** Exercise **** *)
(** 请证明_[BinRel.id]_是二元关系连接运算的单位元。 *)

Lemma BinRel_concat_id_l:
  forall {A B} (R: A -> B -> Prop),
    BinRel.id ∘ R == R.
Proof.
  intros. unfold BinRel.concat. sets_unfold. intros. unfold iff.
  split.
  - intros [b [H0 H1]].
    unfold BinRel.id in H0.
    rewrite H0. apply H1.
  - intros.
    exists a. split; try tauto.
    unfold BinRel.id. reflexivity.
Qed.

Lemma BinRel_concat_id_r:
  forall {A B} (R: A -> B -> Prop),
    R ∘ BinRel.id == R.
Proof.
  intros. unfold BinRel.concat. sets_unfold. intros a b. unfold iff.
  split.
  - intros [b0 [H0 H1]].
    unfold BinRel.id in H1. rewrite H1 in H0. apply H0.
  - intros.
    exists b. split; try tauto.
    unfold BinRel.id. reflexivity.
Qed.

(** **** Exercise **** *)
(** 请证明空集是二元关系连接运算的零元。请注意：在数学中，只要一个集合中不包含任
    何元素，那么这个集合就是空集。然而，在Coq中，任何一个数学对象都应当有类型。
    因此，下面定理中，我们用_[∅: A -> B -> Prop]_以及_[∅: B -> C -> Prop]_表示在
    考虑_[A]_到_[B]_的二元关系时以及在考虑_[B]_到_[C]_的二元关系时的空集。 *)

Lemma BinRel_concat_empty_l:
  forall {A B C} (R: B -> C -> Prop),
    (∅: A -> B -> Prop) ∘ R == ∅.
Proof.
  intros. sets_unfold. intros a c. unfold iff. split.
  2: { contradiction. }
  unfold BinRel.concat. intros.
  destruct H as [b H].
  tauto.
Qed.

Lemma BinRel_concat_empty_r:
  forall {A B C} (R: A -> B -> Prop),
    R ∘ (∅: B -> C -> Prop) == ∅.
Proof.
  intros. sets_unfold. intros a c. unfold iff. split.
  2: { contradiction. }
  unfold BinRel.concat. intros.
  destruct H as [b H]. tauto.
Qed.

(** **** Exercise **** *)
(** 请证明二元关系连接运算对于并集运算的分配律。 *)

Lemma BinRel_concat_union_distr_r:
  forall
    {A B C}
    (R1 R2: A -> B -> Prop)
    (R3: B -> C -> Prop),
  (R1 ∪ R2) ∘ R3 == (R1 ∘ R3) ∪ (R2 ∘ R3).
Proof.
  intros A B C R1 R2 R3.
  sets_unfold. unfold BinRel.concat.
  intros a c. unfold iff.
  split; intros.
  - destruct H as [b H].
    destruct H as [H H0].
    destruct H as [H | H'].
    + left. exists b. split; tauto.
    + right. exists b. split; tauto.
  - destruct H as [H | H'].
    + destruct H as [b [H H']].
      exists b. split; tauto.
    + destruct H' as [b [H H']].
      exists b. split; tauto.
Qed.

Lemma BinRel_concat_union_distr_l:
  forall
    {A B C}
    (R1: A -> B -> Prop)
    (R2 R3: B -> C -> Prop),
  R1 ∘ (R2 ∪ R3) == (R1 ∘ R2) ∪ (R1 ∘ R3).
Proof.
  intros A B C R1 R2 R3.
  sets_unfold. unfold BinRel.concat.
  intros a c. unfold iff.
  split; intros.
  - destruct H as [b [H H']]. destruct H' as [H0 | H1].
    + left. exists b. tauto.
    + right. exists b. tauto.
  - destruct H as [H | H'].
    + destruct H as [b H].
      exists b. tauto.
    + destruct H' as [b H].
      exists b. tauto.
Qed.

Lemma BinRel_concat_omega_union_distr_r:
  forall
    {A B C}
    (R1: nat -> A -> B -> Prop)
    (R2: B -> C -> Prop),
  (⋃ R1) ∘ R2 == ⋃ (fun n => R1 n ∘ R2).
Proof.
  intros A B C R1 R2.
  sets_unfold. unfold BinRel.concat.
  intros a c. unfold iff.
  split; intros.
  - destruct H as [b [H H']].
    destruct H as [n H].
    exists n. exists b. tauto.
  - destruct H as [n [b [H H']]].
    exists b. split.
    + exists n. tauto.
    + tauto.
Qed.

Lemma BinRel_concat_omega_union_distr_l:
  forall
    {A B C}
    (R1: A -> B -> Prop)
    (R2: nat -> B -> C -> Prop),
  R1 ∘ (⋃ R2) == ⋃ (fun n => R1 ∘ R2 n).
Proof.
  intros A B C R1 R2.
  sets_unfold. unfold BinRel.concat.
  intros a c. unfold iff.
  split; intros.
  - destruct H as [b [H [n H']]].
    exists n. exists b. tauto.
  - destruct H as [n [b [H H']]].
    exists b. split; try tauto.
    exists n. tauto.
Qed.


(***************************************************************************
* Preservation and Progress for mini-ML (CBV) - Definitions                *
* Arthur Charguéraud, March 2007                                           *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN List.

(* ********************************************************************** *)
(** ** Description of types *)

(** Grammar of types. *)

Inductive typ : Set :=
  | typ_bvar  : nat -> typ
  | typ_fvar  : var -> typ
  | typ_arrow : typ -> typ -> typ.

(** Types are inhabited, giving us a default value. *)

Definition typ_def := typ_bvar 0.

(** Type schemes. *)

Record sch : Set := Sch {
  sch_arity : nat ;
  sch_type  : typ }.

(** Opening body of type schemes. *)

Fixpoint typ_open (T : typ) (Vs : list typ) {struct T} : typ :=
  match T with
  | typ_bvar i      => nth i Vs typ_def
  | typ_fvar x      => typ_fvar x
  | typ_arrow T1 T2 => typ_arrow (typ_open T1 Vs) (typ_open T2 Vs)
  end.

(** Opening body of type schemes with variables *)

Definition typ_fvars :=
  List.map typ_fvar.

Definition typ_open_vars T Xs :=
  typ_open T (typ_fvars Xs).

(** Instanciation of a type scheme *)

Definition sch_open M :=
  typ_open (sch_type M).

Definition sch_open_vars M :=
  typ_open_vars (sch_type M).

Notation "M ^^ Vs" := (sch_open M Vs)
  (at level 67, only parsing) : typ_scope.
Notation "M ^ Xs" :=
  (sch_open_vars M Xs) (only parsing) : typ_scope.

Bind Scope typ_scope with typ.
Open Scope typ_scope.

(** Locally closed types *)

Inductive type : typ -> Prop :=
  | type_fvar : forall X,
      type (typ_fvar X)
  | type_arrow : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_arrow T1 T2).

(** List of n locally closed types *)

Definition types := list_for_n type.

(** Body of a scheme *)

Definition typ_body n T :=
  exists L, forall Xs,
  fresh L n Xs ->
  type (typ_open_vars T Xs).

(** Definition of a well-formed scheme *)

Definition scheme M :=
   typ_body (sch_arity M) (sch_type M).

(* ********************************************************************** *)
(** ** Description of terms *)

(** Grammar of terms. *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : trm -> trm
  | trm_let  : trm -> trm -> trm
  | trm_app  : trm -> trm -> trm.

(** Opening term binders. *)

Fixpoint trm_open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => If k = i then u else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_abs t1    => trm_abs (trm_open_rec (S k) u t1)
  | trm_let t1 t2 => trm_let (trm_open_rec k u t1) (trm_open_rec (S k) u t2)
  | trm_app t1 t2 => trm_app (trm_open_rec k u t1) (trm_open_rec k u t2)
  end.

Definition trm_open t u := trm_open_rec 0 u t.

Notation "{ k ~> u } t" := (trm_open_rec k u t) (at level 67).
Notation "t ^^ u" := (trm_open t u) (at level 67).
Notation "t ^ x" := (trm_open t (trm_fvar x)).

(** Locally closed termessions *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (trm_abs t1)
  | term_let : forall L t1 t2,
      term t1 ->
      (forall x, x \notin L -> term (t2 ^ x)) ->
      term (trm_let t1 t2)
  | term_app : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_app t1 t2).

(** Definition of the body of an abstraction *)

Definition term_body t :=
  exists L, forall x, x \notin L -> term (t ^ x).

(* ********************************************************************** *)
(** ** Description of typing *)

(** Definition of typing environments *)

Definition env := env sch.

(** The typing judgment *)

Reserved Notation "E |= t ~: T" (at level 69).

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x M Us,
      ok E ->
      binds x M E ->
      types (sch_arity M) Us ->
      scheme M ->
      E |= (trm_fvar x) ~: (M ^^ Us)
  | typing_abs : forall L E U T t1,
      type U ->
      (forall x, x \notin L ->
        (E & x ~ Sch 0 U) |= (t1 ^ x) ~: T) ->
      E |= (trm_abs t1) ~: (typ_arrow U T)
  | typing_let : forall M L1 L2 E T2 t1 t2,
      (forall Xs, fresh L1 (sch_arity M) Xs ->
         E |= t1 ~: (M ^ Xs)) ->
      (forall x, x \notin L2 -> (E & x ~ M) |= (t2 ^ x) ~: T2) ->
      E |= (trm_let t1 t2) ~: T2
  | typing_app : forall E S T t1 t2,
      E |= t1 ~: (typ_arrow S T) ->
      E |= t2 ~: S ->
      E |= (trm_app t1 t2) ~: T

where "E |= t ~: T" := (typing E t T).

(* ********************************************************************** *)
(** ** Description of the semantics *)

(** Grammar of values *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1, term (trm_abs t1) -> value (trm_abs t1).

(** Reduction rules *)

Inductive red : trm -> trm -> Prop :=
  | red_abs : forall t1 t2,
      term (trm_abs t1) ->
      value t2 ->
      red (trm_app (trm_abs t1) t2) (t1 ^^ t2)
  | red_let : forall t1 t2,
      term (trm_let t1 t2) ->
      value t1 ->
      red (trm_let t1 t2) (t2 ^^ t1)
  | red_let_1 : forall t1 t1' t2,
      term_body t2 ->
      red t1 t1' ->
      red (trm_let t1 t2) (trm_let t1' t2)
  | red_app_1 : forall t1 t1' t2,
      term t2 ->
      red t1 t1' ->
      red (trm_app t1 t2) (trm_app t1' t2)
  | red_app_2 : forall t1 t2 t2',
      value t1 ->
      red t2 t2' ->
      red (trm_app t1 t2) (trm_app t1 t2').

Notation "t --> t'" := (red t t') (at level 68).

(* ********************************************************************** *)
(** ** Description of the results *)

(** Goal is to prove preservation and progress *)

Definition preservation := forall E t t' T,
  E |= t ~: T ->
  t --> t' ->
  E |= t' ~: T.

Definition progress := forall t T,
  empty |= t ~: T ->
     value t
  \/ exists t', t --> t'.


Inductive bool : Type :=
| true
| false.

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

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

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

Definition negb' (b:bool) : bool :=
    if b then false
    else true.

Definition andb' (b1:bool) (b2:bool) : bool :=
    if b1 then b2
    else false.

Definition orb' (b1:bool) (b2:bool) : bool :=
    if b1 then true
    else b2.

Definition nandb  (b1:bool) (b2:bool) : bool :=
    match b1 with
    | false => true
    | true => (negb b2)
    end.

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Example test_orb1: (orb true true) = true.
Proof. simpl. reflexivity. Qed.

Example test_orb2: (orb true false) = true.
Proof. simpl. reflexivity. Qed.

Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.

Example test_orb4: (orb false false) = false.
Proof. simpl. reflexivity. Qed.

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

Example xorb_test1: xorb true true = false.
Proof. reflexivity. Qed.
Example xorb_test2: xorb true false = true.
Proof. reflexivity. Qed.
Example xorb_test3: xorb false true = true.
Proof. reflexivity. Qed.
Example xorb_test4: xorb false true = true.
Proof. reflexivity. Qed.

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).
Notation "x ^ y" := (xorb x y).

Example test_orb5: true && false = false.
Proof. simpl. reflexivity. Qed.

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

Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

Check true.
Check true : bool.
Check (negb true) : bool.
Check negb : bool -> bool.

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

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

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

Compute (next_weekday (next_weekday friday)).
Compute (next_weekday friday).

Example test_next_weekday:
    (next_weekday (next_weekday saturday)) = tuesday.

Proof.
    simpl.
    reflexivity.
Qed.

Inductive rgb : Type :=
    | red
    | green
    | blue.

Inductive color : Type :=
    | black
    | white
    | primary (p : rgb).

Definition monochrome (c:color) : bool :=
    match c with
    | black => true
    | white => true
    | primary p => false
    end.

Definition isred (c:color) : bool :=
    match c with
    | black => true
    | white => true
    | primary red => true
    | primary _ => false
    end.

Module Playground.
    Definition b : rgb := blue.
End Playground.

Definition b : bool := true.

Check Playground.b : rgb.
Check b : bool.

Module TuplePlayground.
    Inductive bit : Type :=
        | B0
        | B1.

    Inductive nybble : Type :=
        | bits (b0 b1 b2 b3 : bit).

    Check (bits B1 B0 B1 B0) : nybble.

    Definition all_zero (nb:nybble) : bool :=
        match nb with
        | (bits B0 B0 B0 B0) => true
        | (bits _ _ _ _) => false
        end.

    Compute (all_zero (bits B1 B1 B0 B0)).
    Compute (all_zero (bits B0 B0 B0 B0)).

End TuplePlayground.

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

    Definition pred (n:nat) : nat :=
        match n with
        | O => O
        | S n' => n'
        end.
End NatPlayground.

Check (S (S (S (S O)))).

Definition minustwo (n:nat) : nat :=
    match n with
    | O => O
    | S O => O
    | S (S n') => n'
    end.

Compute (minustwo 4).

Check S : nat -> nat.
Check pred : nat -> nat.
Check minustwo : nat -> nat.

Fixpoint even (n:nat) : bool :=
    match n with
    | O => true
    | S O => false
    | S (S n') => even n'
    end.

Definition odd (n:nat) : bool :=
    negb (even n).

Example test_odd1: odd 1 = true.
Proof. simpl. reflexivity. Qed.
Example test_odd2: odd 4 = false.
Proof. simpl. reflexivity. Qed.

Module NatPlayground2.
    Fixpoint plus (n:nat) (m:nat) : nat :=
        match n with
        | O => m
        | S n' => S (plus n' m)
        end.

    Compute plus 3 2.

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

    Example test_mult1: (mult 3 3) = 9.
    Proof. simpl. reflexivity. Qed.

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

    Example test_minus: (minus 3 3) = 0.
    Proof. simpl. reflexivity. Qed.
End NatPlayground2.

Fixpoint exp (base power : nat) : nat :=
    match power with
    | O => S O
    | S p => mult base (exp base p)
    end.

Example exp_test: exp 2 3 = 8.
Proof. simpl. reflexivity. Qed.

Fixpoint factorial (n:nat) : nat :=
    match n with
    | O => S O
    | S n' => mult n (factorial n')
    end.

Example fact_test1: factorial 3 = 6.
Proof. simpl. reflexivity. Qed.
Example fact_test2: factorial 5 = mult 10 12.
Proof. simpl. reflexivity. Qed.

Notation "x + y" := (plus x y) (at level 50, left associativity) : nat_scope.
Notation "x - y" := (minus x y) (at level 50, left associativity) : nat_scope.
Notation "x * y" := (mult x y) (at level 40, left associativity) : nat_scope.

Check ((0 + 1) + 1) : nat.

Fixpoint eqb (n m:nat) : bool :=
    match n with
    | O => match m with
           | O => true
           | S m' => false
           end
    | S n' => match m with
           | O => false
           | S m' => eqb n' m'
           end
    end.

Fixpoint eqb' (n m:nat) : bool :=
    match n, m with
    | S n', S m' => eqb' n' m'
    | O, O => true
    | _, _ => false
    end.

Example eqb_test: eqb 3 3 = true.
Proof. simpl. reflexivity. Qed.

Example eqb'_test: eqb' 6 19 = false.
Proof. simpl. reflexivity. Qed.

Example eqb'_test2: eqb 3 3 = true.
Proof. simpl. reflexivity. Qed.

Fixpoint leb (n m:nat) : bool :=
    match n with
    | O => true
    | S n' => match m with
              | O => false
              | S m' => leb n' m'
              end
    end.

Example leb_test: leb 3 2 = false.
Proof. simpl. reflexivity. Qed.

Example leb_test2: leb 2 3 = true.
Proof. simpl. reflexivity. Qed.

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.
Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.

Example test_leb3: 3 <=? 3 = true.
Proof. simpl. reflexivity. Qed.

Definition ltb (n m:nat) : bool :=
    match n, m with
    | S n', S m' => leb (S n') m'
    | _, O => false
    | O, _ => true
    end.

    Notation "x <? y" := (ltb x y) (at level 70) : nat_scope.
    Example test_ltb1: (ltb 2 2) = false.
    Proof. simpl. reflexivity. Qed.
    Example test_ltb2: (ltb 2 4) = true.
    Proof. simpl. reflexivity. Qed.
    Example test_ltb3: (ltb 4 2) = false.
    Proof. simpl. reflexivity. Qed.

    Theorem plus_O_n : forall n : nat, 0 + n = n.
    Proof. intros n. simpl. reflexivity. Qed.

    Theorem plus_O_n': forall n : nat, 0 + n = n.
    Proof.
        intros n. simpl. reflexivity.
    Qed.

    Theorem plus_1_1 : forall n : nat, 1 + n = S n.
    Proof.
        intros n. reflexivity.
    Qed.

    Theorem mult_0_1: forall n : nat, 0 * n = 0.
    Proof.
        intros n. reflexivity.
    Qed.

Theorem plus_id_example: forall n m:nat, n = m -> n + n = m + m.
Proof.
    (*move both quantifiers into the context: *)
    intros n m.
    (*move the hypothesis into the context: *)
    intros hypothesis.
    (*rewrite the goal using the hypothesis: *)
    rewrite -> hypothesis.
    reflexivity.
Qed.

Theorem plus_id_example': forall n m:nat, n = m -> n + n = m + m.
Proof.
    intros n m.
    intros hypothesis.
    rewrite <- hypothesis.
    reflexivity.
Qed.

Theorem plus_id_exercise: forall n m o : nat, n = m -> m = o -> n + m = m + o.
Proof.
    intros n m o.
    intros hypothesis1.
    rewrite -> hypothesis1.
    intros hypothesis2.
    rewrite hypothesis2.
    reflexivity.
Qed.

Check mult_n_O.
Check mult_n_Sm.

Theorem mult_n_0_m_0 : forall p q : nat, (p * 0) + (q * 0) = 0.
Proof.
    intros p q.
    rewrite <- mult_n_O.
    rewrite <- mult_n_O.
    simpl.
    reflexivity.
Qed.

Theorem mult_n_1: forall p : nat, p * 1 = p.
Proof.
    intros p.
    rewrite <- mult_n_Sm.
    rewrite <- mult_n_O.
    simpl.
    reflexivity.
Qed.

Theorem plus_1_neq_0_firsttry : forall n : nat, (n + 1) =? 0 = false.
Proof.
    intros n.
    simpl.
Abort.

Theorem plus_1_neq_0 : forall n : nat, (n + 1) =? 0 = false.
Proof.
    intros n. destruct n as [| n'] eqn:E.
    - reflexivity.
    - reflexivity.
Qed.

Theorem negb_involutive : forall b : bool,
    negb (negb b) = b.
Proof.
    intros b.
    destruct b eqn:E.
    - reflexivity.
    - reflexivity.
Qed.

Theorem andb_commutative : forall b c : bool, andb b c = andb c b.
Proof.
    intros b c.
    destruct b eqn:Eb.
    - destruct c eqn:Ec.
     + reflexivity.
     + reflexivity.
    - destruct c eqn:Ec.
     + reflexivity.
     + reflexivity.
Qed.

Theorem nadb3_exchange : forall a b c : bool, andb (andb a b) c = andb (andb a c) b.
Proof.
 intros a b c.
 destruct a eqn:Ea.
  * destruct b eqn:Eb.
   ** destruct c eqn:Ec.
    - reflexivity.
    - reflexivity.
   ** destruct c eqn:Ec.
    - reflexivity.
    - reflexivity.
  * destruct b eqn:Eb.
   ** destruct c eqn:Ec.
    - reflexivity.
    - reflexivity.
   ** destruct c eqn:Ec.
    - reflexivity.
    - reflexivity.
Qed.

Theorem andb_true_elim2 : forall b c : bool, andb b c = true -> c = true.
Proof.
  intros b c.
  destruct b eqn:Eb.
    * destruct c eqn:Ec.
      { simpl. intros hypothesis. assumption. }
      { simpl. intros hypothesis. assumption. }
    * destruct c eqn:Ec.
      { simpl. intros hypothesis. reflexivity. }
      { simpl. intros hypothesis. assumption. }
Qed.

Theorem plus_1_neq_0' : forall n : nat, (n + 1) =? 0 = false.
Proof.
  intros [|n].
  reflexivity.
  reflexivity.
Qed.

Theorem andb_commutative'' : forall a b : bool, andb a b = andb b a.
Proof.
  intros [][].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Theorem zero_nbeq_plus_1 : forall n : nat, 0 =? (n + 1) = false.
Proof.
  intros [|n].
  reflexivity.
  reflexivity.
Qed.

(*Fixpoint func (n : nat) : nat :=
  match n with
  | O => 1
  | S n' => func O
  end.*)

Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool) , f x = x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f hypothesis [].
  - rewrite -> hypothesis.
    rewrite -> hypothesis.
    reflexivity.
  - rewrite -> hypothesis.
    rewrite -> hypothesis.
    reflexivity.
Qed.

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = negb x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f hypothesis [].
  - rewrite -> hypothesis.
    rewrite -> hypothesis.
    reflexivity.
  - rewrite -> hypothesis.
    rewrite -> hypothesis.
    reflexivity.
Qed.

Theorem andb_eq_orb : forall (b c : bool), (andb b c = orb b c) -> b = c.
Proof.
  intros [][].
  - simpl. intros hypothesis. assumption.
  - simpl. intros hypothesis. rewrite -> hypothesis. reflexivity.
  - simpl. intros hypothesis. assumption.
  - simpl. intros hypothesis. assumption.
Qed.

Theorem xor_a_b_a_is_b : forall a b : bool, xorb (xorb a b) a = b.
Proof.
  intros [][].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Theorem xor_commutative : forall a b : bool,
  xorb a b = xorb b a.
Proof.
  intros [][].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Check xor_a_b_a_is_b.

Compute true ^ false.

Compute true ^ false ^ true ^ true ^ false.
Check xor_a_b_a_is_b.
Check xor_commutative.

Inductive bin : Type :=
  | Z
  | B0 (n : bin)
  | B1 (n : bin).

Fixpoint incr (m : bin) : bin :=
  match m with
  | Z => (B1 Z)
  | B0 m' => B1 m'
  | B1 m' => B0 (incr m')
  end.

Fixpoint bin_to_nat (m:bin) : nat :=
  match m with
  | Z => O
  | B0 m' => 2 * (bin_to_nat m')
  | B1 m' => 2 * (bin_to_nat m') + 1
  end.

Example test_bin_incr1 : (incr (B1 Z)) = B0 (B1 Z).
Proof. reflexivity. Qed.
Example test_bin_incr2 : (incr (B0 (B1 Z))) = B1 (B1 Z).
Proof. reflexivity. Qed.
Example test_bin_incr3 : (incr (B1 (B1 Z))) = B0 (B0 (B1 Z)).
Proof. reflexivity. Qed.
Example test_bin_incr4 : bin_to_nat (B0 (B1 Z)) = 2.
Proof. reflexivity. Qed.
Example test_bin_incr5 :
        bin_to_nat (incr (B1 Z)) = 1 + bin_to_nat (B1 Z).
Proof. reflexivity. Qed.
Example test_bin_incr6 :
        bin_to_nat (incr (incr (B1 Z))) = 2 + bin_to_nat (B1 Z).
Proof. reflexivity. Qed.

Check day.
Check tuesday.


Require Import rt.util.all.
Require Import rt.model.schedule.global.basic.schedule.
Require Import rt.analysis.global.basic.workload_bound.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module InterferenceBoundGeneric.

  Section Definitions.

    Import Schedule WorkloadBound.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    (* Let tsk be the task to be analyzed. *)
    Variable tsk: sporadic_task.

    Let task_with_response_time := (sporadic_task * time)%type.

    (* Assume a known response-time bound for each interfering task ... *)
    Variable R_prev: seq task_with_response_time.

    (* ... and an interval length delta. *)
    Variable delta: time.

    Section PerTask.

      Variable tsk_R: task_with_response_time.
      Let tsk_other := fst tsk_R.
      Let R_other := snd tsk_R.

      (* Based on the workload bound, Bertogna and Cirinei define the
         following interference bound for a task. *)
      Definition interference_bound_generic :=
        minn (W task_cost task_period tsk_other R_other delta) (delta - task_cost tsk + 1).

    End PerTask.

  End Definitions.

End InterferenceBoundGeneric.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e194m33_7limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Omega.
Require Import List.

Require Import mxx.
Require Import Flanguage.
Require Export typesystem.

(** * System Fcc (indexed version) *)

(** We write [jterm H G a t] the indexed term judgment. It is exactly
like the lambda term judgment in [Ltypesystem_v] with index
annotations.
*)
Inductive jterm v : tenv -> aenv -> term -> type -> Prop :=
| JVar : forall H G k x t,
  cobj G CAEnv ->
  (mS v -> jobj v H (JT t KStar)) ->
  Gnth G x t ->
  jterm v H G (Var k x) t
| JLam : forall H G k a t s,
  (mS v -> jobj v H (JT s KStar)) ->
  jobj v H (JT t KStar) ->
  jterm v H (GCons G t) a s ->
  jterm v H G (Lam k a) (TArr t s)
| JApp : forall H G k a b t s,
  (mS v -> jobj v H (JT t KStar)) ->
  (mS v -> jobj v H (JT s KStar)) ->
  jterm v H G a (TArr t s) ->
  jterm v H G b t ->
  jterm v H G (App k a b) s
| JUnit : forall H G k,
  cobj H CTEnv ->
  cobj G CAEnv ->
  jterm v H G (Unit k) TOne
| JPair : forall H G k a b t s,
  (mS v -> jobj v H (JT t KStar)) ->
  (mS v -> jobj v H (JT s KStar)) ->
  jterm v H G a t ->
  jterm v H G b s ->
  jterm v H G (Pair k a b) (TProd t s)
| JFst : forall H G k a t s,
  (mS v -> jobj v H (JT t KStar)) ->
  (mS v -> jobj v H (JT s KStar)) ->
  jterm v H G a (TProd t s) ->
  jterm v H G (Fst k a) t
| JSnd : forall H G k a t s,
  (mS v -> jobj v H (JT t KStar)) ->
  (mS v -> jobj v H (JT s KStar)) ->
  jterm v H G a (TProd t s) ->
  jterm v H G (Snd k a) s
| JAbsurd : forall H G k a s,
  jterm v H G a TVoid ->
  jobj v H (JT s KStar) ->
  jterm v H G (Absurd k a) s
| JInl : forall H G k a t s,
  (mS v -> jobj v H (JT t KStar)) ->
  jobj v H (JT s KStar) ->
  jterm v H G a t ->
  jterm v H G (Inl k a) (TSum t s)
| JInr : forall H G k a t s,
  jobj v H (JT t KStar) ->
  (mS v -> jobj v H (JT s KStar)) ->
  jterm v H G a s ->
  jterm v H G (Inr k a) (TSum t s)
| JMatch : forall H G k a bl br tl tr s,
  (mS v -> jobj v H (JT tl KStar)) ->
  (mS v -> jobj v H (JT tr KStar)) ->
  (mS v -> jobj v H (JT s KStar)) ->
  jterm v H G a (TSum tl tr) ->
  jterm v H (GCons G tl) bl s ->
  jterm v H (GCons G tr) br s ->
  jterm v H G (Match k a bl br) s
| JGen : forall H G k k' a t,
  (mE v -> jobj v H (Jwf k' CKind)) ->
  (mS v -> jobj v (HCons H k') (JT t KStar)) ->
  jterm v (HCons H k') (lift 1 0 G) a t ->
  jterm v H G (Gen k a) (TPi k' t)
| JInst : forall H G k k' a t s,
  (mS v -> jobj v (HCons H k') (JT t KStar)) ->
  jterm v H G a (TPi k' t) ->
  jobj v H (JT s k') ->
  jterm v H G (Inst k a) (subst s 0 t)
| JCoer : forall H H' HH' G a t s,
  Happ H H' HH' ->
  (mS v -> jobj v H (JH H')) ->
  (mS v -> jobj v HH' (JT t KStar)) ->
  jterm v HH' (lift (Hlength H') 0 G) a t ->
  jobj v H (JC YNil YNil H' t s) ->
  jterm v H G a s
.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.

Local Open Scope cat.

Section CatIsoInserter.
  Context {C₁ C₂ : category}
          (F G : C₁ ⟶ C₂).

  Definition cat_iso_inserter_disp_cat_ob_mor : disp_cat_ob_mor C₁.
  Proof.
    simple refine (_ ,, _).
    - exact (λ x, z_iso (F x) (G x)).
    - exact (λ x y hx hy f, hx · #G f = #F f · hy).
  Defined.

  Definition cat_iso_inserter_disp_cat_id_comp
    : disp_cat_id_comp C₁ cat_iso_inserter_disp_cat_ob_mor.
  Proof.
    split.
    - intros x hx ; cbn.
      rewrite !functor_id.
      rewrite id_left, id_right.
      apply idpath.
    - intros x y z f g hx hy hz hf hg ; cbn in *.
      rewrite !functor_comp.
      rewrite !assoc.
      rewrite hf.
      rewrite !assoc'.
      rewrite hg.
      apply idpath.
  Qed.

  Definition cat_iso_inserter_disp_cat_data : disp_cat_data C₁.
  Proof.
    simple refine (_ ,, _).
    - exact cat_iso_inserter_disp_cat_ob_mor.
    - exact cat_iso_inserter_disp_cat_id_comp.
  Defined.

  Definition cat_iso_inserter_disp_cat_axioms
    : disp_cat_axioms C₁ cat_iso_inserter_disp_cat_data.
  Proof.
    repeat split ; intros ; try (apply homset_property).
    apply isasetaprop.
    apply homset_property.
  Qed.

  Definition cat_iso_inserter_disp_cat : disp_cat C₁.
  Proof.
    simple refine (_ ,, _).
    - exact cat_iso_inserter_disp_cat_data.
    - exact cat_iso_inserter_disp_cat_axioms.
  Defined.

  Definition is_z_iso_disp_cat_iso_inserter
             {x y : C₁}
             {f : x --> y}
             (Hf : is_z_isomorphism f)
             {hx : cat_iso_inserter_disp_cat x}
             {hy : cat_iso_inserter_disp_cat y}
             (hf : hx -->[ f ] hy)
    : is_z_iso_disp (make_z_iso' f Hf) hf.
  Proof.
    simple refine (_ ,, (_ ,, _)) ; cbn in *.
    - rewrite !functor_on_inv_from_z_iso.
      refine (!_).
      use z_iso_inv_on_left.
      refine (!_).
      rewrite !assoc'.
      use z_iso_inv_on_right.
      exact hf.
    - apply homset_property.
    - apply homset_property.
  Qed.

  Definition is_univalent_cat_iso_inserter_disp_cat
    : is_univalent_disp cat_iso_inserter_disp_cat.
  Proof.
    intros x y e hx hy ; induction e.
    use isweqimplimpl.
    - intro i.
      use z_iso_eq.
      refine (_ @ pr1 i @ _) ; cbn.
      + rewrite functor_id.
        rewrite id_right.
        apply idpath.
      + rewrite functor_id.
        apply id_left.
    - use isaset_z_iso.
    - use isaproptotal2.
      + intro.
        apply isaprop_is_z_iso_disp.
      + intros.
        apply homset_property.
  Qed.

  Definition cat_iso_inserter : category
    := total_category cat_iso_inserter_disp_cat.

  Definition is_univalent_cat_iso_inserter
             (H₁ : is_univalent C₁)
    : is_univalent cat_iso_inserter.
  Proof.
    use is_univalent_total_category.
    - exact H₁.
    - apply is_univalent_cat_iso_inserter_disp_cat.
  Defined.

  Definition make_cat_iso_inserter
             (x : C₁)
             (f : z_iso (F x) (G x))
    : cat_iso_inserter
    := x ,, f.

  Definition cat_iso_inserter_mor_path
             {x y : cat_iso_inserter}
             (f : pr1 x --> pr1 y)
    : UU
    := pr12 x · # G f = # F f · pr12 y.

  Definition make_cat_iso_inserter_mor
             {x y : cat_iso_inserter}
             (f : pr1 x --> pr1 y)
             (p : cat_iso_inserter_mor_path f)
    : x --> y
    := f ,, p.

  Definition cat_iso_inserter_pr1 : cat_iso_inserter ⟶ C₁ := pr1_category _.
End CatIsoInserter.

Definition univalent_cat_iso_inserter
           {C₁ C₂ : univalent_category}
           (F G : C₁ ⟶ C₂)
  : univalent_category.
Proof.
  use make_univalent_category.
  - exact (cat_iso_inserter F G).
  - apply is_univalent_cat_iso_inserter.
    exact (pr2 C₁).
Defined.

Definition eq_cat_iso_inserter
           {C₁ C₂ : category}
           {F G : C₁ ⟶ C₂}
           {x y : cat_iso_inserter F G}
           {f g : x --> y}
           (p : pr1 f = pr1 g)
  : f = g.
Proof.
  use subtypePath.
  {
    intro.
    apply homset_property.
  }
  exact p.
Qed.

Definition is_z_iso_cat_iso_inserter
           {C₁ C₂ : category}
           {F G : C₁ ⟶ C₂}
           {x y : cat_iso_inserter F G}
           (f : x --> y)
           (Hf : is_z_isomorphism (pr1 f))
  : is_z_isomorphism f.
Proof.
  use is_z_iso_total.
  - exact Hf.
  - apply is_z_iso_disp_cat_iso_inserter.
Defined.

Definition z_iso_cat_iso_inserter
           {C₁ C₂ : category}
           {F G : C₁ ⟶ C₂}
           {x y : cat_iso_inserter F G}
           (f : x --> y)
           (Hf : is_z_isomorphism (pr1 f))
  : z_iso x y.
Proof.
  use make_z_iso'.
  - exact f.
  - apply is_z_iso_cat_iso_inserter.
    exact Hf.
Defined.

Definition from_is_z_iso_cat_iso_inserter
           {C₁ C₂ : category}
           {F G : C₁ ⟶ C₂}
           {x y : cat_iso_inserter F G}
           (f : x --> y)
           (Hf : is_z_isomorphism f)
  : is_z_isomorphism (pr1 f)
  := pr2 (functor_on_z_iso (cat_iso_inserter_pr1 F G) (make_z_iso' _ Hf)).

Definition from_z_iso_cat_iso_inserter
           {C₁ C₂ : category}
           {F G : C₁ ⟶ C₂}
           {x y : cat_iso_inserter F G}
           (f : z_iso x y)
  : z_iso (pr1 x) (pr1 y)
  := functor_on_z_iso (cat_iso_inserter_pr1 F G) f.

Definition cat_iso_inserter_nat_trans_data
           {C₁ C₂ : category}
           (F G : C₁ ⟶ C₂)
  : nat_trans_data
      (cat_iso_inserter_pr1 F G ∙ F)
      (cat_iso_inserter_pr1 F G ∙ G)
  := λ x, pr12 x.

Definition cat_iso_inserter_nat_trans_is_nat_trans
           {C₁ C₂ : category}
           (F G : C₁ ⟶ C₂)
  : is_nat_trans _ _ (cat_iso_inserter_nat_trans_data F G).
Proof.
  intros x y f.
  exact (!(pr2 f)).
Qed.

Definition cat_iso_inserter_nat_trans
           {C₁ C₂ : category}
           (F G : C₁ ⟶ C₂)
  : cat_iso_inserter_pr1 F G ∙ F ⟹ cat_iso_inserter_pr1 F G ∙ G.
Proof.
  use make_nat_trans.
  - exact (cat_iso_inserter_nat_trans_data F G).
  - exact (cat_iso_inserter_nat_trans_is_nat_trans F G).
Defined.

Definition cat_iso_inserter_nat_iso
           {C₁ C₂ : category}
           (F G : C₁ ⟶ C₂)
  : nat_z_iso
      (cat_iso_inserter_pr1 F G ∙ F)
      (cat_iso_inserter_pr1 F G ∙ G).
Proof.
  use make_nat_z_iso.
  - exact (cat_iso_inserter_nat_trans F G).
  - intro x.
    apply z_iso_is_z_isomorphism.
Defined.

Section CatIsoInserterFunctor.
  Context {C₁ C₂ C₃ : category}
          {F G : C₂ ⟶ C₃}
          (H : C₁ ⟶ C₂)
          (α : nat_z_iso (H ∙ F) (H ∙ G)).

  Definition functor_to_cat_iso_inserter_data
    : functor_data C₁ (cat_iso_inserter F G).
  Proof.
    use make_functor_data.
    - exact (λ x, H x ,, nat_z_iso_pointwise_z_iso α x).
    - refine (λ x y f, # H f ,, _).
      abstract
        (cbn ;
         exact (!(nat_trans_ax α _ _ f))).
  Defined.

  Definition functor_to_cat_iso_inserter_is_functor
    : is_functor functor_to_cat_iso_inserter_data.
  Proof.
    split.
    - intros x.
      use eq_cat_iso_inserter ; cbn.
      apply functor_id.
    - intros x y z f g.
      use eq_cat_iso_inserter ; cbn.
      apply functor_comp.
  Qed.

  Definition functor_to_cat_iso_inserter
    : C₁ ⟶ cat_iso_inserter F G.
  Proof.
    use make_functor.
    - exact functor_to_cat_iso_inserter_data.
    - exact functor_to_cat_iso_inserter_is_functor.
  Defined.

  Definition functor_to_cat_iso_inserter_pr1
    : functor_to_cat_iso_inserter ∙ cat_iso_inserter_pr1 F G ⟹ H.
  Proof.
    use make_nat_trans.
    - exact (λ x, identity _).
    - abstract
        (intros x y f ; cbn ;
         rewrite id_left, id_right ;
         apply idpath).
  Defined.

  Definition functor_to_cat_iso_inserter_pr1_nat_z_iso
    : nat_z_iso
        (functor_to_cat_iso_inserter ∙ cat_iso_inserter_pr1 F G)
        H.
  Proof.
    use make_nat_z_iso.
    - exact functor_to_cat_iso_inserter_pr1.
    - intro x.
      apply is_z_isomorphism_identity.
  Defined.
End CatIsoInserterFunctor.

Definition nat_trans_to_cat_iso_inserter
           {C₁ C₂ C₃ : category}
           {F G : C₂ ⟶ C₃}
           {H₁ H₂ : C₁ ⟶ cat_iso_inserter F G}
           (α : H₁ ∙ cat_iso_inserter_pr1 F G ⟹ H₂ ∙ cat_iso_inserter_pr1 F G)
           (p : ∏ (x : C₁), pr12 (H₁ x) · # G (α x) = # F (α x) · pr12 (H₂ x))
  : H₁ ⟹ H₂.
Proof.
  use make_nat_trans.
  - exact (λ x, α x ,, p x).
  - abstract
      (intros x y f ;
       use eq_cat_iso_inserter ; cbn ;
       exact (nat_trans_ax α _ _ f)).
Defined.