From mathcomp Require Import
  ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype path bigop.

Require Import ord fset.

(******************************************************************************)
(*   This file defines a type {fmap T -> S} of partial functions with finite  *)
(* domain from T to S, where T is assumed to have an ordType structure.       *)
(* Throughtout this development, we refer to such functions as (finite) maps. *)
(* The type {fmap T -> S} is defined as a list of pairs (k, v) : T * S that   *)
(* is kept ordered by its keys.  This implies that the type supports          *)
(* extensional equality, as shown by the lemma eq_fmap.                       *)
(*                                                                            *)
(*       getm m k == the value of the map f associated with the key k. getm   *)
(*                   is declared as a coercion into Funclass, allowing us to  *)
(*                   simply write m k instead.                                *)
(*     setm m k v == set the value of k in m to v, replacing any previous     *)
(*                   value.                                                   *)
(*     updm m k v == a partial version of setm, that only replaces the value  *)
(*                   of k if it is already present in m, and returns None     *)
(*                   otherwise.                                               *)
(*      mapim f m == apply the function f : T -> S -> S' to all bindings in   *)
(*                   the map m : {fmap T -> S}.                               *)
(*       mapm f m == specialized version of mapim that ignores the key value. *)
(*   unionm m1 m2 == a map containing all the bindings of m1 and m2.  If a    *)
(*                   key is present in both of them, the value of m1 is used. *)
(*    filterm a m == given a predicate a : T -> S -> bool, remove from m all  *)
(*                   bindings (k, v) such that a k v is false.                *)
(*       remm m k == remove the value of k in m, if there is one.             *)
(*         domm m == the domain of m: the set of keys associated with some    *)
(*                   value in m.                                              *)
(*       codomm m == the codomain of m: the set of values associated with     *)
(*                   key in m.  This requires an ordType structure on the     *)
(*                   type of values.                                          *)
(*   injectivem m == the map m is injective on its domain (the type of        *)
(*                   values must be an eqType).                               *)
(*         invm m == the inverse of m.  If multiple keys of m are mapped to   *)
(*                   the same value, only one of the bindings is used.        *)
(*  fmap_of_seq s == convert s : seq T into a map {fmap nat -> T} that        *)
(*                   indexes into s.                                          *)
(*       currym m == convert from {fmap T * S -> R} to                        *)
(*                   {fmap T -> {fmap S -> R}}.                               *)
(*     uncurrym m == the left inverse of the previous function.               *)
(* enum_fmap s s' == sequence of all maps whose domain and codomain are       *)
(*                   contained in the sequences s and s'.                     *)
(*                                                                            *)
(*   The behavior of many of these functions is described by lemmas such as   *)
(* setmE, unionmE, etc.  For example, setmE says that setm m k v k' is equal  *)
(* to if k' == k then Some v else m k'.  Maps coerce to predicates:           *)
(* (k, v) \in m means that m k = Some v (cf. getmP).                          *)
(*                                                                            *)
(*   We provide the following map constructors:                               *)
(*                                                                            *)
(*         emptym == the empty map.                                           *)
(*     mkfmap kvs == construct a map from kvs : seq (T * S).  If multiple     *)
(*                   bindings are present in kvs for a given key k : T, the   *)
(*                   first one is used.                                       *)
(*   mkfmapf f ks == construct a map that associates to each element k of     *)
(*                   the sequence ks the value f k, mapping all other keys to *)
(*                   None.                                                    *)
(*  mkfmapfp f ks == same as above but for a partial function                 *)
(*                   f : T -> option S.                                       *)
(******************************************************************************)

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

Module FMap.

Section Def.

Variables (T : ordType) (S : Type).

Local Open Scope ord_scope.

Record fmap_type := FMap {
  fmval : seq (T * S);
  _ : sorted (@Ord.lt T) (unzip1 fmval)
}.

Definition fmap_of & phant (T -> S) := fmap_type.

End Def.

Module Exports.

Identity Coercion fmap_of_fmap : fmap_of >-> fmap_type.
Notation "{ 'fmap' T }" := (@fmap_of _ _ (Phant T))
  (at level 0, format "{ 'fmap'  T }") : type_scope.

Section WithOrdType.

Variable T : ordType.

Coercion fmval : fmap_type >-> seq.
Canonical fmap_subType S := [subType for @fmval T S].
Definition fmap_eqMixin (S : eqType) :=
  [eqMixin of fmap_type T S by <:].
Canonical fmap_eqType (S : eqType) :=
  Eval hnf in EqType (fmap_type T S) (fmap_eqMixin S).
Definition fmap_choiceMixin (S : choiceType) :=
  [choiceMixin of fmap_type T S by <:].
Canonical fmap_choiceType (S : choiceType) :=
  Eval hnf in ChoiceType (fmap_type T S) (fmap_choiceMixin S).
Definition fmap_ordMixin (S : ordType) :=
  [ordMixin of fmap_type T S by <:].
Canonical fmap_ordType (S : ordType) :=
  Eval hnf in OrdType (fmap_type T S) (fmap_ordMixin S).

Canonical fmap_of_subType (S : Type) :=
  Eval hnf in [subType of {fmap T -> S}].
Canonical fmap_of_eqType (S : eqType) :=
  Eval hnf in [eqType of {fmap T -> S}].
Canonical fmap_of_choiceType (S : choiceType) :=
  Eval hnf in [choiceType of {fmap T -> S}].
Canonical fmap_of_ordType (S : ordType) :=
  Eval hnf in [ordType of {fmap T -> S}].

(*

Still need to rethink the interface hierarchy to allow this...

Definition fmap_countMixin T (S : countType) :=
  [countMixin of type T S by <:].
Canonical fmap_countType T (S : countType) :=
  Eval hnf in CountType (type T S) (fmap_countMixin T S).
Canonical fmap_subCountType T (S : countType) :=
  [subCountType of type T S].
*)

End WithOrdType.

End Exports.

End FMap.

Export FMap.Exports.

(* Redefine the fmap constructor with a different signature, in
order to keep types consistent. *)
Definition fmap (T : ordType) S s Ps : {fmap T -> S} :=
  @FMap.FMap T S s Ps.

Section Operations.

Variables (T : ordType) (S : Type).

Implicit Type m : {fmap T -> S}.
Implicit Type k : T.

Local Open Scope ord_scope.

Fixpoint getm_def s k : option S :=
  if s is p :: s then
    if k == p.1 then Some p.2
    else getm_def s k
  else None.

Definition getm (m : FMap.fmap_type T S) k := getm_def m k.

Fixpoint setm_def s k v : seq (T * S) :=
  if s is p :: s' then
    if k < p.1 then (k, v) :: s
    else if k == p.1 then (k, v) :: s'
    else p :: setm_def s' k v
  else [:: (k, v)].

Lemma setm_subproof m k v : sorted (@Ord.lt T) (unzip1 (setm_def m k v)).
Proof.
have E: forall s, [seq p.1 | p <- setm_def s k v] =i k :: unzip1 s.
  elim=> // p s /= IH k'; rewrite ![in X in X = _]fun_if /= !inE.
  rewrite IH inE.
  case: (Ord.ltgtP k p.1) => // H; try by bool_congr.
  by rewrite H orbA orbb.
case: m; elim=> // p s /= IH Ps.
move: (order_path_min (@Ord.lt_trans T) Ps) => lb.
rewrite ![in X in is_true X]fun_if /= path_min_sorted; last exact: lb.
rewrite (path_sorted Ps); case: Ord.ltgtP=> [k_p//|k_p|-> //] /=.
rewrite path_min_sorted ?(IH (path_sorted Ps)) //=.
by rewrite !(eq_all_r (E s)) {E} /= lb andbT.
Qed.

Definition setm (m : {fmap T -> S}) k v :=
  fmap (setm_subproof m k v).

Definition repm (m : {fmap T -> S}) k f : option {fmap T -> S} :=
  omap (setm m k \o f) (getm m k).

Definition updm (m : {fmap T -> S}) k v :=
  if getm m k then Some (setm m k v) else None.

Definition unionm (m1 m2 : {fmap T -> S}) :=
  foldr (fun p m => setm m p.1 p.2) m2 m1.

Lemma mapim_subproof S' (f : T -> S -> S') m :
  sorted (@Ord.lt T) (unzip1 (map (fun p => (p.1, f p.1 p.2)) m)).
Proof. by rewrite /unzip1 -!map_comp; apply: (valP m). Qed.

Definition mapim S' (f : T -> S -> S') m := fmap (mapim_subproof f m).

Definition mapm S' (f : S -> S') := mapim (fun _ x => f x).

Lemma filterm_subproof (a : T -> S -> bool) m :
  sorted (@Ord.lt T) (unzip1 [seq p | p <- m & a p.1 p.2]).
Proof.
rewrite (subseq_sorted _ _ (valP m)) //; first exact: Ord.lt_trans.
rewrite /=; elim: {m} (FMap.fmval m) => // p s IH.
rewrite (lock subseq) /=; case: (a _); rewrite /= -lock.
  by rewrite /= eqxx.
by rewrite (subseq_trans IH) // subseq_cons.
Qed.

Definition filterm (a : T -> S -> bool) (m : {fmap T -> S}) :=
  fmap (filterm_subproof a m).

Fixpoint remm_def (s : seq (T * S)) k :=
  if s is p :: s then
    if p.1 == k then s else p :: remm_def s k
  else [::].

Lemma remm_subproof m k : sorted (@Ord.lt T) (unzip1 (remm_def m k)).
Proof.
apply/(subseq_sorted _ _ (valP m)); first exact: Ord.lt_trans.
rewrite /=; elim: {m} (FMap.fmval m) => // p s IH.
rewrite (lock subseq) /=; case: (_ == _); rewrite /= -lock.
  by rewrite subseq_cons.
by rewrite /= eqxx.
Qed.

Definition remm m k :=
  fmap (remm_subproof m k).

Definition emptym : {fmap T -> S} :=
  @fmap T S [::] erefl.

Definition mkfmap (kvs : seq (T * S)) : {fmap T -> S} :=
  foldr (fun kv m => setm m kv.1 kv.2) emptym kvs.

Definition mkfmapf (f : T -> S) (ks : seq T) : {fmap T -> S} :=
  mkfmap [seq (k, f k) | k <- ks].

Definition mkfmapfp (f : T -> option S) (ks : seq T) : {fmap T -> S} :=
  mkfmap (pmap (fun k => omap (pair k) (f k)) ks).

Definition domm m := fset (unzip1 m).

End Operations.

Coercion getm : FMap.fmap_type >-> Funclass.

Arguments getm {_ _} _ _.
Arguments setm {_ _} _ _.
Arguments repm {_ _} _ _ _.
Arguments updm {_ _} _ _ _.
Arguments unionm {_ _} _ _.
Arguments mapim {_ _ _} _ _.
Arguments mapm {_ _ _} _ _.
Arguments filterm {_ _} _ _.
Arguments remm {_ _} _ _.
Arguments emptym {_ _}.
Arguments mkfmap {_ _} _.
Arguments mkfmapf {_ _} _ _.
Arguments mkfmapfp {_ _} _ _.
Arguments domm {_ _} _.

Notation "[ 'fmap' kv1 ; .. ; kvn ]" :=
  (mkfmap (cons kv1 .. (cons kvn nil) ..))
  (at level 0, format "[ 'fmap'  '[' kv1 ; '/' .. ; '/' kvn ']' ]")
  : form_scope.

Section PredFmap.

Variables (T : ordType) (S : eqType).

Definition mem_fmap (m : {fmap T -> S}) :=
  [pred p : T * S | p \in val m].

Canonical mem_fmap_predType := PredType mem_fmap.

End PredFmap.

Section Properties.

Variables (T : ordType) (S : Type).
Local Open Scope ord_scope.
Local Open Scope fset_scope.

Implicit Type (m : {fmap T -> S}) (k : T) (v : S).

Lemma eq_fmap m1 m2 : m1 =1 m2 <-> m1 = m2.
Proof.
split; last congruence.
have in_seq: forall s : seq (T * S), [pred k | getm_def s k] =i [seq p.1 | p <- s].
  elim=> [|p s IH] k; rewrite /= !inE // -IH inE.
  by case: (k == p.1).
case: m1 m2 => [s1 Ps1] [s2 Ps2]; rewrite /getm /= => s1_s2.
apply: val_inj=> /=.
elim: s1 Ps1 s2 Ps2 s1_s2
      => [_|[k1 v1] s1 IH /= Ps1] [_|[k2 v2] s2 /= Ps2] //
      => [/(_ k2)|/(_ k1)| ]; try by rewrite eqxx.
have lb1 := order_path_min (@Ord.lt_trans _) Ps1.
have lb2 := order_path_min (@Ord.lt_trans _) Ps2.
move: {Ps1 Ps2} (path_sorted Ps2) (path_sorted Ps1) => Ps1 Ps2.
move: IH => /(_ Ps2 _ Ps1) {Ps1 Ps2} IH s1_s2.
wlog: k1 k2 v1 v2 s1 s2 lb1 lb2 s1_s2 IH / k1 <= k2.
  move=> H.
  have [|k2_k1] := orP (Ord.leq_total k1 k2); first by eauto.
  symmetry; apply: H; eauto.
    by move=> k /=; rewrite s1_s2.
  by move=> H'; rewrite IH //.
rewrite Ord.leq_eqVlt=> /orP [/eqP k1_k2|k1_k2].
  rewrite -{}k1_k2 {k2} in lb2 s1_s2 *.
  move: (s1_s2 k1); rewrite eqxx=> - [->].
  rewrite {}IH // => k; move: {s1_s2} (s1_s2 k).
  have [-> {k} _|ne ?] // := altP (_ =P _).
  move: (in_seq s1 k1) (in_seq s2 k1); rewrite !inE.
  case: (getm_def s1 k1) (getm_def s2 k1) => [v1'|] [v2'|] //=.
  - by move=> _ /esym/(allP lb2) /=; rewrite Ord.ltxx.
  - by move=> /esym/(allP lb1) /=; rewrite Ord.ltxx.
  by move=> _ /esym/(allP lb2) /=; rewrite Ord.ltxx.
move/(_ k1)/esym: s1_s2 k1_k2; rewrite eqxx.
have [->|_ s1_s2] := altP (_ =P _); first by rewrite Ord.ltxx.
move/(_ s2 k1): in_seq; rewrite inE {}s1_s2 /= => /esym/(allP lb2)/Ord.ltW /=.
by rewrite Ord.ltNge => ->.
Qed.

Lemma mem_domm m k : k \in domm m = m k.
Proof.
rewrite inE /domm /= in_fset.
case: m => [s Ps] /=; rewrite /getm /=.
by elim: s {Ps} => [|p s IH] //=; rewrite inE IH; case: (k == p.1).
Qed.

Lemma dommP m k : reflect (exists v, m k = Some v) (k \in domm m).
Proof.
by rewrite mem_domm; case: (m k) => /=; constructor; eauto; case.
Qed.

Lemma dommPn m k : reflect (m k = None) (k \notin domm m).
Proof.
by rewrite mem_domm; case: (m k)=> /=; constructor.
Qed.

Arguments dommP {_ _}.
Arguments dommPn {_ _}.

Lemma setmE m k v k' :
  setm m k v k' =
  if k' == k then Some v else getm m k'.
Proof.
case: m; rewrite /getm /setm /=; elim=> //= p s IH Ps.
rewrite ![in LHS](fun_if, if_arg) /= {}IH; last exact: path_sorted Ps.
have [->{k'}|Hne] := altP (k' =P k); case: (Ord.ltgtP k) => //.
by move=> <-; rewrite (negbTE Hne).
Qed.

Lemma setmC m k v k' v' : k != k' ->
  setm (setm m k v) k' v' = setm (setm m k' v') k v.
Proof.
move=> ne; apply/eq_fmap=> k''; rewrite !setmE.
have [->{k''}|//] := altP (k'' =P k').
by rewrite eq_sym (negbTE ne).
Qed.

Lemma setmxx m k v v' : setm (setm m k v) k v' = setm m k v'.
Proof. by apply/eq_fmap=> k'; rewrite !setmE; case: eqP. Qed.

Lemma repmE m m' k f :
  repm m k f = Some m' ->
  forall k', m' k' = if k' == k then omap f (m k) else getm m k'.
Proof.
by rewrite /repm; case: (m k) => [v [<-]|] //= k'; rewrite setmE.
Qed.

Lemma updm_set m m' k v :
  updm m k v = Some m' -> m' = setm m k v.
Proof. by rewrite /updm; case: (getm m _) => [m''|] //= [<-]. Qed.

Lemma unionmE m1 m2 k : unionm m1 m2 k = if m1 k then m1 k else m2 k.
Proof.
case: m1 => [m1 Pm1]; rewrite /unionm {2 3}/getm /= {Pm1}.
elim: m1 => [|p m1 IH] //=.
by rewrite setmE {}IH; case: (_ == _).
Qed.

Lemma domm_union m1 m2 : domm (unionm m1 m2) = domm m1 :|: domm m2.
Proof.
by apply/eq_fset=> k; rewrite in_fsetU !mem_domm unionmE; case: (m1 k).
Qed.

Lemma domm_set m k v : domm (setm m k v) = k |: domm m.
Proof.
apply/eq_fset=> k'; apply/(sameP dommP)/(iffP idP);
rewrite setmE in_fsetU1.
  case/orP=> [->|]; first by eauto.
  by move=> /dommP [v' ->]; case: eq_op; eauto.
by have [-> //|] := altP eqP => _ /= [v']; rewrite mem_domm => ->.
Qed.

Lemma emptymE k : @emptym T S k = None.
Proof. by []. Qed.

Lemma domm0 : domm (@emptym T S) = fset0.
Proof.
by apply/eq_fset=> k; rewrite mem_domm.
Qed.

Lemma emptymP m : reflect (m = emptym) (domm m == fset0).
Proof.
apply/(iffP eqP); last by move=> ->; rewrite domm0.
by move=> e; apply/eq_fmap => x; apply/dommPn; rewrite e.
Qed.

Lemma mapimE S' (f : T -> S -> S') m k : mapim f m k = omap (f k) (m k).
Proof.
case: m=> [s Ps]; rewrite /mapim /getm /=.
elim: s {Ps}=> [|[k' v] s IH] //=; rewrite {}IH ![in RHS]fun_if /=.
by case: (k =P k') => [<-|].
Qed.

Lemma mapmE S' (f : S -> S') m k : mapm f m k = omap f (m k).
Proof. exact: mapimE. Qed.

Lemma filtermE a m k :
  filterm a m k = obind (fun x => if a k x then Some x else None) (m k).
Proof.
case: m=> [s Ps]; rewrite /filterm /getm /=.
elim: s Ps=> [|p s IH /= Ps] //=.
rewrite ![in LHS](fun_if, if_arg) /= {}IH; last exact: path_sorted Ps.
have [-> {k}|k_p] //= := altP (_ =P _); case: (a _)=> //.
elim: s {Ps} (order_path_min (@Ord.lt_trans _) Ps)
      => [|p' s IH /andP /= [lb {}/IH IH]] //=.
by move: lb; have [->|//] := altP (_ =P _); rewrite Ord.ltxx.
Qed.

Lemma filterm0 (a : T -> S -> bool) : filterm a emptym = emptym.
Proof. by apply/eq_fmap=> x; rewrite filtermE. Qed.

Lemma remmE m k k' :
  remm m k k' =
  if k' == k then None else getm m k'.
Proof.
case: m; rewrite /remm /getm /=; elim=> [|p s IH /= Ps] //=.
  by case: (_ == _).
rewrite ![in LHS](fun_if, if_arg) /= {}IH //; last exact: path_sorted Ps.
move: {Ps} (order_path_min (@Ord.lt_trans _) Ps).
have [-> lb|ne lb] := altP (_ =P _).
  have [-> {k' p}|ne //] := altP (_ =P _).
  elim: s lb=> [|p s IH /= /andP [lb /IH {IH} ->]] //=.
  by move: lb; have [->|//] := altP (_ =P _); rewrite Ord.ltxx.
have [-> {k'}|ne'] // := altP (k' =P k).
by rewrite eq_sym (negbTE ne).
Qed.

Lemma remmI m k : k \notin domm m -> remm m k = m.
Proof.
move=> /dommPn m_k; apply/eq_fmap=> k'; rewrite remmE.
by case: eqP=> // ->; rewrite m_k.
Qed.

Lemma setm_rem m k v : setm (remm m k) k v = setm m k v.
Proof.
apply/eq_fmap=> k'; rewrite !setmE !remmE; by case: eqP.
Qed.

Lemma filterm_set (a : T -> S -> bool) m x y :
  filterm a (setm m x y) =
  if a x y then setm (filterm a m) x y
  else remm (filterm a m) x.
Proof.
apply/eq_fmap=> x'; have [yes|no] := boolP (a x y).
  by rewrite !(setmE, filtermE); case: eqP=> //= ->; rewrite yes.
by rewrite remmE !filtermE setmE; case: eqP no=> //= -> /negbTE ->.
Qed.

Lemma domm_rem m k : domm (remm m k) = domm m :\ k.
Proof.
by apply/eq_fset=> k'; rewrite in_fsetD1 !mem_domm remmE; case: eqP.
Qed.

Lemma domm_mkfmap (kvs : seq (T * S)) : domm (mkfmap kvs) =i unzip1 kvs.
Proof.
move=> k; rewrite mem_domm.
elim: kvs => [|kv kvs IH] //=; rewrite !inE setmE -{}IH.
by case: (_ == _).
Qed.

(* TODO rename this *)
Lemma domm_mkfmap' (kvs : seq (T * S)) :
  domm (mkfmap kvs) = fset (unzip1 kvs).
Proof. by apply/eq_fset=> x; rewrite domm_mkfmap in_fset. Qed.

Lemma mkfmapE (kvs : seq (T * S)) : mkfmap kvs =1 getm_def kvs.
Proof.
by move=> k; elim: kvs=> [|p kvs IH] //=; rewrite setmE IH.
Qed.

Lemma mkfmapfE (f : T -> S) (ks : seq T) k :
  mkfmapf f ks k = if k \in ks then Some (f k) else None.
Proof.
rewrite /mkfmapf; elim: ks => [|k' ks IH] //=.
by rewrite setmE inE {}IH; have [<-|?] := altP (k =P k').
Qed.

Lemma mkfmapfpE (f : T -> option S) (ks : seq T) k :
  mkfmapfp f ks k = if k \in ks then f k else None.
Proof.
rewrite /mkfmapfp; elim: ks => [|k' ks IH] //=.
case e: (f k') => [v|] //=.
  by rewrite setmE inE {}IH; have [->|? //] := altP (k =P k'); rewrite e.
rewrite inE {}IH; have [->|?] //= := altP (k =P k'); rewrite e.
by case: ifP.
Qed.

Lemma domm_mkfmapf (f : T -> S) (ks : seq T) :
  domm (mkfmapf f ks) = fset ks.
Proof.
apply/eq_fset=> k; rewrite mem_domm mkfmapfE in_fset.
by case: (k \in ks).
Qed.

Lemma domm_mkfmapfp (f : T -> option S) (ks : seq T) :
  domm (mkfmapfp f ks) = fset [seq k <- ks | f k].
Proof.
apply/eq_fset=> k; rewrite mem_domm mkfmapfpE in_fset mem_filter andbC.
by case: (k \in ks).
Qed.

Lemma setm_union m1 m2 k v :
  setm (unionm m1 m2) k v = unionm (setm m1 k v) m2.
Proof.
apply/eq_fmap=> k'; rewrite !(setmE, unionmE).
by have [->{k'}|] := altP (k' =P k).
Qed.

Lemma filterm_union p m1 m2 :
  fdisjoint (domm m1) (domm m2) ->
  filterm p (unionm m1 m2) =
  unionm (filterm p m1) (filterm p m2).
Proof.
move=> dis; apply/eq_fmap=> k; rewrite filtermE !unionmE !filtermE.
case get_k1: (m1 k)=> [v|] //=.
have: k \in domm m1 by rewrite mem_domm get_k1.
move/fdisjointP: dis=> dis /dis; rewrite mem_domm.
by case: (m2 k)=> //= _; case: ifP.
Qed.

Lemma eq_mkfmapf (f1 f2 : T -> S) :
  f1 =1 f2 -> mkfmapf f1 =1 mkfmapf f2.
Proof.
by move=> e ks; apply/eq_fmap=> k; rewrite !mkfmapfE e.
Qed.

Lemma eq_mkfmapfp (f1 f2 : T -> option S) :
  f1 =1 f2 -> mkfmapfp f1 =1 mkfmapfp f2.
Proof.
by move=> e ks; apply/eq_fmap=> k; rewrite !mkfmapfpE e.
Qed.

Lemma eq_filterm f1 f2 m :
  (f1 =2 f2) ->
  filterm f1 m = filterm f2 m.
Proof.
move=> e; apply/eq_fmap=> k; rewrite 2!filtermE.
case: (m k) => [v|] //=.
by rewrite e.
Qed.

Lemma domm_filter p m : domm (filterm p m) :<=: domm m.
Proof.
apply/fsubsetP=> k; rewrite !mem_domm filtermE.
by case: (m k).
Qed.

Lemma setmI m k v : m k = Some v -> setm m k v = m.
Proof.
move=> get_k; apply/eq_fmap=> k'; rewrite setmE.
by have [->{k'}|//] := altP (_ =P _); rewrite get_k.
Qed.

Lemma union0m : left_id (@emptym T S) unionm.
Proof. by []. Qed.

Lemma unionm0 : right_id (@emptym T S) unionm.
Proof.
move=> m; apply/eq_fmap=> k; rewrite unionmE emptymE /=.
by case: (m k).
Qed.

Lemma unionmA : associative (@unionm T S).
Proof.
move=> m1 m2 m3; apply/eq_fmap=> k; rewrite !unionmE.
by case: (m1 k).
Qed.

Lemma unionmI : idempotent (@unionm T S).
Proof.
move=> m; apply/eq_fmap=> k; rewrite !unionmE.
by case: (m k).
Qed.

Lemma unionmC m1 m2 :
  fdisjoint (domm m1) (domm m2) ->
  unionm m1 m2 = unionm m2 m1.
Proof.
move=> dis; apply/eq_fmap=> k; rewrite !unionmE.
have {dis}: ~~ (m1 k) || ~~ (m2 k).
  by rewrite -!mem_domm -implybE; apply/implyP/fdisjointP.
by case: (m1 k) (m2 k)=> [?|] [?|] //=.
Qed.

Lemma unionmK m1 m2 : filterm (fun k _ => m1 k) (unionm m1 m2) = m1.
Proof.
apply/eq_fmap=> k; rewrite filtermE unionmE.
by case: (m1 k) (m2 k)=> //= - [].
Qed.

Lemma fmap_rect (P : {fmap T -> S} -> Type) :
  P emptym ->
  (forall m, P m -> forall x y, x \notin domm m -> P (setm m x y)) ->
  forall m, P m.
Proof.
move=> H0 H1 m; move e: (domm m)=> X.
elim/fset_rect: X m e=> [|x X x_X IH] m e.
  by move/eqP/emptymP: e=> ->.
have : x \in domm m by rewrite e in_fsetU1 eqxx.
rewrite mem_domm; case yP: (m x)=> [y|] // _.
set m' := remm m x; have em : m = setm m' x y.
  apply/eq_fmap=> x'; rewrite /m' setmE remmE.
  by case: eqP => [->|].
have {}e : domm m' = X.
  apply/eq_fset=> x'; rewrite /m' domm_rem e in_fsetD1 in_fsetU1.
  by case: eqP=> // -> /=; rewrite (negbTE x_X).
rewrite {}em; apply: H1; first by exact: IH.
by rewrite e.
Qed.

Lemma fmap_ind (P : {fmap T -> S} -> Prop) :
  P emptym ->
  (forall m, P m -> forall x y, x \notin domm m -> P (setm m x y)) ->
  forall m, P m.
Proof. exact: fmap_rect. Qed.

Lemma val_domm m : domm m = unzip1 m :> seq _.
Proof.
apply: (sorted_eq (@Ord.lt_trans T)).
- move=> x y /andP [/Ord.ltW xy /Ord.ltW yx].
  by apply: Ord.anti_leq; rewrite xy.
- exact: valP.
- exact: (valP m).
rewrite uniq_perm // ?uniq_fset //.
  apply: sorted_uniq.
  - exact: (@Ord.lt_trans T).
  - exact: Ord.ltxx.
  - exact: (valP m).
by move=> x; rewrite in_fset.
Qed.

Lemma fmvalK : cancel val (@mkfmap T S).
Proof.
by move=> /= m; apply/eq_fmap=> x; rewrite mkfmapE.
Qed.

Lemma mkfmapK (kvs : seq (T * S)) :
  sorted Ord.lt (unzip1 kvs) ->
  mkfmap kvs = kvs :> seq (T * S).
Proof.
elim: kvs=> [|[k v] kvs IH]=> //= kvs_sorted.
rewrite IH ?(path_sorted kvs_sorted) //.
case: kvs kvs_sorted {IH} => [|[k' v'] kvs] //=.
by case/andP=> ->.
Qed.

Lemma getm_nth p (m : {fmap T -> S}) i :
  (i < size m)%N ->
  m (nth p.1 (domm m) i) = Some (nth p m i).2.
Proof.
rewrite val_domm /getm; move: (valP m); rewrite /=.
elim: (val m) i=> [//|[/= k v] kv IH] [|i] /= kv_sorted.
  by rewrite eqxx.
rewrite ltnS=> isize; rewrite (IH _ (path_sorted kv_sorted) isize).
case: eqP=> // kP; have kkv: k \in unzip1 kv.
  by rewrite -kP; apply/mem_nth; rewrite size_map.
move/(order_path_min (@Ord.lt_trans T))/allP/(_ _ kkv): kv_sorted.
by rewrite Ord.ltxx.
Qed.

End Properties.

Arguments dommP {_ _ _ _}.
Arguments dommPn {_ _ _ _}.

Lemma eq_setm (T : ordType) (S : eqType) m1 m2 (x : T) (y1 y2 : S) :
  (setm m1 x y1 == setm m2 x y2) =
  (y1 == y2) && (remm m1 x == remm m2 x).
Proof.
apply/(sameP eqP)/(iffP andP).
  rewrite -[setm m1 x y1]setm_rem.
  by case=> /eqP -> /eqP ->; rewrite setm_rem.
move=> /eq_fmap e.
move: (e x); rewrite !setmE eqxx; case=> ->; split=> //.
apply/eqP/eq_fmap=> x'; move: (e x'); rewrite !setmE !remmE.
by case: eqP.
Qed.

Section MapSplitting.

Local Open Scope fset_scope.

Variables (T : ordType) (S : Type).
Implicit Types m : {fmap T -> S}.

Definition splitm m :=
  match val m with
  | (x, y) :: ps => Some (x, y, mkfmap ps)
  | [::] => None
  end.

Lemma sizeES m :
  size m = if splitm m is Some (_, _, m') then (size m').+1 else 0.
Proof.
rewrite /splitm /=; move: (valP m)=> /=.
by case: (val m)=> [|[x y] m'] //= /path_sorted /mkfmapK ->.
Qed.

Lemma dommES m :
  domm m = if splitm m is Some (x, _, m) then x |: domm m
           else fset0.
Proof.
rewrite /domm /splitm /=.
case: m=> [[|[x y] m] mP] //=; first by rewrite fset0E.
move: mP=> /= /path_sorted/mkfmapK ->.
by rewrite fset_cons.
Qed.

End MapSplitting.

Section FilterMap.

Variables T : ordType.
Variables S R : Type.

Implicit Types (f : T -> S -> option R) (m : {fmap T -> S}).

Definition filter_map f m :=
  mkfmapfp (fun x => obind (f x) (m x)) (domm m).

Lemma filter_mapE f m x : filter_map f m x = obind (f x) (m x).
Proof.
by rewrite /filter_map mkfmapfpE mem_domm; case: (m x).
Qed.

Lemma domm_filter_map f m :
  domm (filter_map f m) = fset_filter (fun x => obind (f x) (m x)) (domm m).
Proof.
apply/eq_fset=> x.
by rewrite mem_domm filter_mapE in_fset_filter mem_domm andbC; case: (m x).
Qed.

Lemma mapimK (g : T -> R -> S) f :
  (forall x y, f x (g x y) = Some y) ->
  cancel (mapim g) (filter_map f).
Proof.
move=> gK m; apply/eq_fmap=> x.
by rewrite filter_mapE mapimE; case: (m x)=> //= z.
Qed.

End FilterMap.

Section Map.

Variables (T : ordType) (S S' : Type).

Implicit Types (m : {fmap T -> S}) (k : T).

Lemma domm_mapi (f : T -> S -> S') m : domm (mapim f m) = domm m.
Proof.
by apply/eq_fset=> k; rewrite !mem_domm mapimE; case: (m k).
Qed.

Lemma domm_map (f : S -> S') m : domm (mapm f m) = domm m.
Proof. exact: domm_mapi. Qed.

Lemma mapim_map (f : S -> S') m : mapim (fun=> f) m = mapm f m.
Proof. by []. Qed.

Lemma eq_mapm f g : f =1 g -> @mapm T S S' f =1 mapm g.
Proof.
move=> e m; apply/eq_fmap=> x; rewrite !mapmE.
by case: (m x)=> [y|] //=; rewrite e.
Qed.

Lemma mapm_comp S'' (g : S' -> S'') (f : S -> S') m :
  mapm (g \o f) m = mapm g (mapm f m).
Proof.
by apply/eq_fmap=> x; rewrite !mapmE; case: (m x).
Qed.

Lemma mapm_mkfmapf (f : S -> S') (g : T -> S) (X : {fset T}) :
  mapm f (mkfmapf g X) = mkfmapf (f \o g) X.
Proof.
by apply/eq_fmap=> x; rewrite !mapmE !mkfmapfE /=; case: ifP.
Qed.

End Map.

Section Map2.

Implicit Types (T : ordType) (S : Type).

Local Open Scope fset_scope.

Definition mapm2 T T' S S' f g (m : {fmap T -> S}) : {fmap T' -> S'} :=
  mkfmap [seq (f p.1, g p.2) | p <- m].

Lemma mapm2E T T' S S' (f : T -> T') (g : S -> S') m x :
  injective f ->
  mapm2 f g m (f x) = omap g (m x).
Proof.
rewrite /mapm2 => f_inj; rewrite mkfmapE /getm.
case: m=> [/= m _]; elim: m=> [|[x' y] m IH] //=.
by rewrite (inj_eq f_inj) [in RHS]fun_if IH.
Qed.

Lemma domm_map2 T T' S S' (f : T -> T') (g : S -> S') m :
  domm (mapm2 f g m) = f @: domm m.
Proof.
apply/eq_fset=> x; rewrite /mapm2 domm_mkfmap /unzip1 -map_comp /comp /=.
by rewrite /domm imfset_fset in_fset -map_comp.
Qed.

Lemma mapm2_comp T T' T'' S S' S'' f f' g g' :
  injective f  ->
  injective f' ->
  mapm2 (f' \o f) (g' \o g) =1
  @mapm2 T' T'' S' T'' f' g' \o @mapm2 T T' S S' f g.
Proof.
move=> f_inj f'_inj m; apply/eq_fmap=> x /=.
have [|xnin] := boolP (x \in domm (mapm2 (f' \o f) (g' \o g) m)).
- rewrite domm_map2; case/imfsetP=> {}x xin ->.
  rewrite mapm2E /=; last exact: inj_comp.
  by rewrite !mapm2E //; case: (m x).
- move: (xnin); rewrite (dommPn xnin).
  rewrite !domm_map2 // imfset_comp -(domm_map2 f g) -(domm_map2 f' g').
  by move/dommPn=> ->.
Qed.

End Map2.

Section EqType.

Variables (T : ordType) (S : eqType).
Implicit Types (m : {fmap T -> S}) (k : T) (v : S).

Lemma getmP m k v : reflect (m k = Some v) ((k, v) \in m).
Proof.
case: m => [s Ps] /=; apply/(iffP idP); rewrite /getm /= inE /=.
  elim: s Ps => [|[k' v'] s IH] //= sorted_s.
  move/(_ (path_sorted sorted_s)) in IH.
  rewrite inE => /orP [/eqP [e_k e_v]|in_s].
    by rewrite -{}e_k -{}e_v {k' v' sorted_s} eqxx.
  have [e_k {IH} |n_k] := altP (k =P k'); last by auto.
  rewrite -{}e_k {k'} in sorted_s.
  suff : Ord.lt k k by rewrite Ord.ltxx.
  move/allP: (order_path_min (@Ord.lt_trans T) sorted_s); apply.
  by apply: map_f in_s.
elim: s Ps=> [|[k' v'] s IH] //= sorted_s.
move/(_ (path_sorted sorted_s)) in IH.
have [e_k [e_v]|n_k get_k] := altP (k =P k').
  by rewrite -{}e_k {}e_v {k' v'} inE eqxx in sorted_s *.
by rewrite inE IH // orbT.
Qed.

Lemma mkfmap_Some (kvs : seq (T * S)) k v
  : mkfmap kvs k = Some v -> (k, v) \in kvs.
Proof.
elim: kvs => [|[k' v'] kvs IH] //=; rewrite setmE.
have [-> [->]|_ H] := altP (_ =P _); first by rewrite inE eqxx.
by rewrite inE IH // orbT.
Qed.

Definition injectivem m := uniq (unzip2 m).

Lemma injectivemP m : reflect {in domm m, injective m} (injectivem m).
Proof.
apply/(iffP idP).
  move=> inj_m k1; rewrite mem_domm; case m_k1: (m k1) => [v|] // _.
  move/getmP in m_k1; move=> k2 /esym/getmP.
  move: inj_m m_k1; rewrite /injectivem.
  have: uniq (unzip1 m).
    apply (sorted_uniq (@Ord.lt_trans T) (@Ord.ltxx T)).
    exact: (valP m).
  rewrite !inE /=; elim: (val m) => [|[k' v'] s IH] //=.
  move=>/andP [k'_nin_s {}/IH IH] /andP [v'_nin_s {}/IH IH].
  rewrite !inE -pair_eqE /=.
  have [k1k'|k1k'] /= := altP (k1 =P k').
    subst k'; have /negbTE ->: (k1, v) \notin s.
      apply: contra k'_nin_s => k'_in_s.
      by apply/mapP; exists (k1, v).
    rewrite orbF=> /eqP ?; subst v'; rewrite eqxx andbT.
    have /negbTE ->: (k2, v) \notin s.
      apply: contra v'_nin_s => v'_in_s.
      by apply/mapP; exists (k2, v).
    by rewrite orbF => /eqP ->.
  move=> k1_in_s; move: (k1_in_s)=> {}/IH IH.
  have [k2k'|k2k'] //= := altP (k2 =P k').
  subst k'; case/orP=> [/eqP ?|//]; subst v'.
  suff c : v \in unzip2 s by rewrite c in v'_nin_s.
  by apply/mapP; exists (k1, v).
move=> inj_m.
rewrite /injectivem map_inj_in_uniq.
  apply: (@map_uniq _ _ (@fst T S)).
  apply: (sorted_uniq (@Ord.lt_trans T) (@Ord.ltxx T)).
  exact: (valP m).
move=> [k1 v] [k2 v'] /= /getmP k1_in_m /getmP k2_in_m ?; subst v'.
move: (inj_m k1); rewrite mem_domm k1_in_m => /(_ erefl k2 (esym k2_in_m)).
congruence.
Qed.

Lemma eq_domm0 (S' : eqType) (m : {fmap T -> S'}) :
  (domm m == fset0) = (m == emptym).
Proof.
apply/(sameP idP)/(iffP idP)=> [/eqP->|/eqP Pdom]; first by rewrite domm0.
apply/eqP/eq_fmap=> k; rewrite emptymE; apply/dommPn.
by rewrite Pdom in_fset0.
Qed.

End EqType.

Section Inverse.

Section Def.

Variables (T S : ordType).

Implicit Type (m : {fmap T -> S}).

Definition invm m := mkfmap [seq (p.2, p.1) | p <- m].

Definition codomm m := domm (invm m).

End Def.

Section Cancel.

Variables (T S : ordType).

Implicit Type (m : {fmap T -> S}).

Open Scope fset_scope.

Lemma getm_inv m k k' : invm m k = Some k' -> m k' = Some k.
Proof.
rewrite /invm =>/mkfmap_Some/mapP [[h h'] /getmP get_k /= [??]].
by subst h h'.
Qed.

Lemma codommP m k : reflect (exists k', m k' = Some k) (k \in codomm m).
Proof.
rewrite /codomm; apply/(iffP idP).
  rewrite mem_domm; case im_k: (invm m k) => [k'|] //= _.
  by rewrite -(getm_inv im_k); eauto.
move=> [k' /getmP m_k'].
rewrite /invm domm_mkfmap; apply/mapP; exists (k, k') => //.
by apply/mapP; exists (k', k).
Qed.

Lemma codommPn m k : reflect (forall k', m k' != Some k) (k \notin codomm m).
Proof.
apply/(iffP idP).
  by move=> h k'; apply: contra h=> /eqP h; apply/codommP; eauto.
move=> h; apply/negP=> /codommP [k' h'].
by move: (h k'); rewrite h' eqxx.
Qed.

Arguments codommP {_ _}.
Arguments codommPn {_ _}.

Lemma codomm0 : codomm (@emptym T S) = fset0.
Proof. by rewrite /codomm /domm fset0E. Qed.

Lemma codomm_rem m k : codomm (remm m k) :<=: codomm m.
Proof.
apply/fsubsetP=> v /codommP [k']; rewrite remmE.
by case: eqP=> // _ Pv; apply/codommP; eauto.
Qed.

Lemma invmE m k : obind m (invm m k) = if invm m k then Some k else None.
Proof.
case get_k: (invm m k) => [k'|] //=.
rewrite /invm in get_k; move/mkfmap_Some/mapP in get_k.
by case: get_k => [[h h'] /getmP get_k [??]]; subst k k'.
Qed.

End Cancel.

Section CancelRev.

Variables (T S : ordType).

Implicit Type (m : {fmap T -> S}).

Lemma invmEV m k :
  {in domm m, injective m} ->
  obind (invm m) (m k) = if m k then Some k else None.
Proof.
move=> inj_m; case m_k: (m k) => [k'|] //=.
move: (invmE m k').
case im_k': (invm m k') => [k''|] //=.
  move=> m_k''; congr Some; apply: inj_m; last by congruence.
  by rewrite mem_domm m_k''.
have /codommPn/(_ k) : k' \notin domm (invm m) by rewrite mem_domm im_k'.
by rewrite m_k eqxx.
Qed.

End CancelRev.

Variables (T S : ordType).

Implicit Type (m : {fmap T -> S}).

Lemma invm_inj m : {in codomm m, injective (invm m)}.
Proof.
move=> k1 in_im k2 h; rewrite mem_domm in in_im.
have {h}: obind m (invm m k1) = obind m (invm m k2) by congruence.
rewrite invmE {}in_im.
case im_k2: (invm m k2) => [k|] //=.
by move/getm_inv in im_k2; congruence.
Qed.

Lemma invmK m : {in domm m, injective m} -> invm (invm m) = m.
Proof.
move=> inj_m; apply/eq_fmap=> k.
move: (invmEV k inj_m).
case m_k: (m k) => [k'|] //= im_k'.
  by move: (invmEV k' (@invm_inj m)); rewrite im_k' /=.
move {im_k'}.
suff : k \notin domm (invm (invm m)) by rewrite mem_domm; case: (invm (invm m) k).
apply/codommPn=> k'; apply/eqP=> im_k'.
by move: (invmE m k'); rewrite im_k' /= m_k.
Qed.

End Inverse.

Arguments codommP {_ _ _ _}.
Arguments codommPn {_ _ _ _}.

Section OfSeq.

Variable (T : Type).

Definition fmap_of_seq (xs : seq T) : {fmap nat -> T} :=
  mkfmapfp (nth None [seq Some x | x <- xs]) (iota 0 (size xs)).

Lemma fmap_of_seqE xs n :
  fmap_of_seq xs n = nth None [seq Some x | x <- xs] n.
Proof.
rewrite /fmap_of_seq mkfmapfpE mem_iota leq0n /= add0n.
case: ltnP=> [l|g] //.
by rewrite nth_default // size_map.
Qed.

End OfSeq.

Section Currying.

Variables (T S : ordType) (R : Type).
Implicit Type (m : {fmap T * S -> R}).
Implicit Type (n : {fmap T -> {fmap S -> R}}).

Local Open Scope fset_scope.

Definition currym m :=
  mkfmapf (fun x => mkfmapfp (fun y => m (x, y))
                                   (@snd _ _ @: domm m))
             (@fst _ _ @: domm m).

Definition uncurrym n : {fmap T * S -> R} :=
  mkfmapfp (fun p : T * S => if n p.1 is Some n' then n' p.2
                             else None)
              (\bigcup_(x <- domm n)
                  if n x is Some n' then pair x @: domm n'
                  else fset0).

Lemma currymP m x y v :
  (exists2 n, currym m x = Some n & n y = Some v) <->
  m (x, y) = Some v.
Proof.
split.
  move=> [n]; rewrite /currym mkfmapfE.
  case: ifP=> [/imfsetP/= [[x' y'] /= E ?]|//]; subst x'.
  move=> [<-] {n}; rewrite mkfmapfpE.
  by case: ifP.
move=> get_xy.
exists (mkfmapfp (fun y' => m (x, y')) (@snd _ _ @: domm m)).
  rewrite /currym mkfmapfE -{1}[x]/(x, y).1 mem_imfset //.
  by rewrite mem_domm get_xy.
by rewrite mkfmapfpE -{1}[y]/(x, y).2 mem_imfset // mem_domm get_xy.
Qed.

Lemma currymE m x y :
  m (x, y) = obind (fun n : {fmap S -> R} => n y) (currym m x).
Proof.
rewrite /currym mkfmapfE.
case: imfsetP=> [[[x' y'] /=]|].
  rewrite mem_domm => get_xy ?; subst x'.
  rewrite mkfmapfpE.
  case get_xy': (m (x, y))=> [v|] //=; last by case: ifP.
  by rewrite -{1}[y]/(x, y).2 mem_imfset // mem_domm get_xy'.
case get_xy: (m (x, y))=> [v|] // h.
suff: False by [].
by apply: h; exists (x, y)=> //; rewrite mem_domm get_xy.
Qed.

Lemma domm_curry m : domm (currym m) = @fst _ _ @: (domm m).
Proof.
by apply/eq_fset=> x; rewrite /currym mem_domm mkfmapfE; case: ifP.
Qed.

Lemma uncurrymP n x y v :
  (exists2 n', n x = Some n' & n' y = Some v) <->
  uncurrym n (x, y) = Some v.
Proof.
pose f x' := if n x' is Some n'' then pair x' @: domm n'' else fset0.
split.
  move=> [n' get_x get_y].
  rewrite /uncurrym mkfmapfpE /= get_x get_y.
  have inDn' : (x, y) \in f x.
    by rewrite /f get_x mem_imfset // mem_domm get_y.
  have inD : x \in domm n by rewrite mem_domm get_x.
  by move/fsubsetP/(_ _ inDn'): (bigcup_sup f inD erefl)=> ->.
rewrite /uncurrym mkfmapfpE /=.
by case: ifP=> [inU|] //=; case: (n x) => [n'|] //= get_y; eauto.
Qed.

Lemma uncurrymE n p :
  uncurrym n p = obind (fun nn => getm nn p.2) (n p.1).
Proof.
case: p=> x y /=.
case e: (uncurrym n (x, y))=> [v|] /=.
  by case/uncurrymP: e => nn -> /= ->.
case e': (n x) => [nn|] //=.
case e'': (nn y) => [v|] //=.
have/uncurrymP : exists2 n', n x = Some n' & n' y = Some v by eauto.
by rewrite e.
Qed.

Lemma currymK : cancel currym uncurrym.
Proof.
move=> m; apply/eq_fmap=> - [x y].
case get_m: (m _)=> [v|]; first by move/currymP/uncurrymP: get_m.
case get_ucm : (uncurrym _ _)=> [v|] //.
by move/uncurrymP/currymP: get_ucm get_m => ->.
Qed.

End Currying.

Section Enumeration.

Variables (T S : ordType).
Implicit Types (m : {fmap T -> S}) (xs : seq T) (ys : seq S).

Local Open Scope fset_scope.

Definition enum_fmap xs ys :=
  foldr (fun x ms => ms ++ [seq setm m x y | m <- ms, y <- ys]) [:: emptym] xs.

Lemma enum_fmapP xs ys m :
  reflect ({subset domm m <= xs} /\ {subset codomm m <= ys})
          (m \in enum_fmap xs ys).
Proof.
elim: xs m=> [|x xs IHx] //= m.
  rewrite inE; apply/(iffP eqP)=> [->|[eq0 _]].
    by rewrite domm0 codomm0; split=> ?; rewrite in_fset0.
  apply/eqP; rewrite -eq_domm0 -fsubset0.
  by apply/fsubsetP=> x /eq0.
rewrite mem_cat.
apply/(iffP orP) => [[/IHx [subx suby] | /allpairsP h] | [subx suby]].
- by split=> // x' x'_in; rewrite inE; apply/orP; right; apply: subx.
- move: m h => m' [[m y] /= [/IHx [subx suby] h ->]] {m'}; split.
    rewrite domm_set=> x' /fsetU1P [->|/subx]; rewrite inE ?eqxx //.
    by move=> ->; rewrite orbT.
  move=> y' /codommP [x']; rewrite setmE.
  case: eqP=> [_ [<-] //| _ m_x']; apply: suby.
  by apply/codommP; eauto.
have [/dommP [y h]|x_nin] := boolP (x \in domm m).
  right; apply/allpairsP; exists (remm m x, y)=> /=; split.
  - apply/IHx; rewrite domm_rem; split.
      by move=> x' /fsetDP [/subx]; rewrite inE => /orP [/eqP -> /fset1P|].
    move=> y' /codommP [x' m_x']; apply: suby; apply/codommP.
    by exists x'; move: m_x'; rewrite remmE; case: ifP.
  - by apply: suby; apply/codommP; exists x.
  by apply/eq_fmap=> x'; rewrite setmE remmE; case: eqP => [->|].
left; apply/IHx; split=> // x' x'_in; move/(_ _ x'_in): subx (x'_in) x_nin.
by rewrite inE => /orP [/eqP -> ->|].
Qed.

End Enumeration.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (y : natural) (z : natural) (x : natural) : natural :=
  mult z (Succ (plus x y)).


Require Import Reals Coquelicot.Coquelicot.
Require Import Interval.Tactic.

Lemma constant :
  3 <= RInt (fun x => 1) 0 3 <= 3.
Proof.
interval.
Qed.

Lemma exp_0_3 :
  Rabs (RInt (fun x => exp x) 0 3 - (exp(1)*exp(1)*exp(1) - 1)) <= 1/(1000*1000).
Proof.
interval with (i_integral_depth 0, i_integral_deg 12).
Qed.

Lemma exp_0_3' :
  Rabs (RInt (fun x => exp x) 0 3 - (exp(1)*exp(1)*exp(1) - 1)) <= 1/(1000*1000).
Proof.
interval with (i_integral_depth 1, i_integral_prec 20).
Qed.

Lemma x_ln1p_0_1 :
  Rabs (RInt (fun x => x * ln(1 + x)) 0 1 - 1/4) <= 1/1000.
Proof.
interval with (i_integral_depth 0).
Qed.

Lemma circle :
  Rabs (RInt (fun x => sqrt(1 - x * x)) 0 1 - PI / 4) <= 1/100.
Proof.
interval with (i_integral_depth 10, i_integral_deg 1).
Qed.

Lemma exp_cos_0_1 :
  Rabs (RInt (fun x => sin(x) * exp(cos x)) 0 1 - (exp 1 - exp(cos 1))) <= 1/1000.
Proof.
interval with (i_integral_depth 0).
Qed.

Lemma arctan_0_1 :
  Rabs (RInt (fun x => 1 / (1 + x*x)) 0 1 - PI / 4) <= 1/1000.
Proof.
interval with (i_integral_depth 0, i_integral_deg 13).
Qed.

Lemma arctan_0_1' :
  Rabs (RInt (fun x => 1 / (1 + x*x)) 0 1 - PI / 4) <= 1/1000.
Proof.
interval with (i_integral_depth 1).
Qed.


Require Import Omega.
Require Import List.
Import ListNotations.
Require Import StructTact.StructTactics.
Require Import StructTact.ListTactics.
Require Import StructTact.FilterMap.
Require Import StructTact.RemoveAll.

Set Implicit Arguments.

Fixpoint subseq {A} (xs ys : list A) : Prop :=
  match xs, ys with
    | [], _ => True
    | x :: xs', y :: ys' => (x = y /\ subseq xs' ys') \/ subseq xs ys'
    | _, _ => False
  end.

Section subseq.
  Variable A B : Type.
  Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}.

  Lemma subseq_refl : forall (l : list A), subseq l l.
  Proof using.
    induction l; simpl; tauto.
  Qed.

  Lemma subseq_trans :
    forall (zs xs ys : list A),
      subseq xs ys ->
      subseq ys zs ->
      subseq xs zs.
  Proof using.
    induction zs; intros; simpl in *;
      repeat break_match; subst; simpl in *; intuition; subst; eauto;
        right; (eapply IHzs; [|eauto]); simpl; eauto.
  Qed.

  Lemma subseq_In :
    forall (ys xs : list A) x,
      subseq xs ys ->
      In x xs ->
      In x ys.
  Proof using.
    induction ys; intros.
    - destruct xs; simpl in *; intuition.
    - simpl in *. break_match; simpl in *; intuition; subst; intuition eauto;
                    right; (eapply IHys; [eauto| intuition]).
  Qed.

  Theorem subseq_NoDup :
    forall (ys xs : list A),
      subseq xs ys ->
      NoDup ys ->
      NoDup xs.
  Proof using.
    induction ys; intros.
    - destruct xs; simpl in *; intuition.
    - simpl in *. invc_NoDup.
      break_match.
      + constructor.
      + intuition.
        subst. constructor; eauto using subseq_In.
  Qed.

  Lemma subseq_remove :
    forall (x : A) xs,
      subseq (remove A_eq_dec x xs) xs.
  Proof using.
    induction xs; intros; simpl.
    - auto.
    - repeat break_match; auto.
      + intuition congruence.
      + find_inversion. auto.
  Qed.

  Lemma subseq_map :
    forall (f : A -> B) ys xs,
      subseq xs ys ->
      subseq (map f xs) (map f ys).
  Proof using.
    induction ys; intros; simpl in *.
    - repeat break_match; try discriminate; auto.
    - repeat break_match; try discriminate; auto.
      intuition.
      + subst. simpl in *. find_inversion. auto.
      + right. repeat find_reverse_rewrite. auto.
  Qed.

  Lemma subseq_cons_drop :
    forall xs ys (a : A),
      subseq (a :: xs) ys -> subseq xs ys.
  Proof using.
    induction ys; intros; simpl in *; intuition; break_match; eauto.
  Qed.

  Lemma subseq_length :
    forall (ys xs : list A),
      subseq xs ys ->
      length xs <= length ys.
  Proof using.
    induction ys; intros; simpl in *; break_match; intuition.
    subst. simpl in *. specialize (IHys l). concludes. auto with *.
  Qed.

  Lemma subseq_subseq_eq :
    forall (xs ys : list A),
      subseq xs ys ->
      subseq ys xs ->
      xs = ys.
  Proof using.
    induction xs; intros; destruct ys; simpl in *;
      intuition eauto using f_equal2, subseq_cons_drop.
    exfalso.
    repeat find_apply_lem_hyp subseq_length.
    simpl in *. omega.
  Qed.

  Lemma subseq_filter :
    forall (f : A -> bool) xs,
      subseq (filter f xs) xs.
  Proof using.
    induction xs; intros; simpl.
    - auto.
    - repeat break_match; intuition congruence.
  Qed.

  Lemma subseq_nil :
    forall xs,
      subseq (A:=A) [] xs.
  Proof using.
    destruct xs; simpl; auto.
  Qed.

  Lemma subseq_skip :
    forall a xs ys,
      subseq(A:=A) xs ys ->
      subseq xs (a :: ys).
  Proof using.
    induction ys; intros; simpl in *; repeat break_match; intuition.
  Qed.

  Lemma subseq_filterMap :
    forall (f : B -> option A) ys xs,
      subseq xs ys ->
      subseq (filterMap f xs) (filterMap f ys).
  Proof using.
    induction ys; intros; simpl in *; repeat break_match; auto; try discriminate; intuition; subst.
    - simpl. find_rewrite. auto.
    - auto using subseq_skip.
    - auto using subseq_nil.
    - simpl. find_rewrite. auto.
  Qed.

  Lemma subseq_app_r :
    forall xs ys,
      subseq (A:=A) ys (xs ++ ys).
  Proof using.
    induction xs; intros; simpl.
    + auto using subseq_refl.
    + break_match.
      * auto.
      * right. auto using subseq_nil.
  Qed.

  Lemma subseq_app_tail :
    forall ys xs zs,
      subseq (A:=A) xs ys ->
      subseq (xs ++ zs) (ys ++ zs).
  Proof using.
    induction ys; intros; simpl in *.
    - break_match; intuition auto using subseq_refl.
    - repeat break_match.
      + auto.
      + discriminate.
      + simpl in *. subst. right. auto using subseq_app_r.
      + simpl in *. find_inversion. intuition.
        rewrite app_comm_cons. auto.
  Qed.

  Lemma subseq_app_head :
    forall xs ys zs,
      subseq (A:=A) ys zs ->
      subseq (A:=A) (xs ++ ys) (xs ++ zs).
  Proof using.
    induction xs; intros; simpl; intuition.
  Qed.

  Lemma subseq_2_3 :
    forall xs ys zs x y,
      subseq(A:=A) (xs ++ ys ++ zs) (xs ++ x :: ys ++ y :: zs).
  Proof using.
    auto using subseq_refl, subseq_skip, subseq_app_head.
  Qed.

  Lemma subseq_middle :
    forall xs y zs,
      subseq (A:=A) (xs ++ zs) (xs ++ y :: zs).
  Proof using.
    intros.
    apply subseq_app_head.
    apply subseq_skip.
    apply subseq_refl.
  Qed.

  Lemma subseq_remove_all :
    forall (ds l l' : list A),
      subseq l l' ->
      subseq (remove_all A_eq_dec ds l) l'.
  Proof using.
    induction ds; intros; simpl.
    - auto.
    - apply IHds.
      eapply subseq_trans.
      apply subseq_remove.
      auto.
  Qed.
End subseq.


(** * SearchTree: Binary Search Trees *)

(** We have implemented maps twice so far: with lists in
    [Lists], and with higher-order functions in [Maps].
    Those are simple but inefficient implementations: looking up the
    value bound to a given key takes time linear in the number of
    bindings, both in the worst and expected case. *)

(** If the type of keys can be totally ordered -- that is, it supports
    a well-behaved [<=] comparison -- then maps can be implemented with
    _binary search trees_ (BSTs).  Insert and lookup operations on
    BSTs take time proportional to the height of the tree.  If the
    tree is balanced, the operations therefore take logarithmic time. *)

(** If you don't recall BSTs or haven't seen them in a while, see
    Wikipedia or read any standard textbook; for example:

    - Section 3.2 of _Algorithms, Fourth Edition_, by Sedgewick and
      Wayne, Addison Wesley 2011; or

    - Chapter 12 of _Introduction to Algorithms, 3rd Edition_, by
      Cormen, Leiserson, and Rivest, MIT Press 2009. *)

From Coq Require Import String.  (* for an example, and manual grading *)
From Coq Require Import Logic.FunctionalExtensionality.
From VFA Require Import Perm.
From VFA Require Import Maps.
From VFA Require Import Sort.

(* ################################################################# *)
(** * BST Implementation *)

(** We use [nat] as the key type in our implementation of BSTs,
    since it has a convenient total order [<=?] with lots of theorems
    and automation available. *)

Definition key := nat.

(** [E] represents the empty map.  [T l k v r] represents the
    map that binds [k] to [v], along with all the bindings in [l] and
    [r].  No key may be bound more than once in the map. *)

Inductive tree (V : Type) : Type :=
| E
| T (l : tree V) (k : key) (v : V) (r : tree V).

Arguments E {V}.
Arguments T {V}.

(** An example tree:

      4 -> "four"
      /        \
     /          \
  2 -> "two"   5 -> "five"
*)

Definition ex_tree : tree string :=
  (T (T E 2 "two" E) 4 "four" (T E 5 "five" E))%string.

(** [empty_tree] contains no bindings. *)

Definition empty_tree {V : Type} : tree V :=
  E.

(** [bound k t] is whether [k] is bound in [t]. *)

Fixpoint bound {V : Type} (x : key) (t : tree V) :=
  match t with
  | E => false
  | T l y v r => if x <? y then bound x l
                else if x >? y then bound x r
                     else true
  end.

(** [lookup d k t] is the value bound to [k] in [t], or is default
    value [d] if [k] is not bound in [t]. *)

Fixpoint lookup {V : Type} (d : V) (x : key) (t : tree V) : V :=
  match t with
  | E => d
  | T l y v r => if x <? y then lookup d x l
                else if x >? y then lookup d x r
                     else v
  end.

(** [insert k v t] is the map containing all the bindings of [t] along
    with a binding of [k] to [v]. *)

Fixpoint insert {V : Type} (x : key) (v : V) (t : tree V) : tree V :=
  match t with
  | E => T E x v E
  | T l y v' r => if x <? y then T (insert x v l) y v' r
                 else if x >? y then T l y v' (insert x v r)
                      else T l x v r
  end.

(** Note that [insert] is a _functional_ aka _persistent_
    implementation: [t] is not changed. *)

Module Tests.

(** Here are some unit tests to check that BSTs behave the way we
    expect. *)

  Open Scope string_scope.

  Example bst_ex1 :
    insert 5 "five" (insert 2 "two" (insert 4 "four" empty_tree)) = ex_tree.
  Proof. reflexivity. Qed.

  Example bst_ex2 : lookup "" 5 ex_tree = "five".
  Proof. reflexivity. Qed.

  Example bst_ex3 : lookup "" 3 ex_tree = "".
  Proof. reflexivity. Qed.

  Example bst_ex4 : bound 3 ex_tree = false.
  Proof. reflexivity. Qed.

End Tests.

(** Although we can spot-check the behavior of BST operations with
    unit tests like these, we of course should prove general theorems
    about their correctness.  We will do that later in the chapter. *)

(* ################################################################# *)
(** * BST Invariant *)

(** The implementations of [lookup] and [insert] assume that
    values of type [tree] obey the _BST invariant_: for any non-empty
    node with key [k], all the values of the left subtree are less
    than [k] and all the values of the right subtree are greater than
    [k].  But that invariant is not part of the definition of
    [tree]. For example, the following tree is not a BST: *)

Module NotBst.
  Open Scope string_scope.

  Definition t : tree string :=
    T (T E 5 "five" E) 4 "four" (T E 2 "two" E).

  (** The [insert] function we wrote above would never produce
      such a tree, but we can still construct it by manually applying
      [T]. When we try to lookup [2] in that tree, we get the wrong
      answer, because [lookup] assumes [2] is in the left subtree: *)

  Example not_bst_lookup_wrong :
    lookup "" 2 t <> "two".
  Proof.
    simpl. unfold not. intros contra. discriminate.
  Qed.
End NotBst.

(** So, let's formalize the BST invariant. Here's one way to do
    so.  First, we define a helper [ForallT] to express that idea that
    a predicate holds at every node of a tree: *)

Fixpoint ForallT {V : Type} (P: key -> V -> Prop) (t: tree V) : Prop :=
  match t with
  | E => True
  | T l k v r => P k v /\ ForallT P l /\ ForallT P r
  end.

(** Second, we define the BST invariant:

    - An empty tree is a BST.

    - A non-empty tree is a BST if all its left nodes have a lesser
      key, its right nodes have a greater key, and the left and
      right subtrees are themselves BSTs. *)

Inductive BST {V : Type} : tree V -> Prop :=
| BST_E : BST E
| BST_T : forall l x v r,
    ForallT (fun y _ => y < x) l ->
    ForallT (fun y _ => y > x) r ->
    BST l ->
    BST r ->
    BST (T l x v r).

Hint Constructors BST.

(** Let's check that [BST] correctly classifies a couple of example
    trees: *)

Example is_BST_ex :
  BST ex_tree.
Proof.
  unfold ex_tree.
  repeat (constructor; try omega).
Qed.

Example not_BST_ex :
  ~ BST NotBst.t.
Proof.
  unfold NotBst.t. intros contra.
  inv contra. inv H3. omega.
Qed.

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

(** Prove that the empty tree is a BST. *)

Theorem empty_tree_BST : forall (V : Type),
    BST (@empty_tree V).
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 4 stars, standard (insert_BST)  *)

(** Prove that [insert] produces a BST, assuming it is given one.

    Start by proving this helper lemma, which says that [insert]
    preserves any node predicate. Proceed by induction on [t]. *)

Lemma ForallT_insert : forall (V : Type) (P : key -> V -> Prop) (t : tree V),
    ForallT P t -> forall (k : key) (v : V),
      P k v -> ForallT P (insert k v t).
Proof.
  (* FILL IN HERE *) Admitted.

(** Now prove the main theorem. Proceed by induction on the evidence
    that [t] is a BST. *)

Theorem insert_BST : forall (V : Type) (k : key) (v : V) (t : tree V),
    BST t -> BST (insert k v t).
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** Since [empty_tree] and [insert] are the only operations that
    create BSTs, we are guaranteed that any [tree] is a BST -- unless
    it was constructed manually with [T].  It would therefore make
    sense to limit the use of [T] to only within the tree operations,
    rather than expose it.  Coq, like OCaml and other functional
    languages, can do this with its module system.  See [ADT] for
    details. *)

(* ################################################################# *)
(** * Correctness of BST Operations *)

(** To prove the correctness of [lookup] and [bound], we need
    specifications for them.  We'll study two different techniques for
    that in this chapter. *)

(** The first is called _algebraic specification_.  With it, we write
    down equations relating the results of operations.  For example,
    we could write down equations like the following to specify the
    [+] and [*] operations:

      (a + b) + c = a + (b + c)
      a + b = b + a
      a + 0 = a
      (a * b) * c = a * (b * c)
      a * b = b * a
      a * 1 = a
      a * 0 = 0
      a * (b + c) = a * b + a * c

    For BSTs, let's examine how [lookup] should interact with
    when applied to other operations.  It is easy to see what needs to
    be true for [empty_tree]: looking up any value at all in the empty
    tree should fail and return the default value:

      lookup d k empty_tree = d

    What about non-empty trees?  The only way to build a non-empty
    tree is by applying [insert k v t] to an existing tree [t]. So it
    suffices to describe the behavior of [lookup] on the result of an
    arbitrary [insert] operation. There are two cases.  If we look up
    the same key that was just inserted, we should get the value that
    was inserted with it:

      lookup d k (insert k v t) = v

    If we look up a different key than was just inserted, the insert
    should not affect the answer -- which should be the same as if we
    did the lookup in the original tree before the insert occured:

      lookup d k' (insert k v t) = lookup d k' t      if k <> k'

    These three basic equations specify the correct behavior of maps.
    Let's prove that they hold. *)

Theorem lookup_empty : forall (V : Type) (d : V) (k : key),
    lookup d k empty_tree = d.
Proof.
  auto.
Qed.

Theorem lookup_insert_eq : forall (V : Type) (t : tree V) (d : V) (k : key) (v : V),
    lookup d k (insert k v t)  = v.
Proof.
  induction t; intros; simpl.
  - bdestruct (k <? k); try omega; auto.
  - bdestruct (k <? k0); bdestruct (k0 <? k); simpl; try omega; auto.
    + bdestruct (k <? k0); bdestruct (k0 <? k); try omega; auto.
    + bdestruct (k <? k0); bdestruct (k0 <? k); try omega; auto.
    + bdestruct (k0 <? k0); try omega; auto.
Qed.

(** The basic method of that proof is to repeatedly [bdestruct]
    everything in sight, followed by generous use of [omega] and
    [auto]. Let's automate that. *)

Ltac bdestruct_guard :=
  match goal with
  | |- context [ if ?X =? ?Y then _ else _ ] => bdestruct (X =? Y)
  | |- context [ if ?X <=? ?Y then _ else _ ] => bdestruct (X <=? Y)
  | |- context [ if ?X <? ?Y then _ else _ ] => bdestruct (X <? Y)
  end.

Ltac bdall :=
  repeat (simpl; bdestruct_guard; try omega; auto).

Theorem lookup_insert_eq' :
  forall (V : Type) (t : tree V) (d : V) (k : key) (v : V),
    lookup d k (insert k v t) = v.
Proof.
  induction t; intros; bdall.
Qed.

(** The tactic immediately pays off in proving the third
    equation. *)

Theorem lookup_insert_neq :
  forall (V : Type) (t : tree V) (d : V) (k k' : key) (v : V),
   k <> k' -> lookup d k' (insert k v t) = lookup d k' t.
Proof.
  induction t; intros; bdall.
Qed.

(** Perhaps surprisingly, the proofs of these results do not
    depend on whether [t] satisfies the BST invariant.  That's because
    [lookup] and [insert] follow the same path through the tree, so
    even if nodes are in the "wrong" place, they are consistently
    "wrong". *)

(** **** Exercise: 3 stars, standard, optional (bound_correct)  *)

(** Specify and prove the correctness of [bound]. State and prove
    three theorems, inspired by those we just proved for [lookup]. If
    you have the right theorem statements, the proofs should all be
    quite easy -- thanks to [bdall]. *)

(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_bound_correct : option (nat*string) := None.
(** [] *)

(** **** Exercise: 3 stars, standard, optional (bound_default)  *)

(** Prove that if [bound] returns [false], then [lookup] returns
    the default value. Proceed by induction on the tree. *)

Theorem bound_default :
  forall (V : Type) (k : key) (d : V) (t : tree V),
    bound k t = false ->
    lookup d k t = d.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(* ################################################################# *)
(** * BSTs vs. Higher-order Functions (Optional) *)

(** The three theorems we just proved for [lookup] should seem
    familiar: we proved equivalent theorems in [Maps] for maps
    defined as higher-order functions. *)

(** - [lookup_empty] and [t_apply_empty] both state that the empty map
      binds all keys to the default value. *)

Check lookup_empty : forall (V : Type) (d : V) (k : key),
    lookup d k empty_tree = d.

Check t_apply_empty : forall (V : Type) (k : key) (d : V),
    t_empty d k = d.

(** - [lookup_insert_eq] and [t_update_eq] both state that updating a map
      then looking for the updated key produces the updated value. *)

Check lookup_insert_eq : forall (V : Type) (t : tree V) (d : V) (k : key) (v : V),
    lookup d k (insert k v t) = v.

Check t_update_eq : forall (V : Type) (m : total_map V) (k : key) (v : V),
    (t_update m k v) k = v.

(** - [lookup_insert_neq] and [t_update_neq] both state that updating
      a map then looking for a different key produces the same value
      as the original map. *)

Check lookup_insert_neq :
  forall (V : Type) (t : tree V) (d : V) (k k' : key) (v : V),
    k <> k' -> lookup d k' (insert k v t) = lookup d k' t.

Check t_update_neq : forall (V : Type) (v : V) (k k' : key) (m : total_map V),
    k <> k' -> (t_update m k v) k' = m k'.

(** In [Maps], we also proved three other theorems about the
    behavior of functional maps on various combinations of updates and
    lookups: *)

Check t_update_shadow : forall (V : Type) (m : total_map V) (v1 v2 : V) (k : key),
    t_update (t_update m k v1) k v2 = t_update m k v2.

Check t_update_same : forall (V : Type) (k : key) (m : total_map V),
    t_update m k (m k) = m.

Check t_update_permute :
  forall (V : Type) (v1 v2 : V) (k1 k2 : key) (m : total_map V),
    k2 <> k1 ->
    t_update (t_update m k2 v2) k1 v1 = t_update (t_update m k1 v1) k2 v2.

(** Let's prove analogues to these three theorems for search trees.

    Hint: you do not need to unfold the definitions of [empty_tree],
    [insert], or [lookup].  Instead, use [lookup_insert_eq] and
    [lookup_insert_neq]. *)

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

Lemma lookup_insert_shadow :
  forall (V : Type) (t : tree V) (v v' d: V) (k k' : key),
    lookup d k' (insert k v (insert k v' t)) = lookup d k' (insert k v t).
Proof.
  intros. bdestruct (k =? k').
  (* FILL IN HERE *) Admitted.

(** [] *)

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

Lemma lookup_insert_same :
  forall (V : Type) (k k' : key) (d : V) (t : tree V),
    lookup d k' (insert k (lookup d k t) t) = lookup d k' t.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

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

Lemma lookup_insert_permute :
  forall (V : Type) (v1 v2 d : V) (k1 k2 k': key) (t : tree V),
    k1 <> k2 ->
    lookup d k' (insert k1 v1 (insert k2 v2 t))
    = lookup d k' (insert k2 v2 (insert k1 v1 t)).
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** Our ability to prove these lemmas without reference to the
    underlying tree implementation demonstrates they hold for any map
    implementation that satisfies the three basic equations. *)

(** Each of these lemmas just proved was phrased as an equality
    between the results of looking up an arbitrary key [k'] in two
    maps.  But the lemmas for the function-based maps were phrased as
    direct equalities between the maps themselves.

    Could we state the tree lemmas with direct equalities?  For
    [insert_shadow], the answer is yes: *)

Lemma insert_shadow_equality : forall (V : Type) (t : tree V) (k : key) (v v' : V),
    insert k v (insert k v' t) = insert k v t.
Proof.
  induction t; intros; bdall.
  - rewrite IHt1; auto.
  - rewrite IHt2; auto.
Qed.

(** But the other two direct equalities on BSTs do not necessarily
    hold. *)

(** **** Exercise: 3 stars, standard, optional (direct_equalities_break)  *)

(** Prove that the other equalities do not hold.  Hint: find a counterexample
    first on paper, then use the [exists] tactic to instantiate the theorem
    on your counterexample.  The simpler your counterexample, the simpler
    the rest of the proof will be. *)

Lemma insert_same_equality_breaks :
  exists (V : Type) (d : V) (t : tree V) (k : key),
      insert k (lookup d k t) t <> t.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma insert_permute_equality_breaks :
  exists (V : Type) (v1 v2 : V) (k1 k2 : key) (t : tree V),
    k1 <> k2 /\ insert k1 v1 (insert k2 v2 t) <> insert k2 v2 (insert k1 v1 t).
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(* ################################################################# *)
(** * Converting a BST to a List *)

(** Let's add a new operation to our BST: converting it to an
    _association list_ that contains the key--value bindings from the
    tree stored as pairs.  If that list is sorted by the keys, then
    any two trees that represent the same map would be converted to
    the same list. Here's a function that does so with an in-order
    traversal of the tree: *)

Fixpoint elements {V : Type} (t : tree V) : list (key * V) :=
  match t with
  | E => []
  | T l k v r => elements l ++ [(k, v)] ++ elements r
  end.

Example elements_ex :
    elements ex_tree = [(2, "two"); (4, "four"); (5, "five")]%string.
Proof. reflexivity. Qed.

(** Here are three desirable properties for [elements]:

    1. The list has the same bindings as the tree.

    2. The list is sorted by keys.

    3. The list contains no duplicates.

    Let's formally specify and verify them. *)

(* ================================================================= *)
(** ** Part 1: Same Bindings *)

(** We want to show that a binding is in [elements t] iff it's in
    [t]. We'll prove the two directions of that bi-implication
    separately:

    - [elements] is _complete_: if a binding is in [t] then it's in
      [elements t].

    - [elements] is _correct_: if a binding is in [elements t] then
      it's in [t].  *)

(** Getting the specification of completeness right is a little
    tricky.  It's tempting to start off with something too simple like
    this: *)

Definition elements_complete_broken_spec :=
  forall (V : Type) (k : key) (v d : V) (t : tree V),
    BST t ->
    lookup d k t = v ->
    In (k, v) (elements t).

(** The problem with that specification is how it handles the default
    element [d]: the specification would incorrectly require [elements
    t] to contain a binding [(k, d)] for all keys [k] unbound in
    [t]. That would force [elements t] to be infinitely long, since
    it would have to contain a binding for every natural number. We can
    observe this problem right away if we begin the proof: *)

Theorem elements_complete_broken : elements_complete_broken_spec.
Proof.
  unfold elements_complete_broken_spec. intros. induction t.
  - (* t = E *) simpl.
    (** We have nothing to work with, since [elements E] is [[]]. *)
Abort.

(** The solution is to check first to see whether [k] is bound in [t].
    Only bound keys need be in the list of elements: *)

Definition elements_complete_spec :=
  forall (V : Type) (k : key) (v d : V) (t : tree V),
    BST t ->
    bound k t = true ->
    lookup d k t = v ->
    In (k, v) (elements t).

(** **** Exercise: 3 stars, standard (elements_complete)  *)

(** Prove that [elements] is complete. Proceed by induction on [t]. *)

Theorem elements_complete : elements_complete_spec.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** The specification for correctness likewise mentions that the
    key must be bound: *)

Definition elements_correct_spec :=
  forall (V : Type) (k : key) (v d : V) (t : tree V),
    BST t ->
    In (k, v) (elements t) ->
    bound k t = true /\ lookup d k t = v.

(** Proving correctness requires more work than completeness.

    [BST] uses [ForallT] to say that all nodes in the left/right
    subtree have smaller/greater keys than the root.  We need to
    relate [ForallT], which expresses that all nodes satisfy a
    property, to [Forall], which expresses that all list elements
    satisfy a property.

    We begin with this lemma about [Forall], which is missing from the
    standard library. *)

Lemma Forall_app : forall (A: Type) (P : A -> Prop) (l1 l2 : list A),
    Forall P l1 -> Forall P l2 -> Forall P (l1 ++ l2).
Proof.
  induction l1; intros; simpl; auto; inv H; constructor; auto.
Qed.

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

(** Prove that if a property [P] holds of every node in a tree [t],
    then that property holds of every pair in [elements t]. Proceed
    by induction on [t].

    There is a little mismatch between the type of [P] in [ForallT]
    and the type of the property accepted by [Forall], so we have to
    _uncurry_ [P] when we pass it to [Forall]. (See [Poly] for
    more about uncurrying.) The single quote used below is the Coq
    syntax for doing a pattern match in the function arguments. *)

Definition uncurry {X Y Z : Type} (f : X -> Y -> Z) '(a, b) :=
  f a b.

Hint Transparent uncurry.

Lemma elements_preserves_forall : forall (V : Type) (P : key -> V -> Prop) (t : tree V),
    ForallT P t ->
    Forall (uncurry P) (elements t).
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

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

(** Prove that if all the keys in [t] are in a relation [R] with a
    distinguished key [k'], then any key [k] in [elements t] is also
    related by [R] to [k']. For example, [R] could be [<], in which
    case the lemma says that if all the keys in [t] are less than
    [k'], then all the keys in [elements t] are also less than
    [k'].

    Hint: you don't need induction.  Immediately look for a way
    to use [elements_preserves_forall] and library theorem
    [Forall_forall]. *)

Lemma elements_preserves_relation :
  forall (V : Type) (k k' : key) (v : V) (t : tree V) (R : key -> key -> Prop),
    ForallT (fun y _ => R y k') t
    -> In (k, v) (elements t)
    -> R k k'.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 4 stars, standard (elements_correct)  *)

(** Prove that [elements] is correct. Proceed by induction on the
    evidence that [t] is a BST. *)

Theorem elements_correct : elements_correct_spec.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** The inverses of completeness and correctness also should hold:

    - inverse completeness: if a binding is not in [t] then it's not
      in [elements t].

    - inverse correctness: if a binding is not in [elements t] then
      it's not in [t].

    Let's prove that they do. *)

(** **** Exercise: 2 stars, advanced (elements_complete_inverse)  *)

(** This inverse doesn't require induction.  Look for a way to use
    [elements_correct] to quickly prove the result. *)

Theorem elements_complete_inverse :
  forall (V : Type) (k : key) (v : V) (t : tree V),
    BST t ->
    bound k t = false ->
    ~ In (k, v) (elements t).
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 4 stars, advanced (elements_correct_inverse)  *)

(** Prove the inverse.  First, prove this helper lemma by induction on
    [t]. *)

Lemma bound_value : forall (V : Type) (k : key) (t : tree V),
    bound k t = true -> exists v, forall d, lookup d k t = v.
Proof.
  (* FILL IN HERE *) Admitted.

(** Prove the main result.  You don't need induction. *)

Theorem elements_correct_inverse :
  forall (V : Type) (k : key) (t : tree V),
    BST t ->
    (forall v, ~ In (k, v) (elements t)) ->
    bound k t = false.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** Part 2: Sorted (Advanced) *)

(** We want to show that [elements] is sorted by keys.  We follow a
    proof technique contributed by Lydia Symmons et al.*)

(** **** Exercise: 3 stars, advanced (sorted_app)  *)

(** Prove that inserting an intermediate value between two lists
    maintains sortedness. Proceed by induction on the evidence
    that [l1] is sorted. *)

Lemma sorted_app: forall l1 l2 x,
  Sort.sorted l1 -> Sort.sorted l2 ->
  Forall (fun n => n < x) l1 -> Forall (fun n => n > x) l2 ->
  Sort.sorted (l1 ++ x :: l2).
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 4 stars, advanced (sorted_elements)  *)

(** The keys in an association list are the first elements of every
    pair: *)

Definition list_keys {V : Type} (lst : list (key * V)) :=
  map fst lst.

(** Prove that [elements t] is sorted by keys. Proceed by induction
    on the evidence that [t] is a BST. *)

Theorem sorted_elements : forall (V : Type) (t : tree V),
    BST t -> Sort.sorted (list_keys (elements t)).
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** Part 3: No Duplicates (Advanced and Optional) *)

(** We want to show that [elements t] contains no duplicate
    bindings. Tree [t] itself cannot contain any duplicates, so the
    list that [elements] produces shouldn't either. The standard
    library already contains a helpful inductive proposition,
    [NoDup]. *)

Print NoDup.

(** The library is missing a theorem, though, about [NoDup] and [++].
    To state that theorem, we first need to formalize what it means
    for two lists to be disjoint: *)

Definition disjoint {X:Type} (l1 l2: list X) := forall (x : X),
    In x l1 -> ~ In x l2.

(** **** Exercise: 3 stars, advanced, optional (NoDup_append)  *)

(** Prove that if two lists are disjoint, appending them preserves
    [NoDup].  Hint: You might already have proved this theorem in an
    advanced exercise in [IndProp]. *)

Lemma NoDup_append : forall (X:Type) (l1 l2: list X),
  NoDup l1 -> NoDup l2 -> disjoint l1 l2 ->
  NoDup (l1 ++ l2).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, advanced, optional (elements_nodup_keys)  *)

(** Prove that there are no duplicate keys in the list returned
    by [elements]. Proceed by induction on the evidence that [t] is a
    BST. Make use of library theorems about [map] as needed. *)

Theorem elements_nodup_keys : forall (V : Type) (t : tree V),
    BST t ->
    NoDup (list_keys (elements t)).
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** That concludes the proof of correctness of [elements]. *)

(* ################################################################# *)
(** * A Faster [elements] Implementation *)

(** The implemention of [elements] is inefficient because of how
    it uses the [++] operator.  On a balanced tree its running time is
    linearithmic, because it does a linear number of concatentations
    at each level of the tree. On an unbalanced tree it's quadratic
    time.  Here's a tail-recursive implementation than runs in linear
    time, regardless of whether the tree is balanced: *)

Fixpoint fast_elements_tr {V : Type} (t : tree V)
         (acc : list (key * V)) : list (key * V) :=
  match t with
  | E => acc
  | T l k v r => fast_elements_tr l ((k, v) :: fast_elements_tr r acc)
  end.

Definition fast_elements {V : Type} (t : tree V) : list (key * V) :=
  fast_elements_tr t [].

(** **** Exercise: 3 stars, standard (fast_elements_eq_elements)  *)

(** Prove that [fast_elements] and [elements] compute the same
    function. *)

Lemma fast_elements_tr_helper :
  forall (V : Type) (t : tree V) (lst : list (key * V)),
    fast_elements_tr t lst = elements t ++ lst.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma fast_elements_eq_elements : forall (V : Type) (t : tree V),
    fast_elements t = elements t.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** Since the two implementations compute the same function, all
    the results we proved about the correctness of [elements]
    also hold for [fast_elements].  For example: *)

Corollary fast_elements_correct :
  forall (V : Type) (k : key) (v d : V) (t : tree V),
    BST t ->
    In (k, v) (fast_elements t) ->
    bound k t = true /\ lookup d k t = v.
Proof.
  intros. rewrite fast_elements_eq_elements in *.
  apply elements_correct; assumption.
Qed.

(** This corollary illustrates a general technique:  prove the correctness
    of a simple, slow implementation; then prove that the slow version
    is functionally equivalent to a fast implementation.  The proof of
    correctness for the fast implementation then comes "for free". *)

(* ################################################################# *)
(** * An Algebraic Specification of [elements] *)

(** The verification of [elements] we did above did not adhere to the
    algebraic specification approach, which would suggest that we look
    for equations of the form

      elements empty_tree = ...
      elements (insert k v t) = ... (elements t) ...

    The first of these is easy; we can trivially prove the following:
    *)

Lemma elements_empty : forall (V : Type),
    @elements V empty_tree = [].
Proof.
  intros. simpl. reflexivity.
Qed.

(** But for the second equation, we have to express the result of
    inserting [(k, v)] into the elements list for [t], accounting for
    ordering and the possibility that [t] may already contain a pair
    [(k, v')] which must be replaced.  The following rather ugly
    function will do the trick: *)

Fixpoint kvs_insert {V : Type} (k : key) (v : V) (kvs : list (key * V)) :=
  match kvs with
  | [] => [(k, v)]
  | (k', v') :: kvs' =>
    if k <? k' then (k, v) :: kvs
    else if k >? k' then (k', v') :: kvs_insert k v kvs'
         else (k, v) :: kvs'
  end.

(** That's not satisfactory, because the definition of
    [kvs_insert] is so complex. Moreover, this equation doesn't tell
    us anything directly about the overall properties of [elements t]
    for a given tree [t].  Nonetheless, we can proceed with a rather
    ugly verification. *)

(** **** Exercise: 3 stars, standard, optional (kvs_insert_split)  *)
Lemma kvs_insert_split :
  forall (V : Type) (v v0 : V) (e1 e2 : list (key * V)) (k k0 : key),
    Forall (fun '(k',_) => k' < k0) e1 ->
    Forall (fun '(k',_) => k' > k0) e2 ->
    kvs_insert k v (e1 ++ (k0,v0):: e2) =
    if k <? k0 then
      (kvs_insert k v e1) ++ (k0,v0)::e2
    else if k >? k0 then
           e1 ++ (k0,v0)::(kvs_insert k v e2)
         else
           e1 ++ (k,v)::e2.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard, optional (kvs_insert_elements)  *)
Lemma kvs_insert_elements : forall (V : Type) (t : tree V),
    BST t ->
    forall (k : key) (v : V),
      elements (insert k v t) = kvs_insert k v (elements t).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Model-based Specifications *)

(** At the outset, we mentioned studying two techniques for
    specifying the correctness of BST operations in this chapter.  The
    first was algebraic specification.

    Another approach to proving correctness of search trees is to
    relate them to our existing implementation of functional partial
    maps, as developed in [Maps]. To prove the correctness of a
    search-tree algorithm, we can prove:

    - Any search tree corresponds to some functional partial map,
      using a function or relation that we write down.

    - The [lookup] operation on trees gives the same result as the
      [find] operation on the corresponding map.

    - Given a tree and corresponding map, if we [insert] on the tree
      and [update] the map with the same key and value, the resulting
      tree and map are in correspondence.

    This approach is sometimes called _model-based specification_: we
    show that our implementation of a data type corresponds to a more
    more abstract _model_ type that we already understand. To reason
    about programs that use the implementation, it suffices to reason
    about the behavior of the abstract type, which may be
    significantly easier.  For example, we can take advantage of laws
    that we proved for the abstract type, like [update_eq] for
    functional maps, without having to prove them again for the
    concrete tree type.

    We also need to be careful here, because the type of functional
    maps as defined in [Maps] do not actually behave quite like
    our tree-based maps. For one thing, functional maps can be defined
    on an infinite number of keys, and there is no mechanism for
    enumerating over the key set. To maintain correspondence with our
    finite trees, we need to make sure that we consider only
    functional maps built by finitely many applications of constructor
    functions ([empty] and [update]). Also, thanks to functional
    extensionality, functional maps obey stronger equality laws than
    our trees do (as we investigated in the [direct_equalities]
    exercise above), so we should not be misled into thinking that
    every fact we can prove about abstract maps necessarily holds for
    concrete ones.

    Compared to the algebraic-specification approach described earlier
    in this chapter, the model-based approach can save some proof
    effort, especially if we already have a well-developed theory for
    the abstract model type.  On the other hand, we have to give an
    explicit _abstraction_ relation between trees and maps, and show
    that it is maintained by all operations. In the end, about the
    same amount of work is needed to show correctness, though the work
    shows up in different places depending on how the abstraction
    relation is defined. *)

(** We now give a model-based specification for trees in terms
    of functional partial maps. It is based on a simple abstraction
    relation that builds a functional map element by element. *)

Fixpoint map_of_list {V : Type} (el : list (key * V)) : partial_map V :=
  match el with
  | [] => empty
  | (k, v) :: el' => update (map_of_list el') k v
  end.

Definition Abs {V : Type} (t : tree V) : partial_map V :=
  map_of_list (elements t).

(** In general, model-based specifications may use an abstraction
    relation, allowing each concrete value to be related to multiple
    abstract values.  But in this case a simple abstraction _function_
    will do, assigning a unique abstract value to each concrete
    one. *)

(** One small difference between trees and functional maps is that
    applying the latter returns an [option V] which might be [None],
    whereas [lookup] returns a default value if key is not bound
    lookup fails.  We can easily provide a function on functional
    partial maps having the latter behavior. *)

Definition find {V : Type} (d : V) (k : key) (m : partial_map V) : V :=
  match m k with
  | Some v => v
  | None => d
  end.

(** We also need a [bound] operation on maps. *)

Definition map_bound {V : Type} (k : key) (m : partial_map V) : bool :=
  match m k with
  | Some _ => true
  | None => false
  end.

(** We now proceed to prove that each operation preserves (or establishes)
    the abstraction relationship in an appropriate way:

    concrete        abstract
    --------        --------
    empty_tree      empty
    bound           map_bound
    lookup          find
    insert          update
*)

(** The following lemmas will be useful, though you are not required
    to prove them. They can all be proved by induction on the list. *)

(** **** Exercise: 2 stars, standard, optional (in_fst)  *)
Lemma in_fst : forall (X Y : Type) (lst : list (X * Y)) (x : X) (y : Y),
    In (x, y) lst -> In x (map fst lst).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (in_map_of_list)  *)
Lemma in_map_of_list : forall (V : Type) (el : list (key * V)) (k : key) (v : V),
    NoDup (map fst el) ->
    In (k,v) el -> (map_of_list el) k = Some v.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (not_in_map_of_list)  *)
Lemma not_in_map_of_list : forall (V : Type) (el : list (key * V)) (k : key),
    ~ In k (map fst el) -> (map_of_list el) k = None.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

Lemma empty_relate : forall (V : Type),
    @Abs V empty_tree = empty.
Proof.
  reflexivity.
Qed.

(** **** Exercise: 3 stars, standard, optional (bound_relate)  *)

Theorem bound_relate : forall (V : Type) (t : tree V) (k : key),
    BST t ->
    map_bound k (Abs t) = bound k t.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 3 stars, standard, optional (lookup_relate)  *)

Lemma lookup_relate : forall (V : Type) (t : tree V) (d : V) (k : key),
    BST t -> find d k (Abs t) = lookup d k t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard, optional (insert_relate)  *)
Lemma insert_relate : forall (V : Type) (t : tree V) (k : key) (v : V),
  BST t -> Abs (insert k v t) = update (Abs t) k v.
Proof.
  (* TODO: find a direct proof that doesn't rely on [kvs_insert_elements] *)
    unfold Abs.
  intros.
  rewrite kvs_insert_elements; auto.
  remember (elements t) as l.
  clear -l. (* clear everything not about [l] *)
  (* Hint: proceed by induction on [l]. *)
    (* FILL IN HERE *) Admitted.
(** [] *)

(** The previous three lemmas are in essence saying that the following
    diagrams commute.

             bound k
      t -------------------+
      |                    |
  Abs |                    |
      V                    V
      m -----------------> b
           map_bound k

            lookup d k
      t -----------------> v
      |                    |
  Abs |                    | Some
      V                    V
      m -----------------> Some v
             find d k

            insert k v
      t -----------------> t'
      |                    |
  Abs |                    | Abs
      V                    V
      m -----------------> m'
            update' k v

    Where we define:

      update' k v m = update m k v

*)

(** Functional partial maps lack a way to extract or iterate
    over their elements, so we cannot give an analogous abstract
    operation for [elements]. Instead, we can prove this trivial
    little lemma. *)

Lemma elements_relate : forall (V : Type) (t : tree V),
  BST t ->
  map_of_list (elements t) = Abs t.
Proof.
  unfold Abs. intros. reflexivity.
Qed.

(* ################################################################# *)
(** * An Alternative Abstraction Relation (Optional, Advanced) *)

(** There is often more than one way to specify a suitable abstraction
    relation between given concrete and abstract datatypes. The
    following exercises explore another way to relate search trees to
    functional partial maps without using [elements] as an
    intermediate step.

    We extend our definition of functional partial maps by adding a
    new primitive for combining two partial maps, which we call
    [union].  Our intention is that it only be used to combine maps
    with disjoint key sets; to keep the operation symmetric, we make
    the result be undefined on any key they have in common.  *)

Definition union {X} (m1 m2: partial_map X) : partial_map X :=
  fun k =>
    match (m1 k, m2 k) with
    | (None, None) => None
    | (None, Some v) => Some v
    | (Some v, None) => Some v
    | (Some _, Some _) => None
    end.

(** We can prove some simple properties of lookup and update on unions,
    which will prove useful later. *)

(** **** Exercise: 2 stars, standard, optional (union_collapse)  *)
Lemma union_left : forall {X} (m1 m2: partial_map X) k,
    m2 k = None -> union m1 m2 k = m1 k.
Proof.
(* FILL IN HERE *) Admitted.

Lemma union_right : forall {X} (m1 m2: partial_map X) k,
    m1 k = None ->
    union m1 m2 k = m2 k.
Proof.
(* FILL IN HERE *) Admitted.

Lemma union_both : forall {X} (m1 m2 : partial_map X) k v1 v2,
    m1 k = Some v1 ->
    m2 k = Some v2 ->
    union m1 m2 k = None.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard, optional (union_update)  *)
Lemma union_update_right : forall {X} (m1 m2: partial_map X) k v,
    m1 k = None ->
    update (union m1 m2) k v = union m1 (update m2 k v).
Proof.
(* FILL IN HERE *) Admitted.

Lemma union_update_left : forall {X} (m1 m2: partial_map X) k v,
    m2 k = None ->
    update (union m1 m2) k v = union (update m1 k v) m2.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** We can now write a direct conversion function from trees to maps
    based on the structure of the tree, and prove a basic property
    preservation result. *)

Fixpoint map_of_tree {V : Type} (t: tree V) : partial_map V :=
  match t with
  | E => empty
  | T l k v r => update (union (map_of_tree l) (map_of_tree r)) k v
  end.

(** **** Exercise: 3 stars, advanced, optional (map_of_tree_prop)  *)
Lemma map_of_tree_prop : forall (V : Type) (P : key -> V -> Prop) (t : tree V),
    ForallT P t ->
    forall k v, (map_of_tree t) k = Some v ->
           P k v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Finally, we define our new abstraction function, and prove the
    same lemmas as before. *)

Definition Abs' {V : Type} (t: tree V) : partial_map V :=
  map_of_tree t.

Lemma empty_relate' : forall (V : Type),
    @Abs' V empty_tree = empty.
Proof.
  reflexivity.
Qed.

(** **** Exercise: 3 stars, advanced, optional (bound_relate')  *)
Theorem bound_relate' : forall (V : Type) (t : tree V) (k : key),
    BST t ->
    map_bound k (Abs' t) = bound k t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced, optional (lookup_relate')  *)
Lemma lookup_relate' : forall (V : Type) (d : V) (t : tree V) (k : key),
    BST t -> find d k (Abs' t) = lookup d k t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, advanced, optional (insert_relate')  *)
Lemma insert_relate' : forall (V : Type) (k : key) (v : V) (t : tree V),
   BST t -> Abs' (insert k v t) = update (Abs' t) k v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** The [elements_relate] lemma, which was trivial for our previous [Abs]
    function, is considerably harder this time.  We suggest starting with
    an auxiliary lemma. *)

(** **** Exercise: 3 stars, advanced, optional (map_of_list_app)  *)
Lemma map_of_list_app : forall (V : Type) (el1 el2: list (key * V)),
   disjoint (map fst el1) (map fst el2) ->
   map_of_list (el1 ++ el2) = union (map_of_list el1) (map_of_list el2).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, advanced, optional (elements_relate')  *)
Lemma elements_relate' : forall (V : Type) (t : tree V),
  BST t ->
  map_of_list (elements t) = Abs' t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Efficiency of Search Trees *)

(** All the theory we've developed so far has been about correctness.
    But the reason we use binary search trees is that they are
    efficient.  That is, if there are [N] elements in a (reasonably
    well balanced) BST, each insertion or lookup takes about [log N]
    time.

    What could go wrong?

     1. The search tree might not be balanced.  In that case, each
        insertion or lookup will take as much as linear time.

        - SOLUTION: use an algorithm that ensures the trees stay
          balanced.  We'll do that in [Redblack].

     2. Our keys are natural numbers, and Coq's [nat] type takes linear
        time per comparison.  That is, computing (j <? k) takes time
        proportional to the value of [k-j].

        - SOLUTION: represent keys by a data type that has a more
          efficient comparison operator.  We used [nat] in this chapter
          because it's something easy to work with.

     3. There's no notion of running time in Coq.  That is, we can't
        say what it means that a Coq function "takes N steps to
        evaluate."  Therefore, we can't prove that binary search trees
        are efficient.

        - SOLUTION 1: Don't prove (in Coq) that they're efficient;
          just prove that they are correct.  Prove things about their
          efficiency the old-fashioned way, on pencil and paper.

        - SOLUTION 2: Prove in Coq some facts about the height of the
          trees, which have direct bearing on their efficiency.  We'll
          explore that in [Redblack].

        - SOLUTION 3: Apply bleeding-edge frameworks for reasoning
          about run-time of programs represented in Coq.

      4. Our functions in Coq are models of implementations in "real"
         programming languages.  What if the real implementations
         differ from the Coq models?

         - SOLUTION: Use Coq's [extraction] feature to derive the real
	   implementation (in Ocaml or Haskell) automatically from the
	   Coq function.  Or, use Coq's [Compute] or [Eval
	   native_compute] feature to compile and run the programs
	   efficiently inside Coq.  We'll explore [extraction] in a
	   [Extract]. *)

(* 2020-08-07 17:08 *)


Require Import Arith.
Require Import List.
Export ListNotations.

(* LANGAGES FORMELS *)

(* EXERCICE *)
(* Écrire la fonction "lgr" qui calcule la longueur d'une liste de nat (et donc de type list nat) *)
Fixpoint lgr (l : list nat) := match l with [] => 0 | _::rl => 1 + (lgr rl) end.

Example ex_lgr : (lgr (1::2::3::4::5::[])) = 5.
Proof. simpl. reflexivity. Qed.

(* EXERCICE *)
(* Écrire la fonction "mir" qui calcule le miroir d'une liste de nat *)
Fixpoint mir (l : list nat) := match l with [] => [] | e::rl => (mir rl) ++ e::[] end.

Example ex_mir : (mir (1::2::3::4::5::[])) = 5::4::3::2::1::[].
Proof. simpl. reflexivity. Qed.

(* EXERCICE *)
(* Exprimer et prouver que le miroir d'une liste à laquelle on a ajouté un élément en tête
   est le miroir de la liste concaténé à la liste constituée de juste cet élément *)
Goal forall l : list nat, forall a : nat, rev (a :: l) = (rev l) ++ a::[].
Proof.
  intro l0.
  intro a0.
  destruct l0. (* pas besoin d'hyp. d'induction *)
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

(* EXERCICE SUJET A *)
Inductive btree : Type :=
| F : nat -> btree
| N : btree -> btree -> btree
.

(* Écrire la fonction "bnbf" qui calcule le nombre de feuilles d'un tel arbre *)
Fixpoint bnbf t :=
  match t with
  | F e => 1
  | N t1 t2 => (bnbf t1) + (bnbf t2)
  end.

(* Écrire la fonction "bnbn" qui calcule le nombre de noeuds d'un tel arbre *)
Fixpoint bnbn t :=
  match t with
  | F e => 0
  | N t1 t2 => 1 + (bnbn t1) + (bnbn t2)
  end.

(* Écrire la fonction "bsumval" qui calcule la somme des valeurs contenues dans l'arbre *)
Fixpoint bsumval t :=
  match t with
  | F e => e
  | N t1 t2 => (bsumval t1) + (bsumval t2)
  end.

(* Écrire la fonction "bajout" qui ajoute un élément dans un arbre *)
Fixpoint bajout e t : btree :=
  match t with
  | F n => N t (F e)
  | N t1 t2 => N (bajout e t1) t2
  end.

(* exemples *)
(* Définir l'arbre "ab1" :  o
                           / \
                          o   2
                         / \
                        1   o
                           / \
                          o   3
                         / \
                        4   5
*)

Definition ab1 := N (N (F 1) (N (N (F 4) (F 5)) (F 3))) (F 2).

Example ex_bnbf_ab1 : (bnbf ab1) = 5.
Proof. cbv. reflexivity. Qed.

Example ex_bnbn_ab1 : (bnbn ab1) = 4.
Proof. cbv. reflexivity. Qed.

Example ex_bsumval_ab1 : (bsumval ab1) = 15.
Proof. cbv. reflexivity. Qed.

Example ex_bajout_ab1 : bnbf (bajout 10 ab1) = 1 + bnbf ab1.
Proof. cbv. reflexivity. Qed.

(* EXERCICE SUJET B *)
Inductive ctree : Type :=
| V : nat -> ctree
| R : ctree -> ctree -> ctree
| T : ctree -> ctree -> ctree -> ctree
.

(* Ecrire la fonction "cnbf" qui calcule le nombre de feuilles d'un tel arbre *)
Fixpoint cnbf t :=
  match t with
  | V e => 1
  | R t1 t2 => (cnbf t1) + (cnbf t2)
  | T t1 t2 t3 => (cnbf t1) + (cnbf t2) + (cnbf t3)
  end.

(* Ecrire la fonction "cnbn" qui calcule le nombre de noeuds d'un tel arbre *)
Fixpoint cnbn t :=
  match t with
  | V e => 0
  | R t1 t2 => 1 + (cnbn t1) + (cnbn t2)
  | T t1 t2 t3 => 1 + (cnbn t1) + (cnbn t2) + (cnbn t3)
  end.

(* Ecrire la fonction "csumval" qui calcule la somme des valeurs contenues dans l'arbre *)
Fixpoint csumval t :=
  match t with
  | V e => e
  | R t1 t2 => (csumval t1) + (csumval t2)
  | T t1 t2 t3 => (csumval t1) + (csumval t2) + (csumval t3)
  end.

(* Ecrire la fonction "bajout" qui ajoute un élément dans un arbre *)
Fixpoint cajout e t : ctree :=
  match t with
  | V n => R t (V e)
  | R t1 t2 => R (cajout e t1) t2
  | T t1 t2 t3 => T (cajout e t1) t2 t3
  end.

(* exemples *)
(* Définir l'arbre "ac1" : o
                           / \
                          o   7
                         /|\
                        1 2 o
                           /|\
                          o 6 3
                         / \
                        4   5
*)
Definition ac1 := R (T (V 1) (V 2) (T (R (V 4) (V 5)) (V 6) (V 3))) (V 2).

Example ex_cnbf_ab1 : (bnbf ab1) = 5.
Proof. cbv. reflexivity. Qed.

Example ex_cnbn_ab1 : (bnbn ab1) = 4.
Proof. cbv. reflexivity. Qed.

Example ex_csumval_ab1 : (bsumval ab1) = 15.
Proof. cbv. reflexivity. Qed.

Example ex_cajout_ab1 : bnbf (bajout 10 ab1) = 1 + bnbf ab1.
Proof. cbv. reflexivity. Qed.

(* LOGIQUE CLASSIQUE *)

Context (A B C D : Prop).

(* EXERCICE *)
(* Prouver les lemmes suivants (permutation et renommage dans les deux sujets) *)
Lemma LC1 : ((A \/ B) -> C) -> ((A -> C) /\ (B -> C)).
Proof.
  intro Himp.
  split.
  - intro Ha. apply Himp. left. assumption.
  - intro Hb. apply Himp. right. assumption.
Qed.

Lemma LC2 : (A \/ B) -> ((A -> B) -> B).
Proof.
  intro Hou.
  intro Hab.
  destruct Hou. (* on l'a fait 10 fois... *)
  - apply Hab. assumption.
  - assumption.
Qed.

(* EXERCICE *)
(* Exprimer et montrer que la longueur de la concaténation de deux listes de nat est la somme des longueurs des concaténés*)
Lemma concat_compat : forall l1 l2 : list nat, lgr (l1 ++ l2) = (lgr l1) + (lgr l2).
Proof.
  intro l1.
  intro l2.
  induction l1  as [| a l1' IHl1']. (* ou avec noms automatiques *)
  - simpl. reflexivity.
  - simpl. rewrite IHl1'. reflexivity.
Qed.

(* EXERCICE *)
(* Montrer que la longueur d'une liste c'est la longueur de son miroir *)
(* On pourra avoir besoin de la commutativité de l'addition, donnée par le lemme Nat.add_comm, et dulemme précédent *)

Check Nat.add_comm.

Lemma lgrmir_compat : forall l : list nat,  lgr l = lgr (mir l).
Proof.
  induction l as [| a l' IHl']. (* ou avec noms automatiques  *)
  - simpl. reflexivity.
  - simpl.
    rewrite IHl'.
    rewrite (concat_compat (mir l') (a::[])). (* ou bien avec l'étape intermédiaire "pose" etc. *)
    simpl.
    rewrite (Nat.add_comm (lgr (mir l')) 1). (* oups ça n'est pas dans le bon sens *)
    simpl.
    reflexivity.
Qed.

(* EXERCICE *)
(* Exprimer et montrer que l'addition est associative, c'est-à-dire qu'on a (x + y) + z = x + (y + z) pour x, y et z de type nat. *)
(* rappel : ce qui est noté x + y + z (sans parenthèses) est en fait (x + y) + z *)
Lemma p_assoc : forall x y z : nat, x + y + z = x + (y + z).
  intro x0.
  intro y0.
  intro z0.
  induction x0 as [| x0' IHx0']. (* ou avec noms automatiques *)
  - simpl. reflexivity.
  - simpl. rewrite IHx0'. reflexivity.
Qed.

(* EXERCICE SUJET A *)
(* Exprimer et montrer que la somme des valeurs d'un arbre t à laquelle on additionne un nat e est égale à la somme des valeurs de l'arbre t dans lequel on a ajouté un élément de valeur e. *)

(* On pourra avoir besoin de la commutativité de l'addition, donnée par le lemme Nat.add_comm, et de l'associativité démontrée auparavant. *)

Check Nat.add_comm.

Lemma bsumaj_compat : forall t, forall e, bsumval t + e = bsumval (bajout e t).
  intro t0.
  intro e0.
  induction t0 as [n | t1 IHt1 t2 IHt2] . (* ou avec noms automatiques *)
  - simpl. reflexivity.
  - simpl. rewrite <- IHt1. (* on a à droite (a + b) + c et on veut (a + c) + b il faut donc 1) déplacer les parenthèses, permuter, replacer les parenthèses *)
    rewrite (p_assoc (bsumval t1) e0 (bsumval t2)).
    rewrite (Nat.add_comm e0 (bsumval t2)).
    rewrite (p_assoc (bsumval t1) (bsumval t2) e0).
    reflexivity.
Qed.

(* EXERCICE SUJET B *)
(* Exprimer et montrer que la somme des valeurs d'un arbre t à laquelle on additionne un nat e est égale à la somme des valeurs de l'arbre t dans lequel on a ajouté un élément de valeur e. *)

(* On pourra avoir besoin de la commutativité de l'addition, donnée par le lemme Nat.add_comm, et de l'associativité démontrée auparavant. *)

Check Nat.add_comm.

(* La même avec une étape en plus puisqu'on a 3 constructeurs pour les arbres *)
Lemma csumaj_compat : forall t, forall e, csumval t + e = csumval (cajout e t).
  intro t0.
  intro e0.
  induction t0 as [n | t1 IHt1 t2 IHt2 | t1 IHt1 t2 IHt2 t3 IHt3]. (* ou avec noms automatiques *)
  - simpl. reflexivity.
  - simpl. rewrite <- IHt1.
    rewrite (p_assoc (csumval t1) e0 (csumval t2)).
    rewrite (Nat.add_comm e0 (csumval t2)).
    rewrite (p_assoc (csumval t1) (csumval t2) e0).
    reflexivity.
  - simpl. rewrite <- IHt1. (* on a ((a + b) + c) + d et on veut ((a + c )+ d) + b, on déplace les parenthèses et on commute en conséquence *)
    rewrite (p_assoc (csumval t1 + e0) (csumval t2) (csumval t3)). (* (a + b) + (c + d) *)
    rewrite (p_assoc (csumval t1) e0 (csumval t2 + csumval t3)).   (* a + (b + (c + d)) *)
    rewrite (Nat.add_comm e0 (csumval t2 + csumval t3)).           (* on permute *)
    rewrite (p_assoc (csumval t1) (csumval t2) (csumval t3)).      (* on remonte les parenthèses à gauche... *)
    rewrite (p_assoc (csumval t1) (csumval t2 + csumval t3) e0).
    reflexivity.
Qed.