(**************************************************************************
* TLC: A library for Coq                                                  *
* MultiSets -- PROTOTYPE                                                  *
**************************************************************************)

(** FILE UNDER CONSTRUCTION *)

Set Implicit Arguments.
Generalizable Variables A B.
Require Import LibTactics LibLogic LibReflect
  LibRelation LibList LibInt LibNat LibOperation
  LibEpsilon LibSet LibStruct.
Require Export LibBag.

(* ********************************************************************** *)
(** * Construction of sets as predicates *)

(* ---------------------------------------------------------------------- *)
(** ** Basic definitions *)

Definition multiset (A : Type) := A -> nat.

Section Operations.
Variables (A B : Type).
Implicit Types x : A.
Implicit Types E F G : multiset A.

Definition empty_impl : multiset A := fun _ => 0.
Definition single_impl x := fun y => If x = y then 1 else 0.
Definition in_impl x E := E x > 0.
Definition union_impl E F := fun x => (E x + F x)%nat.
Definition incl_impl E F := forall x, E x <= F x.
Definition dom_impl E := set_st (fun x => E x > 0).
(* TODO: update these definitions to match those of finite sets *)
Definition list_repr_impl (E:multiset A) (l:list (A*nat)) :=
     No_duplicates (LibList.map (@fst _ _) l)
  /\ forall n x, In (x,n) l <-> (n = E x /\ n > 0).
Definition to_list_impl (E:multiset A) := epsilon (list_repr_impl E).
Definition fold_impl (m:monoid_def B) (f:A->nat->B) (E:multiset A) :=
  LibList.fold_right (fun p acc => let (x,n) := p : A*nat in monoid_oper m (f x n) acc)
    (monoid_neutral m) (to_list_impl E).
End Operations.
Definition card_impl A (E:multiset A) :=
  fold_impl (monoid_ plus 0) (fun _ n => n) E.

(* ---------------------------------------------------------------------- *)
(** ** Notation through typeclasses *)

Lemma in_inst : forall A, BagIn A (multiset A).
Proof using. constructor. exact (@in_impl A). Defined.
Hint Extern 1 (BagIn _ (multiset _)) => apply in_inst
  : typeclass_instances.

Instance empty_inst : forall A, BagEmpty (multiset A).
  constructor. rapply (@empty_impl A). Defined.
Instance single_inst : forall A, BagSingle A (multiset A) .
  constructor. rapply (@single_impl A). Defined.
Instance union_inst : forall A, BagUnion (multiset A).
  constructor. rapply (@union_impl A). Defined.
Instance incl_inst : forall A, BagIncl (multiset A).
  constructor. rapply (@incl_impl A). Defined.
Instance fold_inst : forall A B, BagFold B (A->nat->B) (multiset A).
  constructor. rapply (@fold_impl A B). Defined.
Instance card_inst : forall A, BagCard (multiset A).
  constructor. rapply (@card_impl A). Defined.

Global Opaque multiset empty_inst single_inst in_inst
 union_inst incl_inst fold_inst card_inst.

Instance multiset_inhab : forall A, Inhab (multiset A).
Proof using. intros. apply (prove_Inhab (@empty_impl A)). Qed.

(* ********************************************************************** *)
(** * Properties of multisets *)

(* ---------------------------------------------------------------------- *)
(** ** Structural properties *)

Section Instances.
Variables (A:Type).
Hint Extern 1 False => math.
Hint Extern 1 (_ > _) => solve [ math | false ].
Hint Extern 1 (_ = _) => math.

Transparent multiset empty_inst single_inst in_inst
 union_inst incl_inst fold_inst card_inst.

Global Instance in_empty_eq_inst : In_empty_eq (A:=A) (T:=multiset A).
Proof using.
  constructor. intros. extens. simpl.
  unfold empty_impl, in_impl. autos*.
Qed.

Global Instance in_single_eq_inst : In_single_eq (A:=A) (T:=multiset A).
Proof using.
  constructor. intros. extens. simpl.
  unfold single_impl, in_impl. case_if*.
Qed.

Global Instance in_union_eq_inst : In_union_eq (A:=A) (T:=multiset A).
Proof using.
  constructor. intros. extens. simpl.
  unfold single_impl, union_impl, in_impl.
  iff. tests: (E x = 0). right~. left~. destruct H; math.
Qed.

Global Instance incl_inv_inst : Incl_inv (A:=A) (T:=multiset A).
Proof using.
  constructor. intros x. introv M N.
  unfold incl_inst, incl_impl,incl, in_inst, in_impl, is_in in *.
  specializes M x. math.
Qed.

Global Instance union_empty_inv_inst : Union_empty_inv (T:=multiset A).
Proof using.
  constructor. introv.
  unfold union_inst, union_impl, union, empty_impl,
   empty_inst, empty, empty_impl, multiset. introv N.
  split; extens~.
  intros x. lets: func_same_1 x N. math.
  intros x. lets: func_same_1 x N. math.
Qed.

Global Instance union_empty_l_eq_inst : Union_empty_l (T:=multiset A).
Proof using.
  constructor. intros_all. simpl.
  unfold union_impl, empty_impl, multiset. simpl. extens~.
Qed.

Global Instance union_comm_eq_inst : Union_comm (T:=multiset A).
Proof using.
  constructor. intros_all. simpl.
  unfold union_impl, multiset. simpl. extens~.
Qed.

Global Instance union_assoc_eq_inst : Union_assoc (T:=multiset A).
Proof using.
  constructor. intros_all. simpl.
  unfold union_impl, multiset. simpl. extens~.
Qed.

Global Instance empty_incl_inst : Empty_incl (T:=multiset A).
Proof using.
  constructor. intros_all. simpl.
  unfold empty_impl, multiset. math.
Qed.

Global Instance card_empty_inst : Card_empty (T:=multiset A).
Proof using. admit. (*TODO: under construction *) Qed.

Global Instance card_single_inst : Card_single (A:=A) (T:=multiset A).
Proof using. admit. (*TODO: under construction *) Qed.

Global Instance card_union_le_inst : Card_union_le (T:=multiset A).
Proof using. admit. (*TODO: under construction *) Qed.

End Instances.

(* ********************************************************************** *)
(** * Additional predicates *)

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

Section ForeachProp.
Variables (A : Type).
Implicit Types P Q : A -> Prop.
Implicit Types E F : multiset A.

Lemma foreach_empty : forall P,
  @foreach A (multiset A) _ P \{}.
Proof using. intros_all. rewrite in_empty_eq in H. false. Qed.

Lemma foreach_single : forall P X,
  P X -> @foreach A (multiset A) _ P (\{ X }).
Proof using. intros_all. rewrite in_single_eq in H0. subst*. Qed.

Lemma foreach_union : forall P E F,
  foreach P E -> foreach P F -> foreach P (E \u F).
Proof using. intros_all. destruct~ (in_union_inv H1). Qed.

Hint Resolve foreach_empty foreach_single foreach_union.

Lemma foreach_union_inv : forall P E F,
  foreach P (E \u F) -> foreach P E /\ foreach P F.
Proof using.
  introv H. split; introv K.
  apply H. rewrite~ @in_union_eq. typeclass.
  apply H. rewrite~ @in_union_eq. typeclass.
Qed.

Lemma foreach_union_eq : forall P E F,
  foreach P (E \u F) = (foreach P E /\ foreach P F).
Proof using.
  intros. extens. iff.
  apply~ foreach_union_inv. apply* foreach_union.
Qed.

Lemma foreach_single_eq : forall P X,
  foreach P (\{X}:multiset A) = P X.
Proof using.
  intros. extens. iff.
  apply H. apply in_single_self.
  apply~ foreach_single.
Qed.

Lemma foreach_weaken : forall P Q E,
  foreach P E -> pred_le P Q -> foreach Q E.
Proof using. introv H L K. apply~ L. Qed.

End ForeachProp.

Hint Resolve foreach_empty foreach_single foreach_union.

Hint Rewrite foreach_union_eq : rew_foreach.
Tactic Notation "rew_foreach" hyp(H) := autorewrite with rew_foreach in H.
Tactic Notation "rew_foreach" := autorewrite with rew_foreach.

Tactic Notation "rew_foreach" "~" constr(H) :=
  rew_foreach H; auto_tilde.
Tactic Notation "rew_foreach" "*" constr(H) :=
  rew_foreach H; auto_star.

(* ********************************************************************** *)
(** * Tactics *)

(* ---------------------------------------------------------------------- *)
(** ** Tactics to prove equalities on unions *)

(* todo: doc *)

Lemma for_multiset_union_assoc : forall A, assoc (union (T:=multiset A)).
Proof using. intros. apply union_assoc. Qed.

Lemma for_multiset_union_comm : forall A, comm (union (T:=multiset A)).
Proof using. intros. apply union_comm. Qed.

Lemma for_multiset_union_empty_l : forall A (E:multiset A), \{} \u E = E.
Proof using. intros. apply union_empty_l. Qed.

Lemma for_multiset_union_empty_r : forall A (E:multiset A), E \u \{} = E.
Proof using. intros. apply union_empty_r. Qed.

Lemma for_multiset_empty_incl : forall A (E:multiset A), \{} \c E.
Proof using. intros. apply empty_incl. Qed.

Hint Rewrite <- for_multiset_union_assoc : rew_permut_simpl.
Hint Rewrite for_multiset_union_empty_l for_multiset_union_empty_r : rew_permut_simpl.
Ltac rew_permut_simpl :=
  autorewrite with rew_permut_simpl.
Ltac rews_permut_simpl :=
  autorewrite with rew_permut_simpl in *.

Section PermutationTactic.
Context (A:Type).
Implicit Types l : multiset A.

Lemma permut_get_1 : forall l1 l2,
  (l1 \u l2) = (l1 \u l2).
Proof using. intros. auto. Qed.

Lemma permut_get_2 : forall l1 l2 l3,
  (l1 \u l2 \u l3) = (l2 \u l1 \u l3).
Proof using. intros. apply union_comm_assoc. Qed.
(* rewrite (union_comm _ l1). auto. Qed. *)

Lemma permut_get_3 : forall l1 l2 l3 l4,
  (l1 \u l2 \u l3 \u l4) = (l2 \u l3 \u l1 \u l4).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_2.
Qed.

Lemma permut_get_4 : forall l1 l2 l3 l4 l5,
    (l1 \u l2 \u l3 \u l4 \u l5)
  = (l2 \u l3 \u l4 \u l1 \u l5).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_3.
Qed.

Lemma permut_get_5 : forall l1 l2 l3 l4 l5 l6,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6)
  = (l2 \u l3 \u l4 \u l5 \u l1 \u l6).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_4.
Qed.

Lemma permut_get_6 : forall l1 l2 l3 l4 l5 l6 l7,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6 \u l7)
  = (l2 \u l3 \u l4 \u l5 \u l6 \u l1 \u l7).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_5.
Qed.

Lemma permut_get_7 : forall l1 l2 l3 l4 l5 l6 l7 l8,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l8)
  = (l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l1 \u l8).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_6.
Qed.

Lemma permut_get_8 : forall l1 l2 l3 l4 l5 l6 l7 l8 l9,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l8 \u l9)
  = (l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l8 \u l1 \u l9).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_7.
Qed.

Lemma permut_tactic_setup : forall C l1 l2,
   C (\{} \u l1 \u \{}) (l2 \u \{}) -> C l1 l2.
Proof using. intros. rews_permut_simpl. eauto. Qed.

Lemma permut_tactic_keep : forall C l1 l2 l3 l4,
  C ((l1 \u l2) \u l3) l4 ->
  C (l1 \u (l2 \u l3)) l4.
Proof using. intros. rews_permut_simpl. eauto. Qed.

Lemma permut_tactic_trans : forall C l1 l2 l3,
  l3 = l2 -> C l1 l3 -> C l1 l2.
Proof using. intros. subst~. Qed.

End PermutationTactic.

(** [permut_lemma_get n] returns the lemma [permut_get_n]
    for the given value of [n] *)

Ltac permut_lemma_get n :=
  match nat_from_number n with
  | 1%nat => constr:(permut_get_1)
  | 2%nat => constr:(permut_get_2)
  | 3%nat => constr:(permut_get_3)
  | 4%nat => constr:(permut_get_4)
  | 5%nat => constr:(permut_get_5)
  | 6%nat => constr:(permut_get_6)
  | 7%nat => constr:(permut_get_7)
  | 8%nat => constr:(permut_get_8)
  end.

(** [permut_prepare] applies to a goal of the form [permut l l']
    and sets [l] and [l'] in the form [l1 \u l2 \u .. \u \{}],
    (some of the lists [li] are put in the form [x::\{}]). *)

Ltac permut_simpl_prepare :=
   rew_permut_simpl;
   apply permut_tactic_setup;
   repeat rewrite <- union_assoc.

(* todo : doc *)

Ltac permut_index_of l lcontainer :=
  match constr:(lcontainer) with
  | l \u _ => constr:(1)
  | _ \u l \u _ => constr:(2)
  | _ \u _ \u l \u _ => constr:(3)
  | _ \u _ \u _ \u l \u _ => constr:(4)
  | _ \u _ \u _ \u _ \u l \u _ => constr:(5)
  | _ \u _ \u _ \u _ \u _ \u l \u _ => constr:(6)
  | _ \u _ \u _ \u _ \u _ \u _ \u l \u _ => constr:(7)
  | _ \u _ \u _ \u _ \u _ \u _ \u _ \u l \u _ => constr:(8)
  | _ => constr:(0) (* not found *)
  end.

(** [permut_simplify] simplifies a goal of the form
    [permut l l'] where [l] and [l'] are lists built with
    concatenation and consing *)

Ltac permut_simpl_once_for permut_tactic_simpl :=
  let go l0 l' :=
    match l0 with
    | _ \u \{} => fail 1
    | _ \u (?l \u ?lr) =>
      match permut_index_of l l' with
      | 0 => apply permut_tactic_keep
      | ?n => let F := permut_lemma_get n in
             eapply permut_tactic_trans;
             [ eapply F; try typeclass
             | apply permut_tactic_simpl ]
      end
     end in
   match goal with
   | |- _ ?x ?y => go x y
   | |- _ _ ?x ?y => go x y
   | |- _ _ _ ?x ?y => go x y
   | |- _ _ _ _ ?x ?y => go x y
   end.

Ltac permut_conclude :=
  first [ apply refl_equal
        | apply for_multiset_empty_incl ].

Ltac permut_simpl_for permut_tactic_simpl :=
  permut_simpl_prepare;
  repeat permut_simpl_once_for permut_tactic_simpl;
  rew_permut_simpl;
  try permut_conclude.

Lemma permut_tactic_simpl_eq : forall A (l1 l2 l3 l4:multiset A),
  (l1 \u l3) = l4 ->
  (l1 \u (l2 \u l3)) = (l2 \u l4).
Proof using. intros. subst. apply permut_get_2. Qed.

Lemma permut_tactic_simpl_incl : forall A (l1 l2 l3 l4:multiset A),
  (l1 \u l3) \c l4 ->
  (l1 \u (l2 \u l3)) \c (l2 \u l4).
Admitted. (* todo: reason on this tedious inclusion... *)

Ltac get_premut_tactic_simpl tt :=
  match goal with
  | |- ?x = ?y => constr:(permut_tactic_simpl_eq)
  | |- ?x \c ?y => constr:(permut_tactic_simpl_incl)
  end.

Ltac permut_simpl_once :=
  let L := get_premut_tactic_simpl tt in permut_simpl_once_for L.

Ltac permut_simpl :=
  let L := get_premut_tactic_simpl tt in permut_simpl_for L.

Tactic Notation "multiset_eq" :=
  permut_simpl.

Section DemoSetUnion.
Variables (A:Type).
Implicit Types l : multiset A.

Lemma demo_multiset_union_permut_simpl_1 :
  forall l1 l2 l3 : multiset A,
  (l1 \u l2 \u l3) = (l3 \u l2 \u l1).
Proof using.
  intros.
  permut_simpl_prepare.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  rew_permut_simpl.
  permut_conclude.
Qed.

Lemma demo_multiset_union_permut_simpl_2 :
  forall
  (x:A) l1 l2 l3 l4,
  (l1 \u \{x} \u l3 \u l2) \c (l1 \u l2 \u l4 \u (\{x} \u l3)).
Proof using.
  intros.
  permut_simpl_prepare.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  rew_permut_simpl.
  permut_conclude.
Qed.

Lemma demo_multiset_union_permut_simpl_3 : forall (x y:A) l1 l1' l2 l3 l4,
  l1 \c l4 \u l1' ->
  (l1 \u (\{x} \u l2) \u \{x} \u (\{y} \u l3)) \c
  (\{y} \u \{x} \u (l1' \u l2 \u l4) \u (\{x} \u l3)).
Proof using.
  intros. dup.
  (* details *)
  permut_simpl_prepare.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  try permut_simpl_once.
  rew_permut_simpl.
  equates 1. apply H.
  permut_simpl_prepare.
  permut_simpl_once.
  rew_permut_simpl.
  permut_conclude.
  (* short *)
  permut_simpl. applys_eq H 1. permut_simpl.
Qed.

End DemoSetUnion.

(* ---------------------------------------------------------------------- *)
(** ** Tactics to prove membership *)

Section InUnionGet.
Variables (A:Type).
Implicit Types l : multiset A.

Lemma in_union_get_1 : forall x l1 l2,
  x \in l1 -> x \in (l1 \u l2).
Proof using. intros. apply in_union_l. auto. Qed.

Lemma in_union_get_2 : forall x l1 l2 l3,
  x \in l2 -> x \in (l1 \u l2 \u l3).
Proof using. intros. apply in_union_r. apply~ in_union_get_1. Qed.

Lemma in_union_get_3 : forall x l1 l2 l3 l4,
  x \in l3 -> x \in (l1 \u l2 \u l3 \u l4).
Proof using. intros. apply in_union_r. apply~ in_union_get_2. Qed.

Lemma in_union_get_4 : forall x l1 l2 l3 l4 l5,
  x \in l4 -> x \in (l1 \u l2 \u l3 \u l4 \u l5).
Proof using. intros. apply in_union_r. apply~ in_union_get_3. Qed.

Lemma in_union_get_5 : forall x l1 l2 l3 l4 l5 l6,
  x \in l5 -> x \in (l1 \u l2 \u l3 \u l4 \u l5 \u l6).
Proof using. intros. apply in_union_r. apply~ in_union_get_4. Qed.

End InUnionGet.

Implicit Arguments in_union_get_1 [A x l1 l2].
Implicit Arguments in_union_get_2 [A x l1 l2 l3].
Implicit Arguments in_union_get_3 [A x l1 l2 l3 l4].
Implicit Arguments in_union_get_4 [A x l1 l2 l3 l4 l5].
Implicit Arguments in_union_get_5 [A x l1 l2 l3 l4 l5 l6].

(** [in_union_get] solves a goal of the form
    [x \in F1 \u ... \u FN] when there exists an
    hypothesis of the form [x \in Fi] for some [i]. *)

Ltac in_union_get :=
  match goal with H: ?x \in ?A |- ?x \in ?B =>
  match B with context [A] =>
  let go tt := first
        [ apply (in_union_get_1 H)
        | apply (in_union_get_2 H)
        | apply (in_union_get_3 H)
        | apply (in_union_get_4 H)
        | apply (in_union_get_5 H) ] in
  first [ go tt
        | rewrite <- (for_multiset_union_empty_r B);
          repeat rewrite <- for_multiset_union_assoc;
          go tt ]
  end end.

(* todo: remove hint
Hint Extern 3 (_ \in _ \u _) => in_union_get.
*)

Section InUnionExtract.
Variables (A:Type).
Implicit Types l : multiset A.

Lemma in_union_extract_1 : forall x l1,
  x \in (\{x} \u l1).
Proof using. intros. apply in_union_get_1. apply in_single_self. Qed.

Lemma in_union_extract_2 : forall x l1 l2,
  x \in (l1 \u \{x} \u l2).
Proof using. intros. apply in_union_get_2. apply in_single_self. Qed.

Lemma in_union_extract_3 : forall x l1 l2 l3,
  x \in (l1 \u l2 \u \{x} \u l3).
Proof using. intros. apply in_union_get_3. apply in_single_self. Qed.

Lemma in_union_extract_4 : forall x l1 l2 l3 l4,
  x \in (l1 \u l2 \u l3 \u \{x} \u l4).
Proof using. intros. apply in_union_get_4. apply in_single_self. Qed.

Lemma in_union_extract_5 : forall x l1 l2 l3 l4 l5,
  x \in (l1 \u l2 \u l3 \u l4 \u \{x} \u l5).
Proof using. intros. apply in_union_get_5. apply in_single_self. Qed.

End InUnionExtract.

(** [in_union_extract] solves a goal of the form
    [x \in F1 \u ... \u \{x} \u ... \u FN]. *)

Ltac in_union_extract :=
  match goal with |- ?x \in ?A =>
  match A with context [\{x}] =>
  let go tt := first
        [ apply (in_union_extract_1)
        | apply (in_union_extract_2)
        | apply (in_union_extract_3)
        | apply (in_union_extract_4)
        | apply (in_union_extract_5) ] in
  first [ go tt
        | rewrite <- (for_multiset_union_empty_r A);
          repeat rewrite <- for_multiset_union_assoc;
          go tt ]
  end end.

Tactic Notation "multiset_in" :=
   first [ in_union_extract | in_union_get ].

(* ---------------------------------------------------------------------- *)
(** ** Tactics to invert a membership hypothesis *)

Section InversionsTactic.
Context (A:Type).
Implicit Types l : multiset A.
Implicit Types x : A.
Lemma empty_eq_single_inv_1 : forall x l1 l2,
  l1 = l2 -> x \notin l1 -> x \in l2 -> False.
Proof using. intros. subst*. Qed.
Lemma empty_eq_single_inv_2 : forall x l1 l2,
  l1 = l2 -> x \notin l2 -> x \in l1 -> False.
Proof using. intros. subst*. Qed.
Lemma notin_empty : forall x,
  x \notin (\{}:multiset A).
Proof using. intros. unfold notin. rewrite in_empty_eq. auto. Qed.
End InversionsTactic.
Hint Resolve notin_empty.

Ltac in_union_meta :=
  match goal with
  | |- _ \in \{_} => apply in_single_self
  | |- _ \in \{_} \u _ => apply in_union_l; apply in_single_self
  | |- _ \in _ \u _ => apply in_union_r; in_union_meta
  end.

Ltac fseq_inv_core H :=
  let go L :=
     false L; [ apply H
              | try apply notin_empty
              | instantiate; try in_union_meta ] in
  match type of H with
  | \{} = _ => go empty_eq_single_inv_1
  | _ = \{} => go empty_eq_single_inv_2
  | _ = _ => go empty_eq_single_inv_1
  end.

(** [multiset_inv H] solves a goal by contraction if
    there exists an hypothesis of the form
    [\{} = E1 \u ... \u \{x} \u ... \u EN]
    (or its symmetric).
    [multiset_inv] speculates on the hypothesis [H] to
    be used. *)

Tactic Notation "multiset_inv" constr(H) :=
  fseq_inv_core H.

Tactic Notation "multiset_inv" :=
  match goal with
  | |- \{} <> _ => let H := fresh in intro H; multiset_inv H
  | |- _ <> \{} => let H := fresh in intro H; multiset_inv H
  | H: \{} = _ |- _ => multiset_inv H
  | H: _ = \{} |- _ => multiset_inv H
  end.

Section InUnionInv.
Variables (A:Type).
Implicit Types l : multiset A.

Lemma in_empty_inv : forall x,
  x \in (\{}:multiset A) -> False.
Proof using. introv. apply notin_empty. Qed.

Lemma in_single_inv : forall x y : A,
  x \in (\{y}:multiset A) -> x = y.
Proof using. intros. rewrite @in_single_eq in H. auto. typeclass. Qed.

Lemma in_union_inv : forall x l1 l2,
  x \in (l1 \u l2) -> x \in l1 \/ x \in l2.
Proof using. introv H. rewrite @in_union_eq in H. auto. typeclass. Qed.

End InUnionInv.

Implicit Arguments in_single_inv [A x y].
Implicit Arguments in_union_inv [A x l1 l2].

Ltac multiset_in_inv_base H M :=
  match type of H with
  | _ \in \{} => false; apply (@in_empty_inv _ _ H)
  | _ \in \{_} =>
    generalize (in_single_inv H); try clear H; try intro_subst_hyp
  | _ \in _ \u _ =>
    let H' := fresh "TEMP" in
    destruct (in_union_inv H) as [H'|H'];
    try clear H; multiset_in_inv_base H' M
  | _ => rename H into M
  end.

Tactic Notation "multiset_in" constr(H) "as" ident(M) :=
  multiset_in_inv_base H M.
Tactic Notation "multiset_in" constr(H) :=
  let M := fresh "H" in multiset_in H as M.

Lemma union_empty_inv_multiset : forall A (l1 l2:multiset A),
  l1 \u l2 = \{} -> l1 = \{} /\ l2 = \{}.
Proof using. intros. eapply union_empty_inv_inst. eauto. Qed.

Implicit Arguments union_empty_inv_multiset [A l1 l2].

Ltac multiset_empty_core H :=
  match type of H with
  | _ \u _ = \{} =>
     let H1 := fresh "M" in let H2 := fresh "M" in
     destruct (union_empty_inv_multiset H) as [H1 H2]; clear H;
     multiset_empty_core H1; multiset_empty_core H2
  | ?E = \{} => try subst E; try solve [ false ]
  | \{} = _ \u _ => symmetry in H; multiset_empty_core H
  | \{} = ?E => symmetry in H; multiset_empty_core H
  end.

Tactic Notation "multiset_empty" "in" hyp(H) :=
  multiset_empty_core H.
Tactic Notation "multiset_empty" :=
  let H := fresh "M" in intro H; multiset_empty in H.
Tactic Notation "multiset_empty" constr(E) :=
  let H := fresh "M" in lets H:E; multiset_empty in H.


Require Import Coq.Lists.List.

Class ElemOf (A B: Type) := elemOf: A -> B -> Prop.
Class Blob (A B: Type) := blob: A -> B -> A.

Instance elemOf_list {A} : ElemOf A (list A) := @In A.

Inductive union (A B: Type) := union_ : A -> B -> union A B.

Notation "A ∪ B" := (union_ _ _ A B) (at level 60, right associativity).
Notation "A ∈ B" := (elemOf A B) (at level 70).
Notation "A ∘ B" := (blob A B) (at level 60).

Instance elemOf_union {A B C: Type} {_: ElemOf A B} {_: ElemOf A C}: ElemOf A (union B C) :=
  fun a u => match u with union_ _ _ b c => a ∈ b \/ a ∈ c end.


Require Import
  HoTT.Classes.interfaces.abstract_algebra.

(** If [B] is a (bounded) lattice, then so is [A -> B], pointwise.
    This relies on functional extensionality. *)
Section contents.
  Context `{Funext}.

  Context {A B : Type}.
  Context `{BJoin : Join B}.
  Context `{BMeet : Meet B}.
  Context `{BBottom : Bottom B}.
  Context `{BTop : Top B}.

  Global Instance bot_fun : Bottom (A -> B)
    := fun _ => ⊥.

  Global Instance top_fun : Top (A -> B)
    := fun _ => ⊤.

  Global Instance join_fun : Join (A -> B) :=
    fun (f g : A -> B) (a : A) => (f a) ⊔ (g a).

  Global Instance meet_fun : Meet (A -> B) :=
    fun (f g : A -> B) (a : A) => (f a) ⊓ (g a).

  (** Try to solve some of the lattice obligations automatically *)
  Create HintDb lattice_hints.
  Hint Resolve
       associativity
       absorption
       commutativity | 1 : lattice_hints.
  Local Ltac reduce_fun := compute; intros; apply path_forall; intro.
  Local Ltac try_solve_fun :=
    reduce_fun;
    eauto 10 with lattice_hints typeclass_instances.

  Global Instance lattice_fun `{!IsLattice B} : IsLattice (A -> B).
  Proof.
    repeat split; try apply _; try_solve_fun.
    * apply binary_idempotent.
    * apply binary_idempotent.
  Defined.

  Instance boundedjoinsemilattice_fun
   `{!IsBoundedJoinSemiLattice B} :
    IsBoundedJoinSemiLattice (A -> B).
  Proof.
    repeat split; try apply _; try_solve_fun.
    * apply left_identity.
    * apply right_identity.
    * apply commutativity.
    * apply binary_idempotent.
  Defined.

  Instance boundedmeetsemilattice_fun
   `{!IsBoundedMeetSemiLattice B} :
    IsBoundedMeetSemiLattice (A -> B).
  Proof.
    repeat split; try apply _; reduce_fun.
    * apply associativity.
    * apply left_identity.
    * apply right_identity.
    * apply commutativity.
    * apply binary_idempotent.
  Defined.

  Global Instance boundedlattice_fun
   `{!IsBoundedLattice B} : IsBoundedLattice (A -> B).
  Proof.
    repeat split; try apply _; reduce_fun; apply absorption.
  Defined.
End contents.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.arrival_sequence rt.model.arrival.basic.task rt.model.arrival.basic.job.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq path.

(* Properties of job arrival. *)
Module TaskArrival.

  Import ArrivalSequence SporadicTaskset.

  Section ArrivalModels.

    Context {Task: eqType}.
    Variable task_period: Task -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_task: Job -> Task.

    (* Consider any job arrival sequence. *)
    Variable arr_seq: arrival_sequence Job.

    (* Then, we define the sporadic task model as follows.*)
    Definition sporadic_task_model :=
      forall (j j': Job),
        j <> j' -> (* Given two different jobs j and j' ... *)
        arrives_in arr_seq j -> (* ...that belong to the arrival sequence... *)
        arrives_in arr_seq j' ->
        job_task j = job_task j' -> (* ... and that are spawned by the same task, ... *)
        job_arrival j <= job_arrival j' -> (* ... if the arrival of j precedes the arrival of j' ...,  *)
        (* then the arrival of j and the arrival of j' are separated by at least one period. *)
        job_arrival j' >= job_arrival j + task_period (job_task j).

  End ArrivalModels.

  Section NumberOfArrivals.

    Context {Task: eqType}.
    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_task: Job -> Task.

    (* Consider any job arrival sequence ...*)
    Variable arr_seq: arrival_sequence Job.

    (* ...and recall the list of jobs that arrive in any interval. *)
    Let arrivals_between := jobs_arrived_between arr_seq.

    (* Let tsk be any task. *)
    Variable tsk: Task.

    (* By checking the task that spawns each job, ...*)
    Definition is_job_of_task (j: Job) := job_task j == tsk.

    (* ...we can identify the jobs of tsk that arrived in any interval [t1, t2) ... *)
    Definition arrivals_of_task_between (t1 t2: time) :=
      [seq j <- arrivals_between t1 t2 | is_job_of_task j].

    (* ...and also count the number of job arrivals. *)
    Definition num_arrivals_of_task (t1 t2: time) :=
      size (arrivals_of_task_between t1 t2).

  End NumberOfArrivals.

  (* In this section, we prove some basic results regarding the
     distance between sporadically released jobs. *)
  Section DistanceBetweenSporadicJobs.

    Context {Task: eqType}.
    Variable task_period: Task -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_task: Job -> Task.

    (* Consider any arrival sequence with consistent, non-duplicate arrivals, ... *)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_consistent_arrivals: arrival_times_are_consistent job_arrival arr_seq.
    Hypothesis H_no_duplicate_arrivals: arrival_sequence_is_a_set arr_seq.

    (* ...where jobs follow the sporadic task model. *)
    Hypothesis H_sporadic_jobs:
      sporadic_task_model task_period job_arrival job_task arr_seq.

    (* Let tsk be any task to be scheduled. *)
    Variable tsk: Task.

    (* Consider any time interval [t1, t2). *)
    Variable t1 t2: time.

    (* Recall the jobs of tsk during [t1, t2), along with the number of arrivals. *)
    Let arriving_jobs := arrivals_of_task_between job_task arr_seq tsk t1 t2.
    Let num_arrivals := num_arrivals_of_task job_task arr_seq tsk t1 t2.

    (* Consider the sequence of jobs ordered by arrival times. *)
    Let by_arrival_time (j j': Job) := job_arrival j <= job_arrival j'.
    Let sorted_jobs := sort by_arrival_time arriving_jobs.

    (* Let (nth_job i) denote the i-th job in the sorted sequence. *)
    Variable elem: Job.
    Let nth_job := nth elem sorted_jobs.

    (* First, we recall some trivial properties about nth_job. *)
    Remark sorted_arrivals_properties_of_nth:
      forall idx,
        idx < num_arrivals ->
        t1 <= job_arrival (nth_job idx) < t2 /\
        job_task (nth_job idx) = tsk /\
        arrives_in arr_seq (nth_job idx).
    Proof.
      rename H_consistent_arrivals into CONS.
      intros idx LTidx.
      have IN: nth_job idx \in sorted_jobs by rewrite mem_nth // size_sort.
      rewrite mem_sort mem_filter in IN.
      move: IN => /andP [JOB IN]; move: (IN) => LT.
      apply in_arrivals_implies_arrived in IN.
      eapply in_arrivals_implies_arrived_between in LT; last by eauto.
      by repeat split; try (by done); apply/eqP.
    Qed.

    (* Next, we conclude that consecutive jobs are different. *)
    Lemma sorted_arrivals_current_differs_from_next:
      forall idx,
        idx < num_arrivals.-1 ->
        nth_job idx <> nth_job idx.+1.
    Proof.
      intros idx LT; apply/eqP.
      destruct num_arrivals eqn:EQ; first by rewrite ltn0 in LT.
      destruct n; [by rewrite ltn0 in LT | simpl in LT].
      rewrite nth_uniq ?size_sort /arriving_jobs
              -/(num_arrivals_of_task _ _ _ _ _) -/num_arrivals;
        first by rewrite neq_ltn ltnSn orTb.
      - by apply leq_trans with (n := n.+1); last by rewrite EQ.
      - by rewrite EQ ltnS.
      - by rewrite sort_uniq filter_uniq //; eapply arrivals_uniq; eauto 1.
    Qed.

    (* Since the list is sorted, we prove that each job arrives at
       least (task_period tsk) time units after the previous job. *)
    Lemma sorted_arrivals_separated_by_period:
      forall idx,
        idx < num_arrivals.-1 ->
        job_arrival (nth_job idx.+1) >= job_arrival (nth_job idx) + task_period tsk.
    Proof.
      have NTH := sorted_arrivals_properties_of_nth.
      have NEQ := sorted_arrivals_current_differs_from_next.
      rename H_sporadic_jobs into SPO.
      intros idx LT.
      destruct num_arrivals eqn:EQ; first by rewrite ltn0 in LT.
      destruct n; [by rewrite ltn0 in LT | simpl in LT].
      exploit (NTH idx);
        [by apply leq_trans with (n := n.+1) | intro NTH1].
      exploit (NTH idx.+1); [by rewrite ltnS | intro NTH2].
      move: NTH1 NTH2 => [_ [JOB1 ARR1]] [_ [JOB2 ARR2]].
      rewrite -JOB1.
      apply SPO; try (by done); [by apply NEQ | by rewrite JOB1 JOB2 |].
      suff ORDERED: by_arrival_time (nth_job idx) (nth_job idx.+1) by done.
      apply sort_ordered;
        first by apply sort_sorted; intros x y; apply leq_total.
      rewrite size_sort.
      rewrite /arriving_jobs -/(num_arrivals_of_task _ _ _ _ _) -/num_arrivals.
      by rewrite EQ.
    Qed.

    (* If the list of arrivals is not empty, we analyze the distance between
       the first and last jobs. *)
    Section FirstAndLastJobs.

      (* Suppose that there is at least one job, ... *)
      Hypothesis H_at_least_one_job:
        num_arrivals >= 1.

      (* ...in which case we identify the first and last jobs and their
         respective arrival times (note that they could be the same job). *)
      Let j_first := nth_job 0.
      Let j_last := nth_job (num_arrivals.-1).
      Let a_first := job_arrival j_first.
      Let a_last := job_arrival j_last.

      (* By induction, we prove that that each job with index 'idx' arrives at
         least idx*(task_period tsk) units after the first job. *)
      Lemma sorted_arrivals_distance_from_first_job:
        forall idx,
          idx < num_arrivals ->
          job_arrival (nth_job idx) >= a_first + idx * task_period tsk.
      Proof.
        have SEP := sorted_arrivals_separated_by_period.
        unfold sporadic_task_model in *.
        rename H_sporadic_jobs into SPO.
        induction idx; first by intros _; rewrite mul0n addn0.
        intros LT.
        have LT': idx < num_arrivals by apply leq_ltn_trans with (n := idx.+1).
        specialize (IHidx LT').
        apply leq_trans with (n := job_arrival (nth_job idx) + task_period tsk);
          first by rewrite mulSn [task_period _ + _]addnC addnA leq_add2r.
        apply SEP.
        by rewrite -(ltn_add2r 1) 2!addn1 (ltn_predK LT).
      Qed.

      (* Therefore, the first and last jobs are separated by at least
         (num_arrivals - 1) periods. *)
      Corollary sorted_arrivals_distance_between_first_and_last:
        a_last >= a_first + (num_arrivals-1) * task_period tsk.
      Proof.
        rename H_at_least_one_job into TWO.
        have DIST := sorted_arrivals_distance_from_first_job.
        rewrite subn1; apply DIST.
        by destruct num_arrivals; first by rewrite ltn0 in TWO.
      Qed.

    End FirstAndLastJobs.

  End DistanceBetweenSporadicJobs.

End TaskArrival.


From Chapter9 Require Export wn.

(** ** Schäfer's Expression Relation *)

Inductive E_strong' {m} (L_A : tm m -> Prop) (s : tm m) :  Prop :=
 | E_strong_In  : (value s -> L_A s) -> (forall s', step s s' -> E_strong' L_A s') -> E_strong' L_A s.

(** Logical relation for lambda expressions *)
Fixpoint L_strong {m} (A : ty): tm m -> Prop :=
  match A with
  | Base => fun _ => True
  | Fun A1 A2 => fun e => match e with
                      |  (lam B s) => forall k (xi: fin m -> fin k) v, E_strong' (L_strong A1) v -> E_strong' (L_strong A2) (subst_tm (v .: (xi >> var_tm)) s)
                      | _ => False
                      end
  end.

Definition E_strong {m} (A : ty) : tm m -> Prop :=
  E_strong' (L_strong A).

Lemma E_strong_sn {m} (s : tm m) A:
  E_strong A s -> sn step s.
Proof.
  induction 1. constructor. intros s' HH. eauto.
Qed.

Lemma E_strong_step {m} (s: tm m) L_A :
  E_strong' L_A s -> forall s', step s s' -> E_strong' L_A s'.
Proof.
 induction 1; eauto.
Qed.

Lemma E_strong_base {m} (s: tm m) A :
  value s -> E_strong A s -> L_strong A s.
Proof.
  intros C []; eauto.
Qed.

Lemma E_strong_var {m} A (x: fin m) :
  E_strong A (var_tm x).
Proof.
  constructor; eauto.
  - cbn. contradiction.
  - intros. inversion H.
Qed.

Definition G_strong {k m} (Gamma : ctx k) : (fin k -> tm m)  -> Prop :=
  fun σ => forall (x : fin k), E_strong (Gamma x) (σ x) .

Definition has_ty_sem_strong {m} (Gamma : ctx m) (s: tm m) (A: ty) : Prop :=
  forall k (sigma: fin m -> tm k), G_strong Gamma sigma -> E_strong A (subst_tm sigma s).

Lemma L_close_ren_lam m n (xi: fin m -> fin n) s A :
  L_strong A s -> L_strong A (ren_tm xi s).
Proof.
  induction A; eauto.
  destruct s; try contradiction.
  subst. intros. cbn in *. intros. asimpl. eauto.
Qed.

Lemma close_ren  :
  (forall m n (xi: fin m -> fin n) s A, E_strong A s -> E_strong A (ren_tm xi s)).
Proof.
  intros. induction H.
  constructor; eauto. intros.
  assert (value s) by (now destruct s).
  specialize (H H3). now apply L_close_ren_lam.
  intros. apply step_naturality in H2. destruct H2 as (?&?&?); subst.
  apply H1; eauto.
Qed.

Lemma value_anti_renaming_lam m n s (xi: fin m -> fin n) :
  value (ren_tm xi s) -> value s.
Proof.
  destruct s;  eauto.
Qed.

Lemma sn_fundamental m Gamma (s: tm m) A :
  has_type Gamma s A -> has_ty_sem_strong Gamma s A.
Proof.
  intros C. induction C as [x | n Gamma A B s H IH | n Gamma A B s t H IH H' IH'].
  - unfold has_ty_sem_strong. intros. cbn. apply H.
  - intros k sigma ctx. cbn.
    assert (sn step (subst_tm (up_tm_tm sigma) s)).
    { eapply E_strong_sn. unfold has_ty_sem_strong in IH. apply IH.
      intros [|]; intros.
      - cbn. unfold funcomp. apply close_ren. eauto.
      - cbn. apply E_strong_var. }
    remember (subst_tm (up_tm_tm sigma) s) as s'.
    unfold has_ty_sem_strong in IH.
    assert (forall m (tau : fin (S k) -> tm m), G_strong (A .: Gamma) (up_tm_tm sigma >> subst_tm tau) -> E_strong B (subst_tm tau s')).
    { intros. rewrite Heqs'. revert H1. asimpl.  eauto.  }
    clear Heqs'.
    induction H0. constructor.
    + intros V m . intros. apply H1.
      intros [|]; intros; cbn; eauto.
      * unfold funcomp. asimpl.
        (* adrian: I had to add the following line so that renamify works *)
        change (fun x0 : fin k => @var_tm m (xi x0)) with (funcomp var_tm xi).
        renamify. eauto.
        eapply close_ren. eauto.
    + intros. inv H3.
      apply H2; eauto.
      intros. specialize (H1 _ _ H4). eapply E_strong_step; eauto.
      eauto using step_inst.

  - intros k sigma D.
    specialize (IH _ _ D). specialize (IH' _ _ D).
    cbn.
    remember (subst_tm sigma s) as s'. remember (subst_tm sigma t) as t'.
    apply E_strong_sn in IH as IH1'. apply E_strong_sn in IH' as IH2'.
    clear s t Heqs' Heqt' H H'.
    revert t' IH' IH2'. induction IH1' as [s].
    intros t' IH2 IH2'. induction IH2' as [t].
    constructor.
    + contradiction.
    + intros ? HH. inv HH; eauto using E_strong_step.
      * apply E_strong_base in IH.
       -- cbn in IH.
          specialize (IH _ id t). eapply IH.
        assumption.
       -- reflexivity.
     * apply H0; eauto. eapply E_strong_step; eauto.
     * apply H2; eauto. eapply E_strong_step; eauto.
Qed.

Lemma sn (Gamma : fin 0 -> ty) (s: tm 0) A:
  has_type Gamma s A -> sn step s.
Proof.
  intros H%sn_fundamental.
  unfold has_ty_sem_strong in H.
  replace s with (s[ids]) by (now asimpl).
  eapply E_strong_sn. eapply H. intros [].
Qed.


(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(** Properties and tactics about algebraic structures with converse.

   In particular,
   - [converse_down] pushes converses down to leaves
   - [switch] add converses on both sides of an (in)equation, and pushes converses down to leaves
   *)

Require Import Common.
Require Import Classes.
Require Import Graph.
Require Import SemiLattice.
Require Import SemiRing.

Set Implicit Arguments.
Unset Strict Implicit.

Section ISR.

  Context `{CISR: ConverseIdemSemiRing}.

  Lemma conv_compat' A B (x y: X A B): x` == y` -> x == y.
  Proof.
    intro H.
    rewrite <- (conv_invol x).
    rewrite <- (conv_invol y).
    apply conv_compat; exact H.
  Qed.

  Hint Rewrite conv_dot conv_plus conv_invol: converse_down.

  Ltac switch :=
    match goal with
      | |- _ ` == _ ` => apply conv_compat
      | |- _   == _   => apply conv_compat'
    end; autorewrite with converse_down.

  Existing Instance dot_compat_c.
  Lemma conv_one A: one A` == 1.
  Proof.
    rewrite <- (dot_neutral_left_c ((one A)`)).
    switch. apply dot_neutral_left_c.
  Qed.
  Hint Rewrite conv_one: converse_down.

  Lemma conv_zero A B: zero B A` == 0.
  Proof.
    transitivity ((dot B A A 0 (0`))`).
    switch.
    symmetry. apply dot_ann_left_c.
    autorewrite with converse_down. apply dot_ann_left_c.
  Qed.
  Hint Rewrite conv_zero: converse_down.

  Instance CISR_ISR: IdemSemiRing G.
  Proof.
    intros. constructor. constructor.
    apply dot_compat_c.
    apply dot_assoc_c.
    apply dot_neutral_left_c.
    intros. switch. apply dot_neutral_left_c.
    apply CISR_SL.
    apply dot_ann_left_c.
    intros. switch. apply dot_ann_left_c.
    apply dot_distr_left_c.
    intros. switch. apply dot_distr_left_c.
  Qed.

  Global Instance conv_incr A B:
  Proper ((leq A B) ==> (leq B A)) (conv A B).
  Proof.
    unfold leq.
    intros x y H.
    rewrite <- H at 2. rewrite conv_plus. apply plus_com.
  Qed.

  Lemma conv_incr' A B (x y: X A B): x` <== y` -> x <== y.
  Proof.
    intro H.
    rewrite <- (conv_invol x).
    rewrite <- (conv_invol y).
    apply conv_incr; exact H.
  Qed.

End ISR.

(** the push converses down to leaves  *)
Ltac converse_down :=
  repeat (
    rewrite conv_invol ||
    rewrite conv_dot ||
    rewrite conv_plus
  );
  repeat (
    rewrite conv_one ||
    rewrite conv_zero
  ).

(** add converses on both sides, and push converses down to leaves  *)
Ltac switch :=
  match goal with
    | |- _ ` == _ ` => apply conv_compat
    | |- _   == _   => apply conv_compat'
    | |- _ ` <== _ ` => apply conv_incr
    | |- _   <== _   => apply conv_incr'
  end; converse_down.

Section KA.

  Context `{KA: ConverseKleeneAlgebra}.

  Existing Instance CISR_ISR.

  Lemma star_destruct_left_old' A B (a: X A A) (b c: X A B): b+a*c <== c  ->  a#*b <== c.
  Proof.
    intro H; transitivity (a#*c).
     rewrite <- H; semiring_reflexivity.
     apply star_destruct_left_c.
     rewrite <- H at -1; auto with algebra.
  Qed.

  Lemma conv_star A (a: X A A): a# ` == a` #.
  Proof.
    apply leq_antisym.

    switch.
    rewrite <- (dot_neutral_right (a#)).
    apply star_destruct_left_old'.
    switch.
    rewrite <- star_make_left_c at 2. semiring_reflexivity.

    rewrite <- (dot_neutral_right (a`#)).
    apply star_destruct_left_old'.
    switch.
    rewrite <- star_make_left_c at 2. semiring_reflexivity.
  Qed.

  Global Instance CKA_KA: KleeneAlgebra G.
  Proof.
    constructor. apply CISR_ISR.
    apply star_make_left_c.
    apply star_destruct_left_c.
    intros. switch. rewrite conv_star.
    apply star_destruct_left_c. switch. assumption.
  Qed.

End KA.

(** override, to take [conv_star] into account *)
Ltac converse_down ::=
  repeat (
    rewrite conv_invol ||
    rewrite conv_star ||
    rewrite conv_dot ||
    rewrite conv_plus
  );
  repeat (
    rewrite conv_one ||
    rewrite conv_zero
  ).


Require Import List.

Check nil.

Require Coq.Reals.Reals.

Import Coq.Reals.Rdefinitions.
Import Coq.Reals.Raxioms.

Open Scope list_scope.
Open Scope R_scope.

Check nil.

Check Coq.Reals.Rdefinitions.R.

Ltac dismiss := eexists; reflexivity.  (* used to finish a goal {y | y = ...} in the obvious way *)

Definition uncurry2 {A B C} (f : A -> B -> C) ab := f (fst ab) (snd ab).

Lemma uncurrying2 {A B C} (f : A -> B -> C) a b : f a b = uncurry2 f (a, b).
Admitted.

(* this is useless in its current form.
 * The idea is that a program of the form {y | y = f a} can be
 * composed by a program computing {y | y = a} followed by an application
 * of f; the program {y | y = a} can then be further refined.
 * But this one does not work because the fourth argument (a) is
 * not eliminated during extraction.
 *
Lemma seq {A B} (f : A -> B) a : {y | y = a} -> {y | y = f a}.
Admitted. *)

Notation Real := Coq.Reals.Rdefinitions.R.

Section Average.

  Fixpoint sum (l : list Real) : Real :=
    match l with
    | nil => 0
    | x::xs => x + sum xs
    end.

  Definition avg l := sum l / INR (length l).

  Lemma INR_S n : INR (S n) = 1 + INR n.
  Proof.
    simpl.
    destruct n.
    - simpl. rewrite RIneq.Rplus_0_r. reflexivity.
    - rewrite Rplus_comm. reflexivity.
  Qed.

  Arguments INR n : simpl nomatch.

  Lemma avg' l : {y | y = avg l}.
  Proof.
    unfold avg.
    (*rewrite (uncurrying2 Rdiv).
    apply seq.*)
    case l as [|x xs]; simpl.
    - dismiss.
    - rewrite INR_S. generalize x 1 xs.  (* "1" is called 'r' from now on *)
      fix aux 3.
      destruct xs0 as [|x' xs']; simpl.
      + rewrite !RIneq.Rplus_0_r. dismiss.
      + rewrite INR_S. rewrite <- !Rplus_assoc. apply aux.
  Defined.

  Compute (fun l => proj1_sig (avg' l)).

  Check exist.
  Search exist.
  Definition sigval {A} {P : A -> Prop} (x: {x | P x}) :=
    match x with exist _ v _ => v end.

  Lemma sigval_P {A} {P : A -> Prop} (x: {x | P x}) : P (sigval x).
    destruct x.
    simpl.
    assumption.
  Qed.

  Lemma avg'avg l : avg l = sigval (avg' l).
    destruct (avg' l).  (* Would be nice to use sigval_P? *)
    simpl.
    symmetry; assumption.
  Qed.

  Fixpoint avg'0 l :=
    match l with
    | nil => 0 / 0
    | x :: xs => aux x 1 xs
    end
  with aux x j xs :=
    match xs with
    | nil => x / j
    | x' :: xs' => aux (x + x') (j + 1) xs'
    end.

End Average.

Section Stddev.

  Definition sqr x := x * x.

  Definition variance l := avg (map (fun x => sqr (x - avg l)) l).

  Print avg'.

  Arguments INR n : simpl nomatch.

  Lemma variance' l : {y | y = variance l}.
  Proof.
    unfold variance.
    generalize (avg l); intro avgl. (* generalize;intro  =  let insertion *)

    (* Now I am basically replicating avg' *)
    case l as [|x xs]; unfold avg; simpl.
    - dismiss.
    - rewrite INR_S. generalize (sqr (x - avgl)) 1 xs.
      fix vaux 3.
      intros. case xs0 as [|x' xs']; simpl.
      + rewrite !RIneq.Rplus_0_r. dismiss.
      + rewrite INR_S. rewrite <- !Rplus_assoc. apply vaux.
  Qed.

  Lemma variance'' l : {y | y = avg'0 (map (fun x => sqr (x - avg l)) l)}.
  Proof.
    case l at 2; simpl.
    - dismiss.
    - generalize (sqr (r - avg l)), 1, l0 as l1; fix vaux 3.
      destruct l1; simpl.
      + dismiss.
      + apply vaux.
  Defined.

End Stddev.

Extraction variance'.
Extraction variance''.


(* Properties of natded *)

Set Implicit Arguments.

Require Import RelationClasses Setoid.
Require Import fml natded.
Require Export fml natded.

Inductive is_sub_pre: natded_pre -> natded_pre -> Prop :=
  | is_sub_pre_zero: forall p, is_sub_pre natded_pre_zero p
  | is_sub_pre_succ: forall p q a,
    natded_con a p -> is_sub_pre q p -> is_sub_pre (q ::: a) p.

Proposition is_sub_pre_ind_r: forall p q a,
  is_sub_pre p q -> is_sub_pre p (q ::: a).
intros p q a H.
induction H as [|q p b con_b_q H IHis_sub_pre].
+ apply is_sub_pre_zero.
+ apply is_sub_pre_succ.
  - apply natded_con_succ.
    exact con_b_q.
  - apply IHis_sub_pre.
Qed.

Proposition is_sub_pre_succ_monotone: forall p q a,
  is_sub_pre p q -> is_sub_pre (p ::: a) (q ::: a).
intros p q a H.
apply is_sub_pre_succ.
+ natded_trivial.
+ apply is_sub_pre_ind_r.
  exact H.
Qed.

Proposition is_sub_pre_with_con: forall a p q,
  natded_con a p -> is_sub_pre p q -> natded_con a q.
intros a p q con_a_p Hpq.
induction con_a_p as [x a|a x b con_a_p IHHpq].
(* p = x :: a *)
+ inversion Hpq as [|s t b H].
  exact H.
(* p = x :: b *)
+ apply IHHpq.
  inversion Hpq as [|s t c con_b_q Hxq].
  exact Hxq.
Qed.

Proposition is_sub_pre_refl: Reflexive is_sub_pre.
intro p.
induction p as [| p IHp a].
+ apply is_sub_pre_zero.
+ apply is_sub_pre_succ.
  - natded_trivial.
  - apply is_sub_pre_ind_r.
    apply IHp.
Qed.

Proposition is_sub_pre_trans: Transitive is_sub_pre.
intros p q r Hpq Hqr.
induction Hpq as [|q x a con_a_x Hxq IHHxq].
+ apply is_sub_pre_zero.
+ apply is_sub_pre_succ.
  - apply (is_sub_pre_with_con (a := a) (p := q) (q := r)).
    * exact con_a_x.
    * exact Hqr.
  - apply IHHxq.
    apply Hqr.
Qed.

Instance is_sub_pre_preorder: @PreOrder natded_pre is_sub_pre := {
  PreOrder_Reflexive := is_sub_pre_refl;
  PreOrder_Transitive := is_sub_pre_trans }.

Add Morphism natded_pre_succ with signature is_sub_pre ++> eq ==> is_sub_pre as natded_pre_succ_monotone.
intros p q Hpq a.
apply is_sub_pre_succ_monotone.
exact Hpq.
Qed.

Add Morphism natded_con with signature eq ==> is_sub_pre ++> Basics.impl as natded_con_monotone.
intros a p q Hpq con_a_p.
exact (is_sub_pre_with_con con_a_p Hpq).
Qed.


Generalizable All Variables.
Require Import Notations.
Require Import Categories_ch1_3.
Require Import Functors_ch1_4.
Require Import Isomorphisms_ch1_5.
Require Import NaturalTransformations_ch7_4.
Require Import NaturalIsomorphisms_ch7_5.

(*******************************************************************************)
(* Chapter 7.5 and 7.7: Functor Categories                                     *)
(*******************************************************************************)

(* Definition 7.9 *)
Instance FunctorCategory `(C:Category)`(D:Category)
    : Category { Fobj : C->D & Functor C D Fobj } (fun F G => (projT2 F) ~~~> (projT2 G)) :=
{ id   := fun F                   => nt_id (projT2 F)
; comp := fun F G H nt_f_g nt_g_h => nt_comp nt_f_g nt_g_h
; eqv  := fun F G nt1 nt2         => forall c, (nt1 c) ~~ (nt2 c)
}.
  intros.
   (apply Build_Equivalence;
            [ unfold Reflexive; unfold respectful; simpl; intros; reflexivity
            | unfold Symmetric; unfold respectful; simpl; intros; symmetry; auto
            | unfold Transitive; unfold respectful; simpl; intros; etransitivity; [ apply H | auto ] ]).
  abstract (intros; unfold Proper; unfold respectful; simpl; intros; setoid_rewrite H0; setoid_rewrite H; reflexivity).
  abstract (intros; simpl; apply left_identity).
  abstract (intros; simpl; apply right_identity).
  abstract (intros; simpl; apply associativity).
  Defined.

(* functors compose with each other, natural transformations compose with each other -- but you can also
 * compose a functor with a natural transformation! *)
Definition LeftWhisker
  `{C:Category}`{D:Category}`{E:Category}
  {Fobj}{F:Functor C D Fobj}
  {Gobj}{G:Functor C D Gobj}
  (nat:F ~~~> G)
  {Hobj}(H:Functor D E Hobj) : ((F >>>> H) ~~~> (G >>>> H)).
  apply Build_NaturalTransformation with (nt_component:=(fun c => H \ (nat c))).
  abstract (intros;
            simpl;
            set (@nt_commutes _ _ _ _ _ _ F _ _ G nat) as nat';
            setoid_rewrite fmor_preserves_comp;
            setoid_rewrite <- nat';
            setoid_rewrite <- (fmor_preserves_comp H);
            reflexivity).
  Defined.

Definition RightWhisker
  `{C:Category}`{D:Category}`{E:Category}
  {Fobj}(F:Functor C D Fobj)
  {Gobj}{G:Functor D E Gobj}
  {Hobj}{H:Functor D E Hobj} : (G ~~~> H) -> ((F >>>> G) ~~~> (F >>>> H)).
  intro nat.
  apply Build_NaturalTransformation with (nt_component:=(fun c => (nat (F  c)))).
  abstract (intros;
            simpl;
            set (@nt_commutes _ _ _ _ _ _ G _ _ H nat) as nat';
            setoid_rewrite nat';
            reflexivity).
  Defined.

(* also sometimes called "horizontal composition" *)
Definition GodementMultiplication
  `{A:Category}`{B:Category}`{C:Category}
  {F0obj}{F0:Functor A B F0obj}
  {F1obj}{F1:Functor A B F1obj}
  {G0obj}{G0:Functor B C G0obj}
  {G1obj}{G1:Functor B C G1obj}
  : (F0~~~>F1) -> (G0~~~>G1) -> ((F0 >>>> G0)~~~>(F1 >>>> G1)).
  intro phi.
  intro psi.
  apply Build_NaturalTransformation with (nt_component:=(fun (a:A) => G0 \ (phi a) >>> psi (F1 a))).
  abstract (intros;
            set (@nt_commutes _ _ _ _ _ _ F0 _ _ F1 phi) as comm1;
            set (@nt_commutes _ _ _ _ _ _ G0 _ _ G1 psi) as comm2;
            setoid_rewrite <- comm2;
            simpl;
            setoid_rewrite associativity;
            setoid_rewrite fmor_preserves_comp;
            setoid_rewrite comm1;
            setoid_rewrite <- fmor_preserves_comp;
            repeat setoid_rewrite <- associativity;
            apply comp_respects; try reflexivity;
            setoid_rewrite comm2;
            reflexivity).
  Defined.
  (* this operation is also a bifunctor from (FunctorCategory A B)*(FunctorCategory B C) to (FunctorCategory A C);
   * it is functorial *)


Require Export Coq.Program.Tactics.
Require Export Coq.Setoids.Setoid.
Require Export Coq.Classes.Morphisms.
Require Export Coq.Arith.Arith_base.
Require Export Coq.Relations.Relations.
Require Export Coq.Lists.List.

Import EqNotations.
Import ListNotations.

(***
 *** Ordered Types = Types with a PreOrder
 ***)

Class OType (T:Type) (R:relation T) : Prop :=
  {
    ot_PreOrder :> PreOrder R
  }.

Definition ot_Type `(A:OType) : Type := T.
Coercion ot_Type : OType >-> Sortclass.
Definition ot_R `(A:OType) : relation T := R.

(* The equivalence relation for an OrderedType *)
Definition ot_equiv `(A:OType) : relation T :=
  fun x y => ot_R A x y /\ ot_R A y x.

Instance ot_equiv_Equivalence `(A:OType) : Equivalence (ot_equiv A).
Proof.
  constructor; intro; intros.
  { split; reflexivity. }
  { destruct H; split; assumption. }
  { destruct H; destruct H0; split; transitivity y; assumption. }
Qed.

(***
 *** Commonly-Used Ordered Types
 ***)

(* The ordered type of propositions *)
Instance OTProp : OType Prop Basics.impl.
Proof.
  constructor; constructor; auto with typeclass_instances.
Qed.

(* The discrete ordered type, where things are only related to themselves *)
Definition OTdiscrete T : OType T eq.
Proof.
  constructor; auto with typeclass_instances.
Qed.

(* The only ordered type over unit is the discrete one *)
Instance OTunit : OType unit eq := OTdiscrete unit.

(* The ordered type of natural numbers using <= *)
Instance OTnat : OType nat le.
Proof.
  constructor; auto with typeclass_instances.
Qed.

(* Flip the ordering of an OType *)
(* NOTE: we don't want this to be an instance, since applying it in proof search
leads to infinite regress... *)
Definition OTflip `(A:OType) : OType T (Basics.flip R).
Proof.
  constructor; auto with typeclass_instances.
Qed.

(* The pointwise relation on pairs *)
Definition pairR {T U} (RT:relation T) (RU:relation U) : relation (T*U) :=
  fun p1 p2 => RT (fst p1) (fst p2) /\ RU (snd p1) (snd p2).

(* The non-dependent product ordered type, where pairs are related pointwise *)
Instance OTpair `(A:OType) `(B: OType) : OType (T*T0) (pairR R R0).
Proof.
  repeat constructor; try reflexivity.
  { destruct H; destruct H0; transitivity (fst y); assumption. }
  { destruct H; destruct H0; transitivity (snd y); assumption. }
Qed.

(* The sort-of pointwise relation on sum types *)
Definition sumR {T U} (RT:relation T) (RU:relation U) : relation (T+U) :=
  fun sum1 sum2 =>
    match sum1, sum2 with
    | inl x, inl y => RT x y
    | inl x, inr y => False
    | inr x, inl y => False
    | inr x, inr y => RU x y
    end.

(* The non-dependent sum ordered type, where objects are only related if they
are both "left"s or both "right"s *)
Instance OTsum `(A:OType) `(B:OType) : OType (T+T0) (sumR R R0).
Proof.
  repeat constructor.
  { intro s; destruct s; simpl; reflexivity. }
  { intros s1 s2 s3 R12 R23.
    destruct s1; destruct s2; destruct s3;
      try (elimtype False; assumption); simpl.
    - transitivity t0; assumption.
    - transitivity t0; assumption. }
Qed.

(* NOTE: the following definition requires everything above to be polymorphic *)
(* NOTE: The definition we choose for OTType is actually deep: instead of
requiring ot_Type A = ot_Type B, we could just require a coercion function from
ot_Type A to ot_Type B, which would yield something more like HoTT... though
maybe it wouldn't work unless we assumed the HoTT axiom? As it is, we might need
UIP to hold if we want to use the definition given here... *)
(*
Program Definition OTType : OType :=
  {|
    ot_Type := OType;
    ot_R := (fun A B =>
               exists (e:ot_Type A = ot_Type B),
                 forall (x y:A),
                   ot_R A x y ->
                   ot_R B (rew [fun A => A] e in x)
                        (rew [fun A => A] e in y));
  |}.
*)

(***
 *** The Ordered Type for Functions
 ***)

(* The type of continuous, i.e. Proper, functions between ordered types *)
Record Pfun `(A:OType) `(B: OType) :=
  {
    pfun_app : ot_Type A -> ot_Type B;
    pfun_Proper :> Proper (ot_R A ==> ot_R B) pfun_app
  }.

Arguments pfun_app [_ _ _ _ _ _] _ _.
Arguments pfun_Proper [_ _ _ _ _ _] _ _ _ _.

(* Infix "@" := pfun_app (at level 50). *)

(* The non-dependent function ordered type *)
Definition OTarrow_R `(A:OType) `(B:OType) : relation (Pfun A B) :=
  fun f g =>
    forall a1 a2, ot_R A a1 a2 -> ot_R B (pfun_app f a1) (pfun_app g a2).

Instance OTarrow `(A:OType) `(B:OType) : OType _ (OTarrow_R A B).
Proof.
  repeat constructor.
  { intros f; apply (pfun_Proper f). }
  { intros f g h Rfg Rgh a1 a2 Ra. transitivity (pfun_app g a1).
    - apply (Rfg a1 a1). reflexivity.
    - apply Rgh; assumption. }
Qed.

(* Curry a Pfun *)
Program Definition pfun_curry `(A:OType) `(B:OType) `(C:OType)
        (pfun : Pfun (OTpair A B) C) : Pfun A (OTarrow B C) :=
  {| pfun_app :=
       fun a =>
         {| pfun_app := fun b => pfun_app pfun (a,b);
            pfun_Proper := _ |};
     pfun_Proper := _ |}.
Next Obligation.
Proof.
  intros b1 b2 Rb. apply pfun_Proper.
  split; [ reflexivity | assumption ].
Qed.
Next Obligation.
Proof.
  intros a1 a2 Ra b1 b2 Rb; simpl.
  apply pfun_Proper; split; assumption.
Qed.

(* Uncrry a Pfun *)
Program Definition pfun_uncurry `(A:OType) `(B:OType) `(C:OType)
        (pfun : Pfun A (OTarrow B C)) : Pfun (OTpair A B) C :=
  {| pfun_app :=
       fun ab => pfun_app (pfun_app pfun (fst ab)) (snd ab);
     pfun_Proper := _ |}.
Next Obligation.
Proof.
  intros ab1 ab2 Rab. destruct Rab as [ Ra Rb ].
  exact (pfun_Proper pfun (fst ab1) (fst ab2) Ra (snd ab1) (snd ab2) Rb).
Qed.

(* Currying and uncurrying of pfuns form an adjunction *)
(* FIXME HERE: figure out the simplest way of stating this adjunction *)

(* OTarrow is right adjoint to OTpair, meaning that (OTarrow (OTpair A B) C) is
isomorphic to (OTarrow A (OTarrow B C)). The following is the first part of this
isomorphism, mapping left-to-right. *)

(* FIXME: could also do a forall type, but need the second type argument, B, to
itself be proper, i.e., to be an element of OTarrow A OType. Would also need a
dependent version of OTContext, below. *)

(***
 *** Ordered Type Functions
 ***)

Class OTypeF (TF: forall `(A:OType), Type)
      (RF: forall `(A:OType), relation (TF A)) : Prop :=
  otypef_otype : forall `(A:OType), OType (TF A) (RF A).

Definition OTypeF_app `(F:OTypeF) `(A:OType) : OType (TF _ _ A) (RF _ _ A) :=
  otypef_otype A.

Instance OType_OTypeF_app `(F:OTypeF) `(A:OType) :
  OType (ot_Type (OTypeF_app F A)) (RF _ _ A) :=
  otypef_otype A.

(***
 *** Notations for Ordered Types
 ***)

Module OTNotations.

  Notation "A '-o>' B" :=
    (OTarrow A B) (right associativity, at level 99).
  Notation "A '*o*' B" :=
    (OTpair A B) (left associativity, at level 40).
  Notation "A '+o+' B" :=
    (OTsum A B) (left associativity, at level 50).
  Notation "'~o~' A" :=
    (OTflip A) (right associativity, at level 35).

  Notation "x <o= y" :=
    (ot_R _ x y) (no associativity, at level 70).
  Notation "x =o= y" :=
    (ot_equiv _ x y) (no associativity, at level 70).

  Notation "x @o@ y" :=
    (pfun_app x y) (left associativity, at level 20).

  Notation "F @t@ A" :=
    (OTypeF_app F A) (left associativity, at level 20).

End OTNotations.

(***
 *** Building Proper Functions
 ***)

Class OTEnrich `(A:OType) {AU} (RA:relation AU) : Type :=
  {
    ot_lift : forall a, Proper RA a -> A;
    ot_lift_Proper :
      forall a1 a2 prp1 prp2,
        RA a1 a2 -> ot_R A (ot_lift a1 prp1) (ot_lift a2 prp2);
    ot_unlift : A -> AU;
  }.

Arguments OTEnrich {T R} A {AU%type} RA%signature.

Program Instance OTEnrich_refl `(A:OType) : OTEnrich A R :=
  {
    ot_lift := fun a _ => a;
    ot_lift_Proper := _;
    ot_unlift := fun a => a;
  }.

Program Instance OTEnrich_fun `(A:OType) `(B:OType) BU RB
        `{@OTEnrich _ _ B BU RB} :
  OTEnrich (OTarrow A B) (R ==> RB) :=
  {
    ot_lift := fun f prp =>
                 Build_Pfun _ _ A _ _ B (fun a => ot_lift (f a) _) _;
    ot_lift_Proper := _;
    ot_unlift := fun pfun a => ot_unlift (pfun_app pfun a);
  }.
Next Obligation.
  apply prp. reflexivity.
Qed.
Next Obligation.
  intros a1 a2 Ra. apply ot_lift_Proper. apply prp. assumption.
Qed.
Next Obligation.
  intros x1 x2 Rx. apply ot_lift_Proper. apply H0. assumption.
Qed.

Class OTHasType `(A:OType) {AU} (RA:relation AU) (x y:AU) : Type :=
  {
    ot_wf_type : OTEnrich A RA;
    ot_wf_term : RA x y;
  }.

Arguments OTHasType {_ _} A {AU%type} RA%signature x y.

(* NOTE: We only want this to apply to terms that are syntactically lambdas, so
we use an Extern hint, below. *)
Definition OTHasType_lambda `(A:OType) `(B:OType) BU RB `{@OTEnrich _ _ B BU RB}
         (fl fr:T -> BU)
         (pf: forall xl xr (pf:OTHasType A R xl xr),
             OTHasType B RB (fl xl) (fr xr)) :
  OTHasType (OTarrow A B) (R ==> RB) fl fr.
Proof.
  constructor.
  auto with typeclass_instances.
  intros xl xr Rx. apply pf. constructor.
  auto with typeclass_instances.
  assumption.
Defined.

(* Hint to apply OTHasType_lambda on lambdas *)
Hint Extern 2 (OTHasType _ _ (fun _ => _) (fun _ => _)) =>
apply OTHasType_lambda : typeclass_instances.

Instance OTHasType_app `(A:OType) AU RA `(B:OType) BU RB
         (fl fr:AU -> BU) argl argr
         `{@OTEnrich _ _ B BU RB}
         `{@OTHasType _ _ (OTarrow A B) _ (RA ==> RB) fl fr}
         `{@OTHasType _ _ A _ RA argl argr}
 : OTHasType B RB (fl argl) (fr argr) | 3.
Proof.
  constructor.
  assumption.
  apply H0. apply ot_wf_term.
Defined.

Instance OTHasType_pfun_app `(A:OType) `(B:OType) (fl fr:OTarrow A B) argl argr
         `{@OTHasType _ _ (OTarrow A B) _ (OTarrow_R A B) fl fr}
         `{@OTHasType _ _ A _ R argl argr}
 : OTHasType B R0 (pfun_app fl argl) (pfun_app fr argr) | 2.
Proof.
  constructor.
  auto with typeclass_instances.
  apply (ot_wf_term (OTHasType:=H)).
  apply (ot_wf_term (OTHasType:=H0)).
Defined.

(* NOTE: this is not an instance because it is not syntax-driven, like our other
rules for OTHasType. Instead, this definition is used as a helper to build
other instances of OTHasType. *)
Definition OTHasType_Proper `{OTEnrich} (x:AU) :
  Proper RA x -> OTHasType A RA x x.
  intros; constructor; assumption.
Qed.

Instance OTHasType_refl `(A:OType) (x : T) : OTHasType A R x x.
Proof.
  apply OTHasType_Proper. unfold Proper. reflexivity.
Qed.

Program Definition mkOTerm `(A:OType) {AU RA} (x:AU)
        `{@OTHasType _ _ A _ RA x x} : A :=
  ot_lift (OTEnrich:=ot_wf_type) x ot_wf_term.

Arguments mkOTerm {_ _} A {AU%type RA%signature} x {H}.

(***
 *** OT Typing Rules for Common Operations
 ***)

(*
Instance OTHasType_Proper A AU R (x:AU)
           {ote:OTEnrich A R} {prp:Proper R x} :
  OTHasType A R x x.
  constructor; assumption.
Qed.

Instance Proper_fst A B : Proper (ot_R (OTpair A B) ==> ot_R A) fst.
Proof.
  intros p1 p2 Rp; destruct Rp; assumption.
Qed.

Instance Proper_snd A B : Proper (ot_R (OTpair A B) ==> ot_R B) snd.
Proof.
  intros p1 p2 Rp; destruct Rp; assumption.
Qed.

Instance Proper_pair A B : Proper (ot_R A ==> ot_R B ==> ot_R (OTpair A B)) pair.
Proof.
  intros a1 a2 Ra b1 b2 Rb; split; assumption.
Qed.
*)

Instance OTHasType_fst `(A:OType) `(B:OType) :
  OTHasType (OTarrow (OTpair A B) A) (pairR R R0 ==> R) fst fst.
Proof.
  apply OTHasType_Proper.
  intros p1 p2 Rp; destruct Rp; assumption.
Defined.

Instance OTHasType_snd `(A:OType) `(B:OType) :
  OTHasType (OTarrow (OTpair A B) B) (pairR R R0 ==> R0) snd snd.
Proof.
  apply OTHasType_Proper.
  intros p1 p2 Rp; destruct Rp; assumption.
Defined.

Instance OTHasType_pair `(A:OType) `(B:OType) :
  OTHasType (OTarrow A (OTarrow B (OTpair A B)))
            (R ==> R0 ==> pairR R R0) pair pair.
Proof.
  apply OTHasType_Proper.
  intros a1 a2 Ra b1 b2 Rb; split; assumption.
Defined.

(***
 *** Examples of Ordered Terms
 ***)

Module OTExamples.
Import OTNotations.

Definition ex1 := mkOTerm (OTProp -o> OTProp) (fun p => p).
Eval compute in (ot_unlift ex1 : OTProp -> OTProp).

Definition ex2 `{A:OType} := mkOTerm (A -o> A) (fun p => p).
Eval simpl in (fun `(A:OType) => ot_unlift ex2 : A -> A).

Definition ex3 `{A:OType} :=
  mkOTerm (A -o> A -o> A -o> A -o> A) (fun (p1 p2 p3 p4:A) => p1).
Eval simpl in (fun `(A:OType) => ot_unlift ex3 : A -> A  -> A -> A -> A).

Definition ex4 `{A:OType} `{B:OType} : (A *o* B -o> A) :=
  mkOTerm _ (fun p => fst p).
Eval compute in (fun `(A:OType) `(B:OType) => ot_unlift ex4 : A * B -> A).

(*
Definition blah {A B:OType} {R}
           `{OTHasType (A *o* B -o> B *o* A) _ R
                       (fun p : A * B => (snd p, fst p))
                       (fun p => (snd p, fst p))} : Prop := True.
Definition blah2 {A B} : Prop := blah (A:=A) (B:=B).
 *)

Definition ex5 `{A:OType} `{B:OType} : A *o* B -o> B *o* A :=
  mkOTerm _ (fun p: A * B => (snd p, fst p)).

Definition ex6 `{A:OType} `{B:OType} `{C:OType} : A *o* B *o* C -o> C *o* A :=
  mkOTerm _ (fun triple : (A * B) * C => (snd triple, fst (fst triple))).

End OTExamples.


(* Equality *)

Inductive Id {A : Type} (a : A) : A -> Type :=
    id : Id a a.
Notation "A == B" := (Id A B) (at level 70) : id_scope.

Open Scope id_scope.

Notation "~ A" := (A -> False) : id_scope.
Notation "A /= B" := (~(A == B)) (at level 70) : id_scope.

(* List *)

Inductive List {A : Set} : Set :=
    null : List
  | new : A -> List -> List.

(* HW : head with proof of non-emptiness. Wow. *)

(* TODO : understand *)
Definition head (A : Set) (l : List) (proof : l /= null) : A :=
    (match l as b return (l == b -> A) with
      | null => fun foo : l == null => match (proof foo) return A with end
      | new x _ => fun foo : l == new x _ => x
    end) (id l).

(* HW : foldr with dependent types *)

Fixpoint foldr (A : Set) (B : List -> Set) (l0 : B (null)) (f : forall (x : A) (xs : List) (y : B xs), B (new x xs)) (l : List) : B l :=
    match l with
      | null => l0
      | new x xs => f x xs (foldr A B l0 f xs)
    end.

(* Sigma and Pi types *)

Inductive Empty :=.

Inductive Sigma (A : Set) (B : A -> Set) : Set :=
    pair : forall (a : A) (b : B a), Sigma A B.

Definition split (A : Set) (B : A -> Set) (C : Sigma A B -> Set) (f : forall (x : A) (y : B x), C (pair A B x y)) (p : Sigma A B) :=
    match p with
        pair x y => f x y
    end.

Definition fst (A : Set) (B : A -> Set) (p : Sigma A B) :=
    split A B (fun _ => A) (fun x y => x) p.

Definition snd (A : Set) (B : A -> Set) (p : Sigma A B) :=
    split A B (fun x => B (fst A B x)) (fun x y => y) p.

Inductive Pi (A : Set) (B : A -> Set) : Set :=
    lambda : (forall x : A, B x) -> Pi A B.

Definition apply (A : Set) (B : A -> Set) (g : Pi A B) (x : A) :=
    match g with
        lambda f => f x
    end.

Notation "A ~> B" := (Pi A (fun _ => B)) (at level 50) : pi_scope.
Open Scope pi_scope.
Notation "~' A" := (A ~> Empty) (at level 45) : pi_scope.

Definition lambda' (A B : Set) (f : A -> B) : A ~> B :=
    lambda A (fun _ => B) f.

Definition apply' (A B : Set) (f : A ~> B) (x : A) :=
    apply A (fun _ => B) f x.

(* HW : \forall x \in A: \not P x <=> \not \exists x \in A : P x *)

Theorem forall_is_exists : forall (A : Set) (B : A -> Set), (Pi A (fun x => ~' (B x))) ~> ~'(Sigma A B).
Proof.
    intros A B.
    refine (lambda' _ _ _).
    intros pi.
    refine (lambda _ _ _).
    intros sigma.
    case sigma.
    intros a b.
    case pi.
    intros hyp.
    case (hyp a).
    intros b_to_empty.
    exact (b_to_empty b).
Qed.

Theorem exists_is_forall : forall (A : Set) (B : A -> Set), ~'(Sigma A B) ~> (Pi A (fun x => ~' (B x))).
Proof.
    intros A B.
    refine (lambda' _ _ _).
    intros not_sigma.
    refine (lambda _ _ _).
    intros a.
    refine (lambda' _ _ _).
    intros b.
    case not_sigma.
    intros sigma_to_empty.
    exact (sigma_to_empty (pair A B a b)).
Qed.

(* Meta-relations *)

Inductive And (A B : Prop) : Prop :=
    conj : A -> B -> And A B.

Implicit Arguments conj.

Inductive Or (A B : Prop) : Prop :=
    inl : A -> Or A B
  | inr : B -> Or A B.

Implicit Arguments inl.
Implicit Arguments inr.

Notation "A /.\ B" := (And A B) (at level 80) : rel_scope.
Notation "A \./ B" := (Or A B) (at level 85) : rel_scope.
Open Scope rel_scope.

Section Relation_Definitions.
    Variable A : Type.
    Definition Relation (S : Type) := S -> S -> Prop.
    Variable R : Relation A.

    Section General_Properties_of_Relations.
        Definition reflexive : Prop := forall x : A, R x x.
        Definition symmetric : Prop := forall x y : A, R x y -> R y x.
        Definition transitive : Prop := forall x y z : A, R x y -> R y z -> R x z.
        Definition antisymmetric : Prop := forall x y : A, R x y -> R y x -> x == y.

        Definition equiv := reflexive /.\ symmetric /.\ transitive.
    End General_Properties_of_Relations.

    Section Meta_Relations.
        Definition inclusion (R1 R2 : Relation A) : Prop := forall x y : A, R1 x y -> R2 x y.
        Definition equality (R1 R2 : Relation A) : Prop := inclusion R1 R2 /.\ inclusion R2 R1.
    End Meta_Relations.
End Relation_Definitions.

Section Extensionality_Definition.
    Variable A B : Type.
    Variable R1 : Relation A.
    Variable R2 : Relation B.

    Definition extensional (f : A -> B) : Prop := forall (x y : A), R1 x y -> R2 (f x) (f y).
End Extensionality_Definition.

Section Theorem_about_Minimal_Relations.
    Variable A : Type.
    Variable R : Relation A.
    Hypothesis reflR : reflexive A R.
    Hypothesis minR : forall S : Relation A, reflexive A S -> inclusion A R S.

    Theorem min_refl_rel_is_equiv :
        equiv A R /.\
        forall (B : Type) (R2 : Relation B), equiv B R2 -> forall (f : A -> B), extensional A B R R2 f.
    Proof.
        (* prove first part *)
        split.
        split.
        split.
        (* prove reflexivity of R *)
        exact reflR.
        (* prove symmetry of R *)
        pose (S x y := R y x).
        assert (reflexive A S).
        unfold reflexive.
        intros x.
        exact (reflR x).
        pose (inclRS := minR S H).
        unfold symmetric.
        intros x y.
        exact (inclRS x y).
        (* prove transitivity of R *)
        pose (T x y := forall z, R y z -> R x z).
        assert (reflexive A T).
        unfold reflexive, T.
        intros x z.
        intuition.
        pose (inclRT := minR T H).
        unfold transitive.
        intros.
        exact (inclRT x y H0 z H1).
        (* prove second part *)
        intros.
        unfold extensional.
        intros.
        pose (F x y := R2 (f x) (f y)).
        (* prove reflexivity of F *)
        assert (reflexive A F).
        unfold reflexive.
        intros x0.
        unfold F.
        assert (reflexive B R2).
        destruct H as [r].
        destruct r as [r].
        exact r.
        exact (H1 (f x0)).
        exact (minR F H1 x y H0).
    Qed.
End Theorem_about_Minimal_Relations.

Lemma inclusion_is_reflexive : forall (A : Type), reflexive (Relation A) (inclusion A).
Proof.
    unfold reflexive, inclusion.
    intuition.
Qed.

Lemma inclusion_is_transitive : forall (A : Type), transitive (Relation A) (inclusion A).
Proof.
    unfold transitive, inclusion.
    intuition.
Qed.

Theorem rels_equality_is_equiv_rel : forall (T : Type), equiv (Relation T) (equality T).
Proof.
    intros T.
    unfold equality.
    split.
    split.
    unfold reflexive.
    intros.
    split.
    exact (inclusion_is_reflexive T x).
    exact (inclusion_is_reflexive T x).
    unfold symmetric.
    intros.
    intuition.
    unfold transitive.
    intros.
    destruct H.
    destruct H0.
    exact (conj (inclusion_is_transitive T x y z H H0) (inclusion_is_transitive T z y x H2 H1)).
Qed.


Require Export Qpositive_le.
Require Export Qpositive_plus_mult.

Ltac make_fraction w p q Heq := elim (interp_non_zero w); intros p (q, Heq).

Ltac expand a b c d p q Heq Heq1 Heq2 :=
  elim (construct_correct2' c a b);
   [ intros d; elim (interp_non_zero (Qpositive_c a b c)); intros p (q, Heq);
      rewrite Heq; unfold fst, snd in |- *; intros (Heq1, Heq2)
   | try (simpl in |- *; auto with arith; fail)
   | try (simpl in |- *; auto with arith; fail)
   | auto ].

Theorem Qpositive_le_add :
 forall w w' w'' : Qpositive,
 Qpositive_le w w' ->
 Qpositive_le (Qpositive_plus w w'') (Qpositive_plus w' w'').
intros w w' w''; make_fraction w ipattern:p ipattern:q ipattern:Heq;
 make_fraction w' ipattern:p' ipattern:q' ipattern:Heq';
 make_fraction w'' ipattern:p'' ipattern:q'' ipattern:Heq''.
intros H; apply Qpositive_le'_to_Qpositive_le;
 generalize (Qpositive_le_to_Qpositive_le' _ _ H);
 clear H.
unfold Qpositive_le' in |- *; simpl in |- *.
unfold Qpositive_le', Qpositive_plus in |- *; simpl in |- *; rewrite Heq;
 rewrite Heq'; rewrite Heq''.
expand (S p * S q'' + S p'' * S q) (S q * S q'')
 (S p * S q'' + S p'' * S q + S q * S q'') ipattern:d ipattern:p3 ipattern:q3
 ipattern:Heq3 ipattern:Heq1 ipattern:Heq2.
expand (S p' * S q'' + S p'' * S q') (S q' * S q'')
 (S p' * S q'' + S p'' * S q' + S q' * S q'') ipattern:d' ipattern:p4
 ipattern:q4 ipattern:Heq4 ipattern:Heq5 ipattern:Heq6.
intros Hle; apply mult_S_le_reg_l with d; rewrite (mult_comm (S p3));
 repeat rewrite (mult_comm (S d)); repeat rewrite <- mult_assoc.
rewrite <- Heq1; rewrite <- Heq2.
apply mult_S_le_reg_l with d'; repeat rewrite mult_assoc;
 repeat rewrite (mult_comm (S d')).
rewrite <- Heq5; rewrite <- Heq6.
rewrite mult_plus_distr_l; repeat rewrite mult_plus_distr_r.
match goal with
| |- (_ + ?X1 <= _ + ?X2) =>
    replace X1 with X2; [ try apply plus_le_compat_r | ring ]
end.
repeat rewrite <- (mult_comm (S q'')); repeat rewrite <- mult_assoc.
apply (fun m n p : nat => mult_le_compat_l p n m).
rewrite mult_assoc; rewrite <- (mult_comm (S q'')); rewrite <- mult_assoc;
 apply (fun m n p : nat => mult_le_compat_l p n m).
rewrite (mult_comm (S q')); exact Hle.
Qed.

Theorem Qpositive_le_mult :
 forall w w' w'' : Qpositive,
 Qpositive_le w w' ->
 Qpositive_le (Qpositive_mult w w'') (Qpositive_mult w' w'').
intros w w' w''; make_fraction w ipattern:p ipattern:q ipattern:Heq;
 make_fraction w' ipattern:p' ipattern:q' ipattern:Heq';
 make_fraction w'' ipattern:p'' ipattern:q'' ipattern:Heq''.
intros H; apply Qpositive_le'_to_Qpositive_le;
 generalize (Qpositive_le_to_Qpositive_le' _ _ H);
 clear H.
unfold Qpositive_le', Qpositive_mult in |- *; simpl in |- *; rewrite Heq;
 rewrite Heq'; rewrite Heq''.
expand (S p * S p'') (S q * S q'') (S p * S p'' + S q * S q'') ipattern:d
 ipattern:p3 ipattern:q3 ipattern:Heq3 ipattern:Heq1 ipattern:Heq2.
expand (S p' * S p'') (S q' * S q'') (S p' * S p'' + S q' * S q'')
 ipattern:d' ipattern:p4 ipattern:q4 ipattern:Heq4 ipattern:Heq5
 ipattern:Heq6.
intros Hle; apply mult_S_le_reg_l with d; rewrite (mult_comm (S p3));
 repeat rewrite (mult_comm (S d)); repeat rewrite <- mult_assoc.
rewrite <- Heq1; rewrite <- Heq2.
apply mult_S_le_reg_l with d'; repeat rewrite mult_assoc;
 repeat rewrite (mult_comm (S d')); rewrite <- Heq5;
 rewrite <- Heq6.
replace (S q' * S q'' * S p * S p'') with (S q'' * S p'' * (S p * S q')).
replace (S p' * S p'' * S q * S q'') with (S q'' * S p'' * (S p' * S q)).
apply (fun m n p : nat => mult_le_compat_l p n m); exact Hle.
ring.
ring.
Qed.

Theorem Qpositive_plus_le :
 forall w w' : Qpositive, Qpositive_le w (Qpositive_plus w w').
intros w w'; apply Qpositive_le'_to_Qpositive_le.
unfold Qpositive_le' in |- *.
unfold Qpositive_plus in |- *.
elim (interp_non_zero w); intros p (q, Heq); elim (interp_non_zero w');
 intros p' (q', Heq').
rewrite Heq; rewrite Heq'.
expand (S p * S q' + S p' * S q) (S q * S q')
 (S p * S q' + S p' * S q + S q * S q') ipattern:d ipattern:p'' ipattern:q''
 ipattern:Heq2 ipattern:Heq3 ipattern:Heq4.
apply mult_S_le_reg_l with d.
rewrite (mult_assoc (S d) (S p'')); repeat rewrite (mult_comm (S d));
 rewrite <- (mult_assoc (S p)); rewrite <- Heq3; rewrite <- Heq4.
rewrite mult_plus_distr_r.
replace (S p * S q' * S q) with (S p * (S q * S q')).
auto with arith.
ring.
Qed.


(** * Maps: Total and Partial Maps *)

Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Export Coq.Strings.String.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Lists.List.
Import ListNotations.

Definition beq_string x y :=
  if string_dec x y then true else false.

Theorem beq_string_refl : forall s, true = beq_string s s.
Proof. intros s. unfold beq_string. destruct (string_dec s s) as [|Hs].
  - reflexivity.
  - destruct Hs. reflexivity.
Qed.

Theorem beq_string_true_iff : forall x y : string,
  beq_string x y = true <-> x = y.
Proof.
   intros x y.
   unfold beq_string.
   destruct (string_dec x y) as [|Hs].
   - subst. split. reflexivity. reflexivity.
   - split.
     + intros contra. inversion contra.
     + intros H. inversion H. subst. destruct Hs. reflexivity.
Qed.

Theorem beq_string_false_iff : forall x y : string,
  beq_string x y = false
  <-> x <> y.
Proof.
  intros x y. rewrite <- beq_string_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

Theorem false_beq_string : forall x y : string,
   x <> y -> beq_string x y = false.
Proof.
  intros x y. rewrite beq_string_false_iff.
  intros H. apply H. Qed.

Definition total_map (A:Type) := string -> A.

(** Intuitively, a total map over an element type [A] is just a
    function that can be used to look up [string]s, yielding [A]s. *)

(** The function [t_empty] yields an empty total map, given a default
    element; this map always returns the default element when applied
    to any string. *)

Definition t_empty {A:Type} (v : A) : total_map A :=
  (fun _ => v).

(** More interesting is the [update] function, which (as before) takes
    a map [m], a key [x], and a value [v] and returns a new map that
    takes [x] to [v] and takes every other key to whatever [m] does. *)

Definition t_update {A:Type} (m : total_map A)
                    (x : string) (v : A) :=
  fun x' => if beq_string x x' then v else m x'.

(** This definition is a nice example of higher-order programming:
    [t_update] takes a _function_ [m] and yields a new function
    [fun x' => ...] that behaves like the desired map. *)

(** For example, we can build a map taking [string]s to [bool]s, where
    ["foo"] and ["bar"] are mapped to [true] and every other key is
    mapped to [false], like this: *)

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true)
           "bar" true.

(** Next, let's introduce some new notations to facilitate working
    with maps. *)

(** First, we will use the following notation to create an empty total map
    with a default value. *)
Notation "{ --> d }" := (t_empty d) (at level 0).

(** We then introduce a convenient notation for extending an existing
    map with some bindings. *)

(** (The definition of the notation is a bit ugly, but because the
    notation mechanism of Coq is not very well suited for recursive
    notations, it's the best we can do.) *)

Notation "m '&' { a --> x }" :=
  (t_update m a x) (at level 20).
Notation "m '&' { a --> x ; b --> y }" :=
  (t_update (m & { a --> x }) b y) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z }" :=
  (t_update (m & { a --> x ; b --> y }) c z) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z ; d --> t }" :=
    (t_update (m & { a --> x ; b --> y ; c --> z }) d t) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z ; d --> t ; e --> u }" :=
    (t_update (m & { a --> x ; b --> y ; c --> z ; d --> t }) e u) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z ; d --> t ; e --> u ; f --> v }" :=
    (t_update (m & { a --> x ; b --> y ; c --> z ; d --> t ; e --> u }) f v) (at level 20).

(** The [examplemap] above can now be defined as follows: *)

Definition examplemap' :=
  { --> false } & { "foo" --> true ; "bar" --> true }.

(** This completes the definition of total maps.  Note that we
    don't need to define a [find] operation because it is just
    function application! *)

Example update_example1 : examplemap' "baz" = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap' "foo" = true.
Proof. reflexivity. Qed.

Example update_example3 : examplemap' "quux" = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap' "bar" = true.
Proof. reflexivity. Qed.

(** To use maps in later chapters, we'll need several fundamental
    facts about how they behave. *)

(** Even if you don't work the following exercises, make sure
    you thoroughly understand the statements of the lemmas! *)

(** (Some of the proofs require the functional extensionality axiom,
    which is discussed in the [Logic] chapter.) *)

(** **** Exercise: 1 star, optional (t_apply_empty)  *)
(** First, the empty map returns its default element for all keys: *)

Lemma t_apply_empty:  forall (A:Type) (x: string) (v: A), { --> v } x = v.
Proof.
  intros A x v.
  unfold t_empty. reflexivity. Qed.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_eq)  *)
(** Next, if we update a map [m] at a key [x] with a new value [v]
    and then look up [x] in the map resulting from the [update], we
    get back [v]: *)

Lemma t_update_eq : forall A (m: total_map A) x v,
  (m & {x --> v}) x = v.
Proof.
  intros A m x v.
  unfold t_update. rewrite <- beq_string_refl.
  reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_neq)  *)
(** On the other hand, if we update a map [m] at a key [x1] and then
    look up a _different_ key [x2] in the resulting map, we get the
    same result that [m] would have given: *)

Theorem t_update_neq : forall (X:Type) v x1 x2
                         (m : total_map X),
  x1 <> x2 ->
  (m & {x1 --> v}) x2 = m x2.
Proof.
  intros X v x1 x2 m H.
  unfold t_update.
  apply beq_string_false_iff in H. rewrite H. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_shadow)  *)
(** If we update a map [m] at a key [x] with a value [v1] and then
    update again with the same key [x] and another value [v2], the
    resulting map behaves the same (gives the same result when applied
    to any key) as the simpler map obtained by performing just
    the second [update] on [m]: *)

Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
    m & {x --> v1 ; x --> v2} = m & {x --> v2}.
Proof.
  intros A m v1 v2 x.
  apply functional_extensionality.
  unfold t_update.
  intros x'. destruct (beq_string x x'); reflexivity.
Qed.
(** [] *)

(** For the final two lemmas about total maps, it's convenient to use
    the reflection idioms introduced in chapter [IndProp].  We begin
    by proving a fundamental _reflection lemma_ relating the equality
    proposition on [id]s with the boolean function [beq_id]. *)

(** **** Exercise: 2 stars, optional (beq_stringP)  *)
(** Use the proof of [beq_natP] in chapter [IndProp] as a template to
    prove the following: *)

Lemma beq_stringP : forall x y, reflect (x = y) (beq_string x y).
Proof.
  intros x y. apply iff_reflect. rewrite beq_string_true_iff. reflexivity.
Qed.
(** [] *)

(** Now, given [string]s [x1] and [x2], we can use the [destruct (beq_stringP
    x1 x2)] to simultaneously perform case analysis on the result of
    [beq_string x1 x2] and generate hypotheses about the equality (in the
    sense of [=]) of [x1] and [x2]. *)

(** **** Exercise: 2 stars (t_update_same)  *)
(** With the example in chapter [IndProp] as a template, use
    [beq_stringP] to prove the following theorem, which states that if we
    update a map to assign key [x] the same value as it already has in
    [m], then the result is equal to [m]: *)

Theorem t_update_same : forall X x (m : total_map X),
    m & { x --> m x } = m.
Proof.
  intros X x m. apply functional_extensionality. intros y.
  destruct beq_stringP with (x:=x) (y:=y).
  - unfold t_update. rewrite e. rewrite <- beq_string_refl. reflexivity.
  - unfold t_update. apply beq_string_false_iff in n. rewrite n. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 3 stars, recommended (t_update_permute)  *)
(** Use [beq_stringP] to prove one final property of the [update]
    function: If we update a map [m] at two distinct keys, it doesn't
    matter in which order we do the updates. *)

Theorem beq_string_sym : forall (s1 s2 : string),
  beq_string s1 s2 = beq_string s2 s1.
Proof.
  intros s1 s2. destruct (beq_stringP s1 s2).
  - rewrite e. apply beq_string_refl.
  - symmetry. apply beq_string_false_iff. unfold not in *.
    intros H. apply n. rewrite H. reflexivity.
Qed.

Theorem t_update_permute : forall (X:Type) v1 v2 x1 x2
                             (m : total_map X),
  x2 <> x1 ->
  m & { x2 --> v2 ; x1 --> v1 }
  =  m & { x1 --> v1 ; x2 --> v2 }.
Proof.
  intros X v1 v2 x1 x2 m H. apply functional_extensionality.
  intros x.
  destruct (beq_stringP x x1).
  - rewrite e. unfold t_update. rewrite <- beq_string_refl.
    apply beq_string_false_iff in H. rewrite H. reflexivity.
  - unfold t_update. apply beq_string_false_iff in n.
    rewrite beq_string_sym. rewrite n. reflexivity.
Qed.

(** [] *)

(* ################################################################# *)
(** * Partial maps *)

(** Finally, we define _partial maps_ on top of total maps.  A partial
    map with elements of type [A] is simply a total map with elements
    of type [option A] and default element [None]. *)

Definition partial_map (A:Type) := total_map (option A).

Definition empty {A:Type} : partial_map A :=
  t_empty None.

Definition update {A:Type} (m : partial_map A)
           (x : string) (v : A) :=
  m & { x --> (Some v) }.

(** We introduce a similar notation for partial maps, using double
    curly-brackets.  **)

Notation "m '&' {{ a --> x }}" :=
  (update m a x) (at level 20).
Notation "m '&' {{ a --> x ; b --> y }}" :=
  (update (m & {{ a --> x }}) b y) (at level 20).
Notation "m '&' {{ a --> x ; b --> y ; c --> z }}" :=
  (update (m & {{ a --> x ; b --> y }}) c z) (at level 20).
Notation "m '&' {{ a --> x ; b --> y ; c --> z ; d --> t }}" :=
    (update (m & {{ a --> x ; b --> y ; c --> z }}) d t) (at level 20).
Notation "m '&' {{ a --> x ; b --> y ; c --> z ; d --> t ; e --> u }}" :=
    (update (m & {{ a --> x ; b --> y ; c --> z ; d --> t }}) e u) (at level 20).
Notation "m '&' {{ a --> x ; b --> y ; c --> z ; d --> t ; e --> u ; f --> v }}" :=
    (update (m & {{ a --> x ; b --> y ; c --> z ; d --> t ; e --> u }}) f v) (at level 20).

(** We now straightforwardly lift all of the basic lemmas about total
    maps to partial maps.  *)

Lemma apply_empty : forall (A: Type) (x: string),  @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

Lemma update_eq : forall A (m: partial_map A) x v,
    (m & {{ x --> v }}) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (X:Type) v x1 x2
                       (m : partial_map X),
  x2 <> x1 ->
  (m & {{ x2 --> v }}) x1 = m x1.
Proof.
  intros X v x1 x2 m H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall A (m: partial_map A) v1 v2 x,
    m & {{ x --> v1 ; x --> v2 }} = m & {{x --> v2}}.
Proof.
  intros A m v1 v2 x1. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall X v x (m : partial_map X),
  m x = Some v ->
  m & {{x --> v}} = m.
Proof.
  intros X v x m H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (X:Type) v1 v2 x1 x2
                                (m : partial_map X),
  x2 <> x1 ->
  m & {{x2 --> v2 ; x1 --> v1}}
  = m & {{x1 --> v1 ; x2 --> v2}}.
Proof.
  intros X v1 v2 x1 x2 m. unfold update.
  apply t_update_permute.
Qed.


(** adaptation to whiskered notions by Ralph Matthes 2022 *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.Bicategories.Core.Bicat.

Local Open Scope cat.

(* Defines a bicategory from a whiskered monoidal category. *)
Section Bicat_From_Monoidal_Cat.

Import Bicat.Notations.
Import BifunctorNotations.
Import MonoidalNotations.

Context {C: category} (M : monoidal C).

(* The type of 0-cells is unit type and the 1-cells are the objects of the monoidal category. The
 2-cells are given by the morphisms of the original monoidal category. *)
Definition one_cells_data_from_monoidal : precategory_data.
Proof.
  use tpair.
  - exact (unit ,, (λ _ _, ob C)).
  - split.
    + intros dummy. exact I_{ M }.
    + intros dummy0 dummy1 dummy2. exact (λ a b, a ⊗_{M} b).
Defined.

Definition two_cells_from_monoidal : prebicat_2cell_struct (one_cells_data_from_monoidal)
  := λ _ _ a b, C ⟦ a , b⟧.

Definition prebicat_data_from_monoidal : prebicat_data.
Proof.
  use make_prebicat_data.
  - exact (one_cells_data_from_monoidal ,, two_cells_from_monoidal).
  - split. { intros ? ? f. exact (id₁ f). }
    split. { intros ? ? f. apply monoidal_leftunitordata. }
    split. { intros ? ? f. apply monoidal_rightunitordata. }
    split. { intros ? ? f. apply monoidal_leftunitorinvdata. }
    split. { intros ? ? f. apply monoidal_rightunitorinvdata. }
    split. { intros ? ? ? ? f g h. exact ( α_{ M } f g h ). }
    split. { intros ? ? ? ? f g h. exact ( αinv_{ M } f g h ). }
    split. { intros ? ? f g h. exact compose. }
    split. { intros ? ? ? f g h. exact (λ u, (f ⊗^{ M }_{l} u)). }
             intros ? ? ? f g h. exact (λ u, (u ⊗^{ M }_{r} h)).
Defined.

Lemma prebicat_laws_from_monoidal : prebicat_laws (prebicat_data_from_monoidal).
Proof.
  (* 1. Identities. *)
  split. { intros. apply id_left. }
  split. { intros. apply id_right. }

  (* 2. Vertical right associativity. *)
  split. { intros. apply assoc. }

  (* 3. Whiskering and identities. *)
  split. { intros ? ? ? f g. apply (bifunctor_leftid M). }
  split. { intros ? ? ? f g. apply (bifunctor_rightid M). }

  (* 4. Left whiskering vertical composition. *)
  split. {
    intros ? ? ? f g h i x y.
    apply pathsinv0, (bifunctor_leftcomp M).
  }

  (* 5. Right whiskering vertical composition. *)
  split. {
    intros ? ? ? f g h i x y.
    apply pathsinv0, (bifunctor_rightcomp M).
  }

  (* 6 and 7. Vertical composition and unitors. *)
  split. { intros. apply (leftunitorlaw_nat (monoidal_leftunitorlaw M)). }
  split. { intros. apply (rightunitorlaw_nat (monoidal_rightunitorlaw M)). }

  (* 8. Associator and left/left whiskering *)
  split. {
    intros ? ? ? ? f g h i x.
    cbn.
    apply pathsinv0.
    apply (z_iso_inv_on_right _ _ _ (_,,(_,,associatorlaw_iso_law (monoidal_associatorlaw M) f g h))).
    rewrite assoc.
    apply (z_iso_inv_on_left _ _ _ _ (_,,(_,,associatorlaw_iso_law (monoidal_associatorlaw M) f g i))).
    apply (associatorlaw_natleft (monoidal_associatorlaw M)).
  }

  (* 9. Associator and right/left whiskering *)
  split. {
    intros ? ? ? ? f g h i x.
    cbn.
    apply pathsinv0.
    apply (z_iso_inv_on_right _ _ _ (_,,(_,,associatorlaw_iso_law (monoidal_associatorlaw M) f g i))).
    rewrite assoc.
    apply (z_iso_inv_on_left _ _ _ _ (_,,(_,,associatorlaw_iso_law (monoidal_associatorlaw M) f h i))).
    apply (associatorlaw_natleftright (monoidal_associatorlaw M)).
  }

  (* 10. Associator and right/right whiskering *)
  split. {
    intros ? ? ? ? f g h i x.
    cbn.
    apply (z_iso_inv_on_right _ _ _ (_,,(_,,associatorlaw_iso_law (monoidal_associatorlaw M) f h i))).
    rewrite assoc.
    apply (z_iso_inv_on_left _ _ _ _ (_,,(_,,associatorlaw_iso_law (monoidal_associatorlaw M) g h i))).
    apply (associatorlaw_natright (monoidal_associatorlaw M)).
  }

  (* 11. Vertical composition and whiskering *)
  split. {
    intros.
    cbn.
    apply (bifunctor_equalwhiskers M).
  }

  (* 12. Left unitor invertible. *)
  split. { intros ? ? f. exact (pr1 (leftunitorlaw_iso_law (monoidal_leftunitorlaw M) f)). }
  split. { intros ? ? f. exact (pr2 (leftunitorlaw_iso_law (monoidal_leftunitorlaw M) f)). }

  (* 13. Right unitor invertible. *)
  split. { intros ? ? f. exact (pr1 (rightunitorlaw_iso_law (monoidal_rightunitorlaw M) f)). }
  split. { intros ? ? f. exact (pr2 (rightunitorlaw_iso_law (monoidal_rightunitorlaw M) f)). }

  (* 14. Associator invertible. *)
  split. { intros ? ? ? ? f g h. exact (pr2 (associatorlaw_iso_law (monoidal_associatorlaw M) f g h)). }
  split. { intros ? ? ? ? f g h. exact (pr1 (associatorlaw_iso_law (monoidal_associatorlaw M) f g h)). }

  (* 15. Right unitor whiskering. *)
  split. {
    intros ? ? ? f g.
    apply (z_iso_inv_on_right _ _ _ (_,,(_,,associatorlaw_iso_law (monoidal_associatorlaw M) f I_{ M} g))).
    apply pathsinv0, monoidal_triangleidentity.
  }

  (* 16. Pentagon equation *)
  intros ? ? ? ? ? f g h i.
  cbn.
  (* the pentagon equation in bicategories is formulated for the left associator while it is based
     on the right associator in whiskered monoidal categories *)
  apply monoidal_pentagon_identity_inv.
Qed.

Definition prebicat_from_monoidal : prebicat :=
  prebicat_data_from_monoidal ,, prebicat_laws_from_monoidal.

Definition bicat_from_monoidal : bicat.
  use build_bicategory.
  - exact prebicat_data_from_monoidal.
  - exact prebicat_laws_from_monoidal.
  - red. intros. apply homset_property.
Defined.

End Bicat_From_Monoidal_Cat.


Require Import Coq.Classes.Morphisms.

Section Binary.
  Context {T: Type} (P Q: T -> Prop).
  Definition impl1 := forall x, P x -> Q x.
  Definition iff1 := forall x, P x <-> Q x.
  Definition and1 := fun x => P x /\ Q x.
  Definition or1 := fun x => P x \/ Q x.
End Binary.

Definition ex1 {A B} (P : A -> B -> Prop) := fun (b:B) => exists a:A, P a b.

Global Instance Transitive_impl1 T : Transitive (@impl1 T). firstorder idtac. Qed.
Global Instance Reflexive_impl1 T : Reflexive (@impl1 T). firstorder idtac. Qed.
Global Instance Proper_impl1_impl1 T : Proper (Basics.flip impl1 ==> impl1 ==> Basics.impl) (@impl1 T). firstorder idtac. Qed.
Global Instance subrelation_iff1_impl1 T : subrelation (@iff1 T) (@impl1 T). firstorder idtac. Qed.
Global Instance Equivalence_iff1 T : Equivalence (@iff1 T). firstorder idtac. Qed.
Global Instance Proper_iff1_iff1 T : Proper (iff1 ==> iff1 ==> iff) (@iff1 T). firstorder idtac. Qed.
Global Instance Proper_iff1_impl1 T : Proper (Basics.flip impl1 ==> impl1 ==> Basics.impl) (@impl1 T). firstorder idtac. Qed.
Global Instance Proper_impl1_iff1 T : Proper (iff1 ==> iff1 ==> iff) (@impl1 T). firstorder idtac. Qed.
Global Instance Proper_ex1_iff1 A B : Proper (pointwise_relation _ iff1 ==> iff1) (@ex1 A B). firstorder idtac. Qed.
Global Instance Proper_ex1_impl1 A B : Proper (pointwise_relation _ impl1 ==> impl1) (@ex1 A B). firstorder idtac. Qed.
Global Instance iff1_rewrite_relation T : RewriteRelation (@iff1 T) := {}.

Lemma impl1_ex1_l {A B} p q : impl1 (@ex1 A B p) q <-> (forall x, impl1  (p x) q).
Proof. firstorder idtac. Qed.
Lemma impl1_ex1_r {A B} p q x : impl1 p (q x) -> impl1 p (@ex1 A B q).
Proof. firstorder idtac. Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Lemma lem: forall n1 n2 l, drop (Succ n1) (drop n2 l) = drop n1 (drop (Succ n2) l).
Proof.
intros. generalize dependent n1. generalize dependent n2. induction l.
- intros. assert (forall n x l, drop (Succ n) (Cons x l) = drop n l).
  + intros. reflexivity.
  + destruct n2.
    * rewrite H. rewrite H. rewrite <- IHl. reflexivity.
    * simpl. destruct l. reflexivity. reflexivity.
- intros. assert (forall n, drop n Nil = Nil).
  + intros. destruct n. reflexivity. reflexivity.
  + rewrite H. rewrite H. rewrite H. reflexivity.
Qed.

Theorem theorem0 : forall (u : natural) (v : natural) (w : natural) (x : natural) (y : natural) (z : lst),
  eq (drop (Succ u) (drop v (drop (Succ w) (Cons x (Cons y z))))) (drop (Succ u) (drop v (drop w (Cons x z)))).
Proof.
intros.
rewrite lem.
rewrite lem.
lfind. Admitted.