From Coq Require Import Relations.
From mathcomp Require Import ssreflect ssrbool ssrnat ssrfun.
From mathcomp Require Import eqtype choice order seq tuple path zify.
From mathcomp Require Import fintype finfun fingraph finmap.
From mathcomp Require Import generic_quotient.
From mathcomp.tarjan Require Import extra acyclic kosaraju acyclic_tsorted.

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

Import Order.Theory.

(* ************************************************************************** *)
(*     Some automation with hints and tactics                                 *)
(* ************************************************************************** *)

(****** Hints to deal with dummy boolean goals ******)

Lemma orbTb a b : [|| a, true | b].
Proof. by case: a. Qed.

Lemma orbbT a b : [|| a, b | true].
Proof. by rewrite !orbT. Qed.

Lemma orbbbT a b c: [|| a, b, c | true].
Proof. by rewrite !orbT. Qed.

Lemma orbbbbT a b c d: [|| a, b, c, d | true].
Proof. by rewrite !orbT. Qed.

#[export] Hint Resolve orbT orbTb orbbT orbbbT orbbbbT : core.

Lemma and3PP P Q R p q r : reflect P p -> reflect Q q -> reflect R r ->
  reflect [/\ P, Q & R] [&& p, q & r].
Proof. by move=> rP rQ rR; apply: (iffP and3P)=> -[/rP ? /rQ ? /rR ?]. Qed.

Lemma andb_iff (a b c d : bool) :
  (a <-> c) -> (b <-> d) -> (a && b <-> c && d).
Proof. by move=> ??; split=> /andP[??]; apply/andP; split; firstorder. Qed.

Lemma iff_eqP (a b : bool) :
  reflect (a <-> b) (a == b).
Proof.
  apply/(equivP idP); split=> [/eqP->|] //.
  case a; case b=> //; intuition.
Qed.

Lemma forall_iff_eqP {T U : Type} P (p : pred T) x y :
  (forall x, reflect (P x) (p x)) -> (P x <-> P y) -> (p x = p y).
Proof.
  move=> /[dup] /(_ x) /rwP[??] /(_ y) /rwP[??] [??].
  apply: eqP; apply/iff_eqP; intuition.
Qed.

Lemma nmem_subset {T : Type} (p q : pred T) x :
  {subset p <= q} -> x \notin q -> x \notin p.
Proof. by move=> subs; apply/contra=> ?; rewrite subs. Qed.

(* ************************************************************************** *)
(*     Anti-homomorphism (i.e. homomorphism with reversed direction)          *)
(* ************************************************************************** *)

(* TODO: recheck the name (antihomomorphism) in the literature *)

Section AntiHomomorphism.
Context (aT rT : Type) (f : aT -> rT).

Definition antihomomorphism_1 (aP rP : _ -> Prop) := forall x, rP (f x) -> aP x.
Definition antihomomorphism_2 (aR rR : _ -> _ -> Prop) :=
  forall x y, rR (f x) (f y) -> aR x y.

End AntiHomomorphism.

Notation "{ 'ahomo' f : x / a >-> r }" :=
  (antihomomorphism_1 f (fun x => a) (fun x => r))
  (at level 0, f at level 99, x name,
   format "{ 'ahomo'  f  :  x  /  a  >->  r }") : type_scope.

Notation "{ 'ahomo' f : x / a }" :=
  (antihomomorphism_1 f (fun x => a) (fun x => a))
  (at level 0, f at level 99, x name,
   format "{ 'ahomo'  f  :  x  /  a }") : type_scope.

Notation "{ 'ahomo' f : x y / a >-> r }" :=
  (antihomomorphism_2 f (fun x y => a) (fun x y => r))
  (at level 0, f at level 99, x name, y name,
   format "{ 'ahomo'  f  :  x  y  /  a  >->  r }") : type_scope.

Notation "{ 'ahomo' f : x y / a }" :=
  (antihomomorphism_2 f (fun x y => a) (fun x y => a))
  (at level 0, f at level 99, x name, y name,
   format "{ 'ahomo'  f  :  x  y  /  a }") : type_scope.

Notation "{ 'ahomo' f : x y /~ a }" :=
  (antihomomorphism_2 f (fun y x => a) (fun x y => a))
  (at level 0, f at level 99, x name, y name,
   format "{ 'ahomo'  f  :  x  y  /~  a }") : type_scope.

Section AntiHomomorphismTheory.
Context (aT rT : Type) (f : aT -> rT).
Context (aR : rel aT) (rR : rel rT).

Lemma mono2aW :
  {mono f : x y / aR x y >-> rR x y} -> {ahomo f : x y / aR x y >-> rR x y}.
Proof. by move=> hf x y axy; rewrite -hf. Qed.

End AntiHomomorphismTheory.

(* ************************************************************************** *)
(*     Decidable morphisms on finite types                                    *)
(* ************************************************************************** *)

Section FinTypeMorphism.
Context (aT : finType) (rT : eqType) (f : aT -> rT).
Implicit Types (aF : aT -> aT) (rF : rT -> rT).
Implicit Types (aOp : aT -> aT -> aT) (rOp : rT -> rT -> rT).

Lemma morph1P aF rF :
  reflect (morphism_1 f aF rF)
          ([forall x, f (aF x) == rF (f x)]).
Proof. repeat apply/forallPP=> ?; exact/eqP. Qed.

Lemma morph2P aOp rOp :
  reflect (morphism_2 f aOp rOp)
          ([forall x, forall y, f (aOp x y) == rOp (f x) (f y)]).
Proof. repeat apply/forallPP=> ?; exact/eqP. Qed.

End FinTypeMorphism.

Section FinTypeHomomorphism.
Context (aT : finType) (rT : Type) (f : aT -> rT).
Implicit Types (aP : pred aT) (rP : pred rT).
Implicit Types (aR : rel aT) (rR : rel rT).

Lemma homo1P aP rP :
  reflect (homomorphism_1 f aP rP)
          ([forall x, aP x ==> rP (f x)]).
Proof. repeat apply/forallPP=> ?; exact/implyP. Qed.

Lemma homo2P aR rR :
  reflect (homomorphism_2 f aR rR)
          ([forall x, forall y, aR x y ==> rR (f x) (f y)]).
Proof. repeat apply/forallPP=> ?; exact/implyP. Qed.

End FinTypeHomomorphism.

Section FinTypeMonomorphism.
Context (aT : finType) (rT : Type) (sT : eqType) (f : aT -> rT).
Implicit Types (aP : aT -> sT) (rP : rT -> sT).
Implicit Types (aR : aT -> aT -> sT) (rR : rT -> rT -> sT).

Lemma mono1P aP rP :
  reflect (monomorphism_1 f aP rP)
          ([forall x, rP (f x) == aP x]).
Proof. repeat apply/forallPP=> ?; exact/eqP. Qed.

Lemma mono2P aR rR :
  reflect (monomorphism_2 f aR rR)
          ([forall x, forall y, rR (f x) (f y) == aR x y]).
Proof. repeat apply/forallPP=> ?; exact/eqP. Qed.

End FinTypeMonomorphism.

(* ************************************************************************** *)
(*     Morphisms of extensionally equal functions                             *)
(* ************************************************************************** *)

Section MorphismEq.
Context (aT rT : Type) (f : aT -> rT) (g : aT -> rT).
Implicit Types (aF : aT -> aT) (rF : rT -> rT).
Implicit Types (aOp : aT -> aT -> aT) (rOp : rT -> rT -> rT).

Hypothesis (eqf : f =1 g).

Lemma eq_morph1 aF rF :
  (morphism_1 f aF rF) <-> (morphism_1 g aF rF).
Proof. split=> mor x; [rewrite -?eqf | rewrite ?eqf]; exact/mor. Qed.

Lemma eq_morph2 aOp rOp :
  (morphism_2 f aOp rOp) <-> (morphism_2 g aOp rOp).
Proof. split=> mor x y; [rewrite -?eqf | rewrite ?eqf]; exact/mor. Qed.

End MorphismEq.

Section HomomorphismEq.
Context (aT rT : Type) (f : aT -> rT) (g : aT -> rT).
Implicit Types (aP : aT -> Prop) (rP : rT -> Prop).
Implicit Types (aR : rel aT) (rR : rel rT).

Hypothesis (eqf : f =1 g).

Lemma eq_homo1 aP rP :
  (homomorphism_1 f aP rP) <-> (homomorphism_1 g aP rP).
Proof. split=> hom x; [rewrite -?eqf | rewrite ?eqf]; exact/hom. Qed.

Lemma eq_homo2 aR rR :
  (homomorphism_2 f aR rR) <-> (homomorphism_2 g aR rR).
Proof. split=> hom x y; [rewrite -?eqf | rewrite ?eqf]; try exact/hom. Qed.

End HomomorphismEq.

Section MonomorphismEq.
Context (aT rT : Type) (sT : Type) (f : aT -> rT) (g : aT -> rT).
Implicit Types (aP : aT -> sT) (rP : rT -> sT).
Implicit Types (aR : aT -> aT -> sT) (rR : rT -> rT -> sT).

Hypothesis (eqf : f =1 g).

Lemma eq_mono1 aP rP :
  (monomorphism_1 f aP rP) <-> (monomorphism_1 g aP rP).
Proof. split=> mon x; [rewrite -?eqf | rewrite ?eqf]; exact/mon. Qed.

Lemma eq_mono2 aR rR :
  (monomorphism_2 f aR rR) <-> (monomorphism_2 g aR rR).
Proof. split=> mon x y; [rewrite -?eqf | rewrite ?eqf]; exact/mon. Qed.

End MonomorphismEq.

(* ************************************************************************** *)
(*     Restriction of the function to subType                                 *)
(* ************************************************************************** *)

Section RstDef.
Context {T U : Type} {P : pred T} {S : subType P}.
Implicit Types  (f : T -> U).

Definition rst f : S -> U := f \o val.

End RstDef.

Notation "[ 'rst' f 'to' S ]" := (rst f : S -> _)
  (at level 0, f at level 99,
   format "[ 'rst'  f  'to'  S ]") : form_scope.

Notation "[ 'rst' f | P ]" := (rst f : (sig P) -> _)
  (at level 0, f at level 99,
   format "[ 'rst'  f  |  P ]") : form_scope.

Section SubFunTheory.
Context {T U : Type} {P : pred T} {S : subType P}.
Implicit Types  (f : T -> U).

Lemma rst_existsE f (PU : U -> Prop) :
  (exists x, PU ([rst f to S] x)) <-> (exists2 x, P x & PU (f x)).
Proof.
  split=> [[x] pux | [x] px pux].
  - exists (val x)=> //; exact/valP.
  by exists (Sub x px); rewrite /rst /= SubK.
Qed.

End SubFunTheory.

(* Variables (T U : Type) (P : pred T) (f : T -> U). *)
(* Check ([rst f | P]). *)

(* ************************************************************************** *)
(*     Surjective function                                                    *)
(* ************************************************************************** *)

Section Surjective.
Context {rT aT : Type}.
Implicit Types (f : aT -> rT).

Definition surjective f :=
  forall (y : rT), exists x, f x = y.

Lemma bij_surj f :
  bijective f -> surjective f.
Proof. by case=> g Kf Kg y; exists (g y); rewrite Kg. Qed.

End Surjective.

Section SurjectivePreim.
Context {rT : eqType} {aT : choiceType}.
Context (f : aT -> rT).
Hypothesis (surjf : surjective f).

Lemma preim_ofP :
  forall (x : rT), exists y, f y == x.
Proof. by move=> x; case (surjf x)=> [y] <-; exists y. Qed.

Definition preim_of : rT -> aT :=
  fun y => xchoose (preim_ofP y).

(* TODO: rename? *)
Lemma preim_of_f :
  cancel preim_of f.
Proof.
  rewrite /preim_of=> y.
  exact/eqP/(xchooseP (preim_ofP y)).
Qed.

(* TODO: rename? *)
Lemma f_preim_of :
  injective f -> cancel f preim_of.
Proof.
  move=> injf x.
  apply/injf=> //; apply/eqP.
  exact/(xchooseP (preim_ofP (f x))).
Qed.

End SurjectivePreim.

Section SurjectiveTheory.
Context {rT : eqType} {aT : choiceType}.
Implicit Types (f : aT -> rT).

Lemma inj_surj_bij f :
  injective f -> surjective f -> bijective f.
Proof.
  move=> injf surjf.
  exists (preim_of surjf).
  - exact/f_preim_of.
  exact/preim_of_f.
Qed.

End SurjectiveTheory.

Section SurjectiveRst.
Context {rT aT : Type}.
Implicit Types (f : aT -> rT).
Implicit Types (rP : pred rT) (aP : pred aT).

Lemma surj_rstE rP aP f :
  {in rP, surjective [rst f | aP]} <-> (forall y, rP y -> exists2 x, aP x & f x = y).
Proof. by split=> surjf y py; apply/(rst_existsE f (eq^~ y))/surjf. Qed.

End SurjectiveRst.

(* ************************************************************************** *)
(*     Mapping using proof of membership                                      *)
(* ************************************************************************** *)

Section SeqIn.

Context {T : eqType}.
Implicit Type s : seq T.

Fixpoint seq_in_sub s s' (sub : subseq s' s) : seq {x in s} :=
  (if s' is h :: t then
     fun sub =>
       exist _ h (mem_subseq sub (mem_head h t)) ::
       seq_in_sub (subseq_trans (subseq_cons t h) sub)
   else fun => [::]
  ) sub.

Definition seq_in s : seq {x in s} := seq_in_sub (subseq_refl s).

Lemma val_seq_in_sub s s' (sub : subseq s' s) :
  map val (seq_in_sub sub) = s'.
Proof. by elim: s'=> //= ?? IHs in sub *; rewrite IHs. Qed.

Lemma val_seq_in s :
  map val (seq_in s) = s.
Proof. by rewrite /seq_in val_seq_in_sub. Qed.

Lemma seq_in_subE s s' (sub : subseq s' s) :
  seq_in_sub sub = pmap insub s'.
Proof. by rewrite -[in RHS](@val_seq_in_sub s s') map_pK //; apply: valK. Qed.

Lemma seq_inE s :
  seq_in s = pmap insub s.
Proof. by rewrite /seq_in seq_in_subE. Qed.

Lemma seq_in_mem s x (p : x \in s) :
  exist _ x p \in seq_in s.
Proof. by rewrite seq_inE mem_pmap_sub. Qed.

End SeqIn.

Lemma exists_equiv {T} {A B : T -> Prop} :
  (forall x, A x <-> B x) -> (exists x, A x) <-> (exists x, B x).
Proof. move=> H; split=> [][] x /H ?; by exists x. Qed.

Lemma exists2_equiv {T} {A B C D : T -> Prop} :
  (forall x, A x <-> C x) -> (forall x, B x <-> D x) ->
  (exists2 x, A x & B x) <-> (exists2 x, C x & D x).
Proof. move=> H1 H2; split=> [][] x /H1 ? /H2 ?; by exists x. Qed.

Inductive and6 (P1 P2 P3 P4 P5 P6 : Prop) : Prop :=
  And6 of P1 & P2 & P3 & P4 & P5 & P6.

Notation "[ /\ P1 , P2 , P3 , P4 , P5 & P6 ]" :=
  (and6 P1 P2 P3 P4 P5 P6) : type_scope.

Section ReflectConnectives.

Variable b1 b2 b3 b4 b5 b6 : bool.

Lemma and6P : reflect [/\ b1, b2, b3, b4, b5 & b6] [&& b1, b2, b3, b4, b5 & b6].
Proof.
  by case: b1; case: b2; case: b3; case: b4; case: b5; case: b6;
    constructor; try by case.
Qed.

End ReflectConnectives.

Section Swap.

Context {T : eqType}.

Section SwapDef.

Context (f : T -> T) (a b : T).

Definition swap := fun x =>
  if x == a then
    f b
  else if x == b then
    f a
  else f x.

Lemma swap1: swap a = f b.
Proof. by rewrite /swap eq_refl. Qed.

Lemma swap2: swap b = f a.
Proof. by rewrite /swap eq_refl; case: ifP=> // /eqP->. Qed.

Lemma swap_not_eq x: x != a -> x != b -> f x = swap x.
Proof. by rewrite /swap=> /negbTE->/negbTE->. Qed.

End SwapDef.

Lemma swapxx x f : swap f x x =1 f.
Proof. by move=> y; rewrite /swap eq_sym; case: (x =P y)=> [->|]. Qed.

Lemma swap_inv a b: involutive (swap id a b).
Proof.
  move=> ?; rewrite {2}/swap; case: ifP=> [/eqP->|]; first exact/swap2.
  move/negbT=> ?; case: ifP=> [/eqP->|/negbT ?]; first exact/swap1.
  exact/esym/swap_not_eq.
Qed.

Lemma bij_swap a b f : bijective f -> bijective (swap f a b).
Proof.
  move=> /[dup] bi [g c1 c2].
  apply/(@Bijective _ _ _ (swap g (f a) (f b)))=> x; rewrite /swap.
  - case: (x =P a)=> [->|]; rewrite ?eq_refl ?c1 ?bij_eq //.
    - by case: ifP=> // /eqP.
    case: (x =P b)=> [->|]; first by rewrite ?eq_refl.
    by rewrite ?bij_eq // => /eqP/negbTE->/eqP/negbTE->.
  case: (x =P f a)=>[->|]; rewrite ?c1 ?eq_refl; first by case: ifP=>[/eqP->|].
  case: (x =P f b)=>[->|]; rewrite ?eq_refl // -?[g x == _](bij_eq bi) c2.
  by move/eqP/negbTE->=>/eqP/negbTE->.
Qed.

End Swap.

Section NatUtils.
Implicit Types (n m : nat).

Lemma ltn_total n m :
  [|| n == m, n < m | m < n].
Proof.
  move: (leq_total n m).
  rewrite [n <= m]leq_eqVlt [m <= n]leq_eqVlt.
  by rewrite orbA orbAC orbC eq_sym !orbA orbb.
Qed.

End NatUtils.

Section OptionUtils.

Context {T rT : Type}.
Implicit Types (f : T -> option rT) (p : pred rT) (r : rel rT).

Definition opreim f p : simpl_pred T :=
  [pred x | match f x with Some x => p x | _ => false end].

Definition orelpre f r : simpl_rel T :=
  [rel x y | match f x, f y with Some x, Some y => r x y | _, _ => false end].

Definition mk_total f (tot : forall x, f x) : T -> rT :=
  fun x => oextract (tot x).

Lemma mk_totalE d f x tot :
  @mk_total f tot x = odflt d (f x).
Proof.
  rewrite /mk_total /odflt /oapp.
  move: (tot x)=> {tot}.
  case: (f x)=> [{}x|] //.
Qed.

Lemma mk_totalK g f tot :
  pcancel g f -> cancel g (@mk_total f tot).
Proof.
  move=> K x; rewrite /mk_total.
  move: (tot (g x))=> {tot}.
  case H: (f (g x))=> [{}y|] //= _.
  apply /esym; move: H; rewrite K.
  exact /Some_inj.
Qed.

Lemma mk_total_inj f tot :
  injective f -> injective (@mk_total f tot).
Proof.
  move=> I x y; rewrite /mk_total.
  move: (tot x) (tot y)=> {tot}.
  case H1: (f x)=> [{}x'|] //= _.
  case H2: (f y)=> [{}y'|] //= _.
  move=> H3; move: H3 H2 H1=> <- <-.
  exact /I.
Qed.

End OptionUtils.

Section TupleUtils.
Context {T : Type}.

Lemma eq_from_tuple {s1 s2 : seq T} (eq_sz : size s1 = size s2) :
  tcast eq_sz (in_tuple s1) = in_tuple s2 -> s1 = s2.
Proof.
  have: s2 = val (in_tuple s2) by done.
  move=> /[swap] + ->; move=> <-.
  by rewrite /val /= val_tcast.
Qed.

End TupleUtils.

Section CountableUtils.
Context {T : countType}.

Lemma pickle_inj : injective (@choice.pickle T).
Proof. apply /pcan_inj /choice.pickleK. Qed.

End CountableUtils.

Section FoldUtils.

Lemma foldl_maxn_leq n m s :
  n <= m -> foldl maxn n s <= foldl maxn m s.
Proof.
  move: n m; elim s=> [|k {}s IH n m] => //=.
  rewrite {2 4}/maxn; case: ifP; case: ifP=> //; last 1 first.
  - by move=> ?? /IH.
  - by move=> /negP /(contra_not_leq id) /IH.
  move=> + /negP /(contra_not_leq id).
  move=> + /leq_trans /[apply].
  lia.
Qed.

Lemma foldl_maxn_leq_init n s :
  n <= foldl maxn n s.
Proof.
  move: n; elim s=> [|m {}s IH n] => //=.
  rewrite {2}/maxn; case: ifP=> //.
  move=> H; apply /leq_trans; last by exact/IH.
  by apply ltnW.
Qed.

Lemma foldl_maxn_sorted s :
  sorted (<=%O) s -> foldl maxn 0 s = last 0 s.
Proof.
  elim/last_ind: s=> [|{}s m IH] => //=.
  rewrite foldl_rcons last_rcons {1}/maxn.
  case: ifP=> //=.
  move=> /negP /(contra_not_leq id) + S.
  rewrite IH; last first.
  - apply /(subseq_sorted le_trans (subseq_rcons s m) S).
  rewrite -leEnat le_eqVlt=> /orP[/eqP<-|] //=.
  move: S; rewrite -(@path_min_sorted _ _ 0); last first.
  - apply/allP=> x ?; exact/leq0n.
  rewrite rcons_path=> /andP[] ?.
  by move=> H; rewrite (le_gtF H).
Qed.

End FoldUtils.

Notation "@! f" := (fun A => f @` A)%fset
  (at level 10, f at level 8, no associativity, format "@!  f") : fset_scope.

(* Context {T U : choiceType} (f : T -> U) {A : {fset T}}. *)
(* Check (@!f : {fset T} -> {fset U})%fset. *)

Section FSetUtils.
Context {key : unit} {T U : choiceType}.
Implicit Types (p : pred T) (r : rel T) (f : T -> U).
Implicit Types (s : {fset T}) (x : T).

Local Open Scope fset_scope.

Definition fset_pick s : option T :=
  omap val [pick x : s].

Lemma fset_pick1 x :
  fset_pick [fset x] = Some x.
Proof.
  rewrite /fset_pick; case: pickP=> /= [y _|].
  - by move: (valP y); rewrite inE => /eqP->.
  by move=>/(_ (Sub x (fset11 x))) /=.
Qed.

Lemma in_fset1 (x : T) a :
  (a \in [fset[key] x in [:: x]]) = (a == x).
Proof. by rewrite !mem_imfset //= inE. Qed.

Lemma fset_singl (x : T) :
  [fset[key] x in [:: x]] = [fset x].
Proof. by apply/fsetP=> y; rewrite in_fset1 inE. Qed.

Lemma imfset1 f x :
  f @` ([fset x]) = [fset (f x)].
Proof.
  apply/fsetP=> y /=; rewrite !inE.
  apply/idP/idP=> [/imfsetP|].
  - by move=> [] z /=; rewrite inE=> /eqP-> ->.
  move=> /eqP->; apply/imfsetP; exists x=> //=; exact/fset11.
Qed.

Lemma imfsetU f s1 s2 :
  f @` (s1 `|` s2) = (f @` s1) `|` (f @` s2).
Proof.
  apply/fsetP=> x /=; rewrite !inE.
  apply/idP/idP=> [/imfsetP|].
  - move=> [] y /=; rewrite !inE=> + ->.
    by move=> /orP[?|?]; apply/orP; [left|right]; apply/imfsetP; exists y.
  by move=> /orP[|] /imfsetP[] /= y ? ->; apply/imfsetP; exists y=> //;
    rewrite inE; apply/orP; [left|right].
Qed.

Lemma imfset_preim_subs f s :
  {subset s <= preim f (mem (f @` s))}.
Proof. by move=> x xin; rewrite inE /=; apply/imfsetP; exists x. Qed.

Lemma imfset_preim_eq f s :
  injective f -> preim f (mem (f @` s)) =1 (mem s).
Proof.
  move=> finj x /=; apply/idP/idP; last exact/imfset_preim_subs.
  by move=> /imfsetP [y] /= /[swap] /finj ->.
Qed.

Lemma imfset_can_in f g s :
  {on f @` s, cancel f & g} -> {in s, cancel f g}.
Proof. by move=> K x xin; rewrite K ?(in_imfset _ f). Qed.

Lemma fset_existsP s p :
  reflect (exists x, x \in s /\ p x) [exists x : s, p (val x)].
Proof.
  apply /equivP; first (by apply /existsP); split.
  - by move=> [] /= [] /= x Hx Px; exists x.
  by move=> [] x [] Hx Px; exists (FSetSub Hx).
Qed.

(* TODO: use `rst s r` (restriction of relation) ? *)
Lemma fset_exists2P s r :
  reflect (exists x y, [/\ x \in s, y \in s & r x y])
          [exists x : s, exists y : s, r (val x) (val y)].
Proof.
  apply /equivP; last split.
  - apply /(@fset_existsP _ (fun x => [exists y, r x (val y)])).
  - by move=> [] x [] Hx /fset_existsP [] y [] Hy Rxy; exists x, y.
  move=> [] x [] y [] Hx Hy Rxy; exists x; split=> //.
  by apply /fset_existsP; exists y.
Qed.

Lemma fset_forallPP s pp p :
  (forall x, reflect (pp x) (p x)) ->
  reflect {in s, forall x, pp x} [forall x : s, p (val x)].
Proof.
  move=> refl; apply /equivP; first (by apply /forallP); split.
  - move=> H x inX; move: (H (Sub x inX)); exact/refl.
  move=> H x; exact/refl/H/(valP x).
Qed.

Lemma fset_forallP s p :
  reflect {in s, forall x, p x} [forall x : s, p (val x)].
Proof. apply/fset_forallPP=> x; exact/idP. Qed.

(* TODO: use `rst s r` (restriction of relation) ? *)
Lemma fset_forall2P s r :
  reflect {in s & s, forall x y, r x y}
          [forall x : s, forall y : s, r (val x) (val y)].
Proof.
  apply /equivP; last split.
  - by apply/(@fset_forallP _ (fun x => [forall y, r x (val y)])).
  - move=> H x y inX inY; move: (H x inX).
    by move=> /forallP=> Hy; move: (Hy (Sub y inY)).
  move=> H x Hx /=; apply/forallP=> y; exact/H.
Qed.

End FSetUtils.

Section FinTypeUtils.
Context {T U : finType}.
Implicit Types (r : rel T) (f : T -> U).

Lemma inj_inj_bij f (g : U -> T) :
  injective f -> injective g -> bijective f.
Proof. move=> + /leq_card; exact/inj_card_bij. Qed.

Definition bijectiveb f :=
  injectiveb f && (#|U| <= #|T|)%N.

Lemma bijectiveP f :
  reflect (bijective f) (bijectiveb f).
Proof.
  apply/(equivP idP); split; rewrite /bijectiveb.
  - move=> /andP[/injectiveP]; exact/inj_card_bij.
  by move=> /[dup] /bij_inj /injectiveP -> /= /bij_eq_card ->.
Qed.

(* TODO: use `forallPP` instead? *)
Lemma forall2P r :
  reflect (forall x y, r x y) [forall x, forall y, r x y].
Proof.
  apply/(equivP forallP); split.
  - by move=> H x y; move: (H x)=> /forallP.
  by move=> H x; apply/forallP.
Qed.

Lemma forall3P (p : T -> T -> T -> bool) :
  reflect (forall x y z, p x y z) [forall x, forall y, forall z, p x y z].
Proof.
  apply/(equivP forallP); split.
  - by move=> H x y z; move: (H x)=> /forall2P.
  by move=> H x; apply/forall2P.
Qed.

End FinTypeUtils.

(* TODO: better name? (h stands for heterogeneous) *)
Section InvFh.
Context {T U : finType}.
Variable (f : T -> U).
Hypothesis (fbij : bijective f).

Lemma injFh_onto y :
  y \in codom f.
Proof.
  apply/(inj_card_onto (bij_inj fbij)).
  by rewrite (bij_eq_card fbij).
Qed.

Definition invFh y := iinv (injFh_onto y).

Lemma invFh_f : cancel f invFh.
Proof. move=> x; apply: iinv_f; exact/bij_inj. Qed.

Lemma f_invFh : cancel invFh f.
Proof. by move=> y; apply: f_iinv. Qed.

Lemma injFh_bij : bijective invFh.
Proof. exists f; [exact/f_invFh | exact/invFh_f]. Qed.

End InvFh.

Section SubTypeUtils.

Context {T : eqType} {U : Type} {P : pred T} {S : subType P}.

Definition sub_down (g : U -> S) (f : U -> T) : U -> S :=
  fun x => insubd (g x) (f x).

Definition sub_lift (g : T -> U) (f : S -> U) : T -> U :=
  fun x => odflt (g x) (omap f (insub x)).

Definition sub_rel_down (r : rel T) : rel S :=
  [rel x y | r (val x) (val y)].

Definition sub_rel_lift (r : rel S) : rel T :=
  [rel x y | match (insub x), (insub y) with
    | Some x, Some y => r x y
    | _, _ => false
    end
  ].

Definition compatible (g : T -> U) (f : S -> U) : Prop :=
  forall x y, g x = f y -> P x.

Lemma sub_inj (x y : T) (px : P x) (py : P y) :
  Sub x px = Sub y py :> S -> x = y.
Proof. by move=> H; move: (SubK S px) (SubK S py)=> <- <-; rewrite H. Qed.

Lemma sub_val (x : S) px :
  Sub (val x) px = x.
Proof. by apply/val_inj; rewrite SubK. Qed.

Lemma sub_downT y g f x :
  P (f x) -> sub_down g f x = insubd y (f x).
Proof. by move=> ?; rewrite /sub_down /insubd insubT //. Qed.

Lemma val_sub_downT g f x :
  P (f x) -> val (sub_down g f x) = f x.
Proof. by rewrite /sub_down val_insubd; case: ifP. Qed.

Lemma sub_downF g f x :
  ~ P (f x) -> sub_down g f x = g x.
Proof. move=> ?; rewrite /sub_down /insubd insubF //; exact/negP. Qed.

Lemma val_sub_downF g f x :
  ~ P (f x) -> val (sub_down g f x) = val (g x).
Proof. by rewrite /sub_down val_insubd; case: ifP. Qed.

Lemma sub_down_inj_inT (g : U -> S) f (pU := fun x => f x \in P) :
  injective f -> { in pU &, injective (sub_down g f) }.
Proof.
  subst pU; move=> Hf x y; rewrite /in_mem /= => Hx Hy.
  by rewrite /sub_down /insubd !insubT /= => /sub_inj/Hf.
Qed.

Lemma sub_down_inj_inF (g : U -> S) f (pU := fun x => f x \notin P) :
  injective g -> { in pU &, injective (sub_down g f) }.
Proof.
  subst pU; move=> Hg x y; rewrite /in_mem /= => /negP Hx /negP Hy.
  rewrite !sub_downF //; exact/Hg.
Qed.

Lemma sub_liftT g f x Px :
  sub_lift g f x = f (Sub x Px).
Proof. by rewrite /sub_lift /insubd insubT /=. Qed.

Lemma sub_liftF g f x :
  ~ P x -> sub_lift g f x = g x.
Proof. move=> ?; rewrite /sub_lift /insubd insubF //=; exact/negP. Qed.

Lemma sub_lift_inj g f :
  compatible g f -> injective g -> injective f -> injective (sub_lift g f).
Proof.
  move=> Hc Hg Hf x y.
  case: (P x)/idP; case: (P y)/idP=> Hx Hy.
  - rewrite !sub_liftT=> /Hf; exact/sub_inj.
  - by rewrite sub_liftT sub_liftF // => /esym /Hc.
  - by rewrite sub_liftF // sub_liftT=> /Hc.
  rewrite !sub_liftF //; exact/Hg.
Qed.

Lemma sub_lift_homo g f (rT : rel T) (rU : rel U) :
  (forall x y, rT x y -> P y -> P x) ->
  (forall x y, ~ P y -> rU (f x) (g y)) ->
  { homo g : x y / rT x y >-> rU x y } ->
  { homo f : x y / rT (val x) (val y) >-> rU x y } ->
  { homo (sub_lift g f) : x y / rT x y >-> rU x y }.
Proof.
  move=> HrT HrU Hg Hf x y.
  case: (P x)/idP; case: (P y)/idP=> Hx Hy.
  - by rewrite !sub_liftT=> ?; apply/Hf; rewrite !SubK.
  - by rewrite sub_liftT sub_liftF // => ?; apply/HrU.
  - by move: Hx=> /[swap] /HrT /[apply].
  rewrite !sub_liftF //; exact/Hg.
Qed.

Lemma sub_rel_lift_val r (x y : S) :
  sub_rel_lift r (val x) (val y) = r x y.
Proof.
  rewrite /sub_rel_lift /= !insubT; try exact/valP.
  by move=> ??; rewrite !sub_val.
Qed.

Lemma sub_rel_lift_fld r :
  subrel (sub_rel_lift r) [rel x y | P x && P y].
Proof.
  rewrite /sub_rel_lift=> ?? /=.
  by repeat case: insubP=> [? ->|] //.
Qed.

Lemma sub_rel_down_liftK r :
  sub_rel_down (sub_rel_lift r) =2 r.
Proof.
  rewrite /sub_rel_lift /sub_rel_down=> x y /=.
  rewrite !insubT; try exact/valP.
  by move=> ??; rewrite !sub_val.
Qed.

Lemma sub_rel_lift_downK r :
  subrel r [rel x y | P x && P y] -> sub_rel_lift (sub_rel_down r) =2 r.
Proof.
  move=> sub x y /=.
  have ->: r x y = [&& r x y, P x & P y].
  - apply/idP/idP=> [|/and3P[]] //=.
    by move=> /[dup] /sub /andP[] -> -> ->.
  rewrite /sub_rel_lift /sub_rel_down /=.
  apply/idP/idP.
  - repeat (case: insubP=> [? -> ->|] //); by move=> ->.
  move=> /and3P[???].
  repeat (case: insubP=> [?? ->|/negP] //).
Qed.

Lemma sub_rel_liftP (r : rel S) x y :
  reflect (exists x' y', [/\ r x' y', val x' = x & val y' = y])
          (sub_rel_lift r x y).
Proof.
  pose rl := sub_rel_lift r.
  pose r' := [rel x y | P x && P y].
  rewrite -/rl.
  have ->: rl x y = [&& rl x y, P x & P y].
  - apply/idP/idP=> [/[dup] + ->|/and3P[]] //.
    by move=> /sub_rel_lift_fld /andP[-> ->].
  apply/(equivP idP); split.
  - move=> /and3P[rxy px py].
    exists (Sub x px), (Sub y py).
    split; rewrite ?SubK //.
    by move: rxy=> /=; rewrite /rl /sub_rel_lift /= !insubT.
  move=> [x' [] y' []] /=.
  move=> + <- <-; move: (valP x') (valP y').
  move=> /[dup] ? -> /[dup] ? ->.
  by rewrite /rl /sub_rel_lift /= !insubT !andbT !sub_val.
Qed.

Lemma sub_rel_lift_antisym r :
  antisymmetric r -> antisymmetric (sub_rel_lift r).
Proof.
  move=> asym x y.
  rewrite /sub_rel_lift /=.
  case: insubP=> // x' ? <-.
  case: insubP=> // y' ? <-.
  by move=> /asym ->.
Qed.

Lemma sub_rel_lift_trans r :
  transitive r -> transitive (sub_rel_lift r).
Proof.
  move=> trans x y z.
  rewrite /sub_rel_lift /=.
  case: insubP=> // y' ??.
  case: insubP=> // x' ??.
  case: insubP=> // z' ??.
  exact/trans.
Qed.

Lemma eq_sub_rel_down r1 r2 :
  r1 =2 r2 -> sub_rel_down r1 =2 sub_rel_down r2.
Proof. by move=> eqr x y; rewrite /sub_rel_down /= eqr. Qed.

Lemma eq_sub_rel_lift r1 r2 :
  r1 =2 r2 -> sub_rel_lift r1 =2 sub_rel_lift r2.
Proof.
  move=> eqr x y; rewrite /sub_rel_lift /=.
  by do 2 case: insubP=> //.
Qed.

End SubTypeUtils.

Module Export SubFinFun.

Section Def.
Context {aT : finType} {rT : Type}.
Implicit Types (f : {ffun aT -> rT}) (P : pred {ffun aT -> rT}).

Structure subFinfun P : Type := SubFinfun {
  apply :> {ffun aT -> rT};
  _     : P apply;
}.

Canonical subFinfun_subType P := Eval hnf in [subType for (@apply P)].

Definition sub_finfun_of (ph : phant (aT -> rT)) P : predArgType :=
  [subType of (subFinfun P)].

(* TODO: invent better rename or notation? *)
Definition SubFinfunOf f P : P f -> sub_finfun_of (Phant (aT -> rT)) P :=
  fun pf => SubFinfun pf.

End Def.

Notation "{ 'ffun' fT '|' P }" := (sub_finfun_of (Phant fT) P)
  (at level 0, format "{ 'ffun'  fT '|' P }") : type_scope.

Section Instances.
Context {aT : finType}.

Definition subFinfun_eqMixin (rT : eqType) (P : pred {ffun aT -> rT}) :=
  Eval hnf in [eqMixin of {ffun aT -> rT | P} by <:].
Canonical subFinfun_eqType (rT : eqType) (P : pred {ffun aT -> rT}) :=
  Eval hnf in EqType {ffun aT -> rT | P} (subFinfun_eqMixin P).

Definition subFinfun_choiceMixin (rT : choiceType) (P : pred {ffun aT -> rT}) :=
  Eval hnf in [choiceMixin of {ffun aT -> rT | P} by <:].
Canonical subFinfun_choiceType (rT : choiceType) (P : pred {ffun aT -> rT}) :=
  Eval hnf in ChoiceType {ffun aT -> rT | P} (subFinfun_choiceMixin P).

Definition subFinfun_countMixin (rT : countType) (P : pred {ffun aT -> rT}) :=
  Eval hnf in [countMixin of {ffun aT -> rT | P} by <:].
Canonical subFinfun_countType (rT : countType) (P : pred {ffun aT -> rT}) :=
  Eval hnf in CountType {ffun aT -> rT | P} (subFinfun_countMixin P).

Canonical subFinfun_subCountType (rT : countType) (P : pred {ffun aT -> rT}) :=
  Eval hnf in [subCountType of {ffun aT -> rT | P}].

Definition subFinfun_finMixin (rT : finType) (P : pred {ffun aT -> rT}) :=
  Eval hnf in [finMixin of {ffun aT -> rT | P} by <:].
Canonical subFinfun_finType (rT : finType) (P : pred {ffun aT -> rT}) :=
  Eval hnf in FinType {ffun aT -> rT | P} (subFinfun_finMixin P).

Canonical subFinfun_subFinType (rT : finType) (P : pred {ffun aT -> rT}) :=
  Eval hnf in [subFinType of {ffun aT -> rT | P}].

End Instances.

End SubFinFun.

Module Export Subsumes.

Section Def.
Context {T : Type}.
Implicit Types (r : rel T) (mp : mem_pred T).

Definition subsumes_mem r mp1 mp2 :=
  forall x, in_mem x mp1 -> exists2 y, in_mem y mp2 & r x y.

End Def.

Notation "{ 'subsumes' A <= B 'by' R }" :=
  (subsumes_mem R (mem A) (mem B))
    (A at level 69, B at level 69) : type_scope.

Notation "{ 'subsumes' A <= B : x y / a }" :=
  (subsumes_mem (fun x y => a) (mem A) (mem B))
    (A at level 69, B at level 69, x at level 0, y at level 0) : type_scope.

Section Theory.
Context {T : Type}.
Implicit Types (P Q S : pred T) (R : rel T).

Lemma subsumes_refl R P :
  reflexive R -> { subsumes P <= P by R }.
Proof. by move=> ? p ?; exists p. Qed.

Lemma subsumes_trans R P Q S : transitive R ->
  {subsumes P <= Q by R} -> {subsumes Q <= S by R} -> {subsumes P <= S by R}.
Proof.
  move=> trans pq_subs qs_subs p.
  move: pq_subs=> /[apply] [[q]].
  move: qs_subs=> /[apply] [[s]].
  move=> ss /[swap].
  move: trans=> /[apply] /[apply].
  by exists s.
Qed.

End Theory.

End Subsumes.

Section IterUtils.
Context {T : Type}.
Implicit Types (f : T -> T).
Implicit Types (r : rel T).

(* TODO: r could be T -> T -> Prop ? *)
Lemma homo_iter r f n :
  { homo f : x y / r x y } -> { homo (iter n f) : x y / r x y }.
Proof.
  elim n=> [|{}n IH] //=.
  - by move=> ? x y /=.
  move=> homo x y /= ?.
  by apply/homo/IH.
Qed.

Lemma iter_mul_eq n m f x :
  iter m f x = x -> iter (n * m) f x = x.
Proof.
  move=> fmx; elim: n=> [|{}n IH] => //=.
  by rewrite mulSnr iterD fmx IH.
Qed.

End IterUtils.

Arguments homo_iter {T} [r] f n.

Section FSetInduction.

Open Scope fset_scope.

Lemma fset_ind (A : choiceType) (P : {fset A} -> Prop) :
  P fset0 ->
  (forall a l, a \notin l -> P l -> P (a |` l)) ->
  forall l, P l.
Proof.
  move=> ? Ps X.
  have [n leMn] := ubnP #|` X|; elim: n => // n IHn in X leMn *.
  case (fset_0Vmem X)=> [->//| [x]/[dup] I /fsetD1K<-].
  apply/Ps/IHn; first by rewrite ?inE eqxx.
  by rewrite (cardfsD1 x) I /= addnC addn1 in leMn.
Qed.

End FSetInduction.

Section Imfset.

Open Scope fset_scope.

Lemma imfset_comp (K V W : choiceType)
  (f : K -> V) (g : V -> W) (p : {fset K}) :
  (g \o f) @` p = g @` (f @` p).
Proof.
  apply/fsetP=> a; apply/imfsetP/imfsetP=> [[/= x xA ->]|].
    by exists (f x); rewrite // in_imfset.
  by move=> [/= x /imfsetP [/= y yA ->] ->]; exists y.
Qed.

Lemma imfset0 (K V : choiceType)
  (f : K -> V) : f @` fset0 = fset0.
Proof.
  apply/cardfs0_eq/eqP; rewrite -leqn0.
  exact/(leq_trans (leq_imfset_card _ _ _)).
Qed.

End Imfset.

Section FinMapCount.
Variable (K : countType) (V : countType).
Implicit Types (d : K -> V).

Definition finMap_countMixin := CanCountMixin (@finMap_codeK K V).
Canonical finMap_countType := CountType {fmap K -> V} finMap_countMixin.

Definition fsfun_countMixin d := [countMixin of (fsfun d) by <:].
Canonical fsfun_countType d := CountType (fsfun d) (fsfun_countMixin d).

End FinMapCount.

Section FinMapUtils.
Context {K : choiceType} {V : eqType}.
Implicit Types (A : {fset K}).

Lemma finsupp_fset (A : {fset K}) (f : K -> V) dflt :
  finsupp [fsfun k in A => f k | dflt] = [fset k in A | f k != dflt]%fset.
Proof.
  apply/fsetP=> x.
  rewrite mem_finsupp fsfunE in_fset !inE /=.
  by case: (x \in A)=> //; rewrite eq_refl.
Qed.

Context {P : pred K} {fK : subFinType P}.

Lemma in_fsetval k :
  (k \in [fsetval k' in fK])%fset = (insub k : option fK).
Proof.
  case: insubP=> /=.
  - move=> k' ? <-; apply/idP/idP=> //.
    by apply/imfsetP; exists k'.
  move=> /negP nPe.
  apply/idP/idP=> //; apply/negP.
  move=> /imfsetP[k''] /= ? H; apply/nPe.
  by move: (valP k''); rewrite H.
Qed.

Lemma in_fsetval_seq k (s : seq fK) :
  (k \in [fsetval k' in s])%fset =
    if insub k is Some k' then k' \in s else false.
Proof.
  case: insubP=> /=.
  - move=> k' ? <-; apply/idP/idP=> //.
    + by move=> /imfsetP[k''] /= + /val_inj ->.
    by move=> ?; apply/imfsetP; exists k'.
  move=> /negP nPk; apply/idP/idP=> //.
  apply/negP=> /imfsetP[k''] /= ? H.
  by move: (valP k''); rewrite -H.
Qed.

End FinMapUtils.

Section QuotUtils.
Variables (T : Type) (e : rel T) (Q : eqQuotType e).

Lemma eqquot_eqP (x y : Q) :
  reflect (x = y) (e (repr x) (repr y)).
Proof. by apply/equivP; first exact/eqquotP; rewrite !reprK. Qed.

Lemma eqquot_eqE (x y : Q) :
  (x == y) = (e (repr x) (repr y)).
Proof. exact/eqP/eqquot_eqP. Qed.

Lemma piK (x : T) :
  (repr (\pi_Q x) = x %[mod Q])%qT.
Proof. by rewrite reprK. Qed.

Lemma eqquot_piE (x : Q) (y : T) :
  x == (\pi y)%qT = e (repr x) y.
Proof.
  rewrite eqquot_eqE; apply/etrans.
  - by rewrite -(@eqquotE T e Q) piK.
  by rewrite -(@eqquotE T e Q).
Qed.

Lemma eqquot_piP (x : Q) (y : T) :
  reflect (x = (\pi y)%qT) (e (repr x) y).
Proof. apply/(equivP idP); rewrite -eqquot_piE; symmetry; exact/(rwP eqP). Qed.

End QuotUtils.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  The typing module.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.
Require Import Coq.Bool.Bool.
Require Import Coq.Structures.Equalities.

Require Export BooleanEqualityDef.
Require Export TVarModuleDef.
Require Export KappaModuleDef.
Require Export PhiModuleDef.
Require Export CpdtTactics.
Require Export Case.
Require Export MoreTacticals.

Module TauModule <: BooleanEquality.

Module Types.
 Module K := KappaModule.
 Include K.Types.
 Module P := PhiModule.
 Include P.Types.

 Module TVS  := TVarModuleSet.
 Module TV  := TVarModuleSet.BE.
 Definition TVar := TVS.elt.
 Definition TVars := TVS.t.

Inductive Tau : Type :=
 | btvar  : nat -> Tau                               (* A bound type variable, a de Bruijn index. *)
 | ftvar  : TVar -> Tau                              (* A free type variable. *)
 | cint   : Tau                                      (* Cyclone's Integers. *)
 | cross  : Tau -> Tau -> Tau                        (* Pairs. *)
 | arrow  : Tau -> Tau -> Tau                        (* Function    type. *)
 | ptype  : Tau -> Tau                               (* Pointer     type. *)
 | utype  : K.Kappa -> Tau -> Tau                    (* Universal   type. *)
 | etype  : P.Phi -> K.Kappa -> Tau -> Tau.          (* Existential type. *)

End Types.
Include Types.

Fixpoint fv_tau (tau : Tau) {struct tau} : TVS.t :=
  match tau with
    | btvar i     => TVS.empty
    | ftvar x     => TVS.singleton x
    | cint        => TVS.empty
    | cross t0 t1 => TVS.union (fv_tau t0) (fv_tau t1)
    | arrow t0 t1 => TVS.union (fv_tau t0) (fv_tau t1)
    | ptype t0    => (fv_tau t0)
    | utype k t0   => (fv_tau t0)
    | etype _ _ t0   => (fv_tau t0)
end.

Fixpoint open_rec_tau  (k : nat) (tau' : Tau) (tau : Tau)  {struct tau}  : Tau :=
 match tau with
   | btvar i       => if (beq_nat k i) then tau' else (btvar i)
   | ftvar i       => ftvar i
   | cint          => cint
   | cross t0 t1   => cross (open_rec_tau k tau' t0) (open_rec_tau k tau' t1)
   | arrow t0 t1   => arrow (open_rec_tau k tau' t0) (open_rec_tau k tau' t1)
   | ptype  t0     => ptype (open_rec_tau k tau' t0)
   | utype kp t0   => utype kp (open_rec_tau (S k) tau' t0)
   | etype p kp t0 => etype p kp (open_rec_tau (S k) tau' t0)
  end.

(* Is this complete ?*)
Inductive lc_tau : Tau -> Prop :=
 | lc_tau_cint  : lc_tau cint
 | lc_tau_ftvar : forall x, lc_tau (ftvar x)
 | lc_tau_cross : forall t0 t1, lc_tau t0 -> lc_tau t1 -> lc_tau (cross t0 t1)
 | lc_tau_arrow : forall t0 t1, lc_tau t0 -> lc_tau t1 -> lc_tau (arrow t0 t1)
 | lc_tau_ptype : forall t0, lc_tau t0 -> lc_tau (ptype t0)
 | lc_tau_utype : forall L' k t0,
                  (forall alpha, (TVS.mem alpha L') = false
                                 -> lc_tau (open_rec_tau 0 (ftvar alpha) t0)) ->
                  lc_tau (utype k t0)
 | lc_tau_etype : forall L' p k t0,
                  (forall alpha, (TVS.mem alpha L') = false
                                 -> lc_tau (open_rec_tau 0 (ftvar alpha) t0)) ->
                  lc_tau (etype p k t0).

Fixpoint subst_Tau  (t : Tau) (tau : Tau) (alpha : TVar) {struct t} : Tau :=
  match t with
    | btvar i      => btvar i
    | ftvar beta   => if (TVS.BE.eqb alpha beta) then tau else (ftvar beta)
    | cint         => cint
    | cross t0 t1  => cross (subst_Tau t0 t alpha) (subst_Tau t1 t alpha)
    | arrow t0 t1  => arrow (subst_Tau t0 t alpha) (subst_Tau t1 t alpha)
    | ptype t0     => ptype (subst_Tau t0 t alpha)
    | utype k t0   => utype k (subst_Tau t0 t alpha)
    | etype p k t0 => etype p k (subst_Tau t0 t alpha)
end.

Function eqb (t t' : Tau) : bool :=
 match t, t' with
 | btvar i, btvar j => beq_nat i j
 | ftvar alpha, ftvar beta => TVS.eqb alpha beta
 | cint, cint => true
 | (cross t0 t1), (cross t0' t1') => andb (eqb t0 t0') (eqb t1 t1')
 | (arrow t0 t1), (arrow t0' t1') => andb (eqb t0 t0') (eqb t1 t1')
 | ptype t, ptype t' => (eqb t t')
 | utype kappa tau, utype kappa' tau' =>
   andb (K.eqb kappa kappa') (eqb tau tau')
 | etype p kappa tau, etype p' kappa' tau' =>
   andb (andb (P.eqb p p')  (K.eqb kappa kappa'))
        (eqb tau tau')
 | _ , _ => false
end.
Hint Unfold eqb.
Hint Resolve eqb.

Fixpoint eq (a b : Tau) : Prop :=
    match eqb a b with
     | false => False
     | true => True
    end.
Hint Unfold eq.

Ltac destruct_away :=
  repeat match goal with
    | [ |- ?X = true ] => destruct X; try solve[inversion H]; try reflexivity
         end.

Lemma eqb_eq : forall x y : Tau, eqb x y = true <-> eq x y.
Proof.
  induction x; induction y;  unfold iff; split; intros;
  try solve[unfold eq;
             rewrite H;
             reflexivity];
  unfold eq in H;
  repeat match goal with
    | [ |- ?X = true ] => destruct X; try solve[inversion H]; try reflexivity
  end.
Qed.

Lemma eqb_to_eq:
  forall t0 t1, eqb t0 t1 = true -> t0 = t1.
Proof.
  induction t0; induction t1; intros; try solve [inversion H]; try reflexivity.

  unfold eqb in H.
  symmetry in H.
  apply beq_nat_eq in H.
  subst.
  reflexivity.

  unfold eqb in H.
  apply TVS.eqb_to_eq in H.
  subst.
  reflexivity.

  unfold eqb in H.
  fold eqb in H.
  apply andb_true_iff in H.
  inversion H.
  apply IHt0_1 in H0.
  apply IHt0_2 in H1.
  subst.
  reflexivity.

  unfold eqb in H.
  fold eqb in H.
  apply andb_true_iff in H.
  inversion H.
  apply IHt0_1 in H0.
  apply IHt0_2 in H1.
  subst.
  reflexivity.

  unfold eqb in H.
  fold eqb in H.
  apply IHt0 in H.
  rewrite H.
  reflexivity.

  unfold eqb in H.
  fold eqb in H.
  apply andb_true_iff in H.
  inversion H.
  apply IHt0 in H1.
  apply K.eqb_to_eq in H0.
  subst.
  reflexivity.

  unfold eqb in H.
  fold eqb in H.
  apply andb_true_iff in H.
  inversion H.
  apply andb_true_iff in H0.
  inversion H0.
  apply IHt0 in H1.
  apply P.eqb_to_eq in H2.
  apply K.eqb_to_eq in H3.
  subst.
  reflexivity.
Qed.
Hint Resolve eqb_eq.

Lemma eqb_refl:
 forall (t : Tau),
   eqb t t = true.
Proof.
  intros.
  induction t; crush.
  symmetry.
  apply beq_nat_refl.
Qed.
Hint Resolve eqb_refl.

Lemma eq_refl:
 forall (a : Tau),
   eq a a.
Proof.
  intros.
  apply eqb_eq.
  apply eqb_refl.
Qed.

Ltac apply_beq_eqs :=
  repeat match goal with
    | [ I : eqb _ _ = true
        |- _ ] => apply eqb_to_eq in I; subst; try reflexivity; try assumption
    | [ I : P.eqb _ _ = true
        |- _ ] => apply P.eqb_to_eq in I; subst; try reflexivity; try assumption
    | [ I : K.eqb _ _ = true
        |- _ ] => apply K.eqb_to_eq in I; subst; try reflexivity; try assumption
    | [ I : TVS.eqb _ _ = true
        |- _ ] => apply TVS.eqb_to_eq in I; subst; try reflexivity; try assumption
end.

Lemma eqb_iff_eq:    forall a b, eqb a b = true <-> a = b.
Proof.
  induction a; induction b;
  unfold iff;
  split;
  intros;
  try reflexivity;
  try solve [inversion H];
  try solve [inversion H;
             subst;
             apply eqb_refl;
             reflexivity];
  apply_beq_eqs.
Qed.
Hint Resolve eqb_iff_eq.

Ltac apply_eqs_sym :=
  repeat match goal with
    | [ |- beq_nat ?n ?n' = beq_nat ?n' ?n ] =>
      apply beq_nat_sym
    | [ |- TVS.eqb ?n ?n' = TVS.eqb ?n' ?n ] =>
      apply TVS.eqb_sym
end.

Lemma eqb_sym : forall x y, eqb x y = eqb y x.
Proof.
  induction x; induction y; auto;
  try solve[
        unfold eqb;
        fold eqb;
        apply_eqs_sym];
  try solve[refold eqb;
             apply IHx];
  try solve[refold eqb;
             congruence];
  try solve[
        refold eqb;
        try rewrite K.eqb_sym;
        try rewrite P.eqb_sym;
        try rewrite IHx;
        congruence].
Qed.
Hint Immediate eqb_sym.

Lemma eq_sym : forall x y : Tau, eq x y -> eq y x.
Proof.
  intros.
  apply eqb_eq.
  apply eqb_eq in H.
  rewrite eqb_sym.
  assumption.
Qed.

Lemma eqb_to_neq:
  forall t0 t1, eqb t0 t1 = false -> t0 <> t1.
Proof.
  induction t0; induction t1; intros; try solve [inversion H]; try solve [discriminate];
  try solve[refold_in eqb H;
            try apply beq_nat_false_iff in H;
            try apply TVS.eqb_to_neq in H;
            congruence];
  try solve[inversion H;
             try apply andb_false_iff in H1;
             try apply IHt0 in H;
             inversion H1;
             try apply IHt0_1 in H0;
             try apply IHt0_2 in H0;
             congruence];
  try solve[refold_in eqb H;
             simplify_boolean_and_false;
             try apply K.eqb_to_neq in H0;
             try apply P.eqb_to_neq in H0;
             try apply IHt0 in H0;
             try apply K.eqb_to_neq in H;
             try apply P.eqb_to_neq in H;
             try apply IHt0 in H0;
             congruence].
Qed.
Hint Resolve eqb_to_neq.

Ltac fold_n_neq :=
  repeat match goal with
    | [ I : eqb ?x ?y = false |- ?x <> ?y  ] =>
      fold eqb in I; unfold eqb in I; simplify_boolean_and_false
    | [ I : eqb ?x _ = false,
        IH: forall _, eqb ?x _ = false <-> ?x <> _
       |- _ <> _  ] =>
       apply IH in I; congruence
    | [ H : TVS.eqb _ _ = false |- _ ] =>
      apply TVS.eqb_to_neq in H; try congruence
    | [ H : K.eqb _ _ = false |- _ ] =>
      apply K.eqb_to_neq in H; try congruence
    | [ H : P.eqb _ _ = false |- _ ] =>
      apply P.eqb_to_neq in H; try congruence
end.

Lemma eqb_iff_neq:   forall a b, eqb a b = false <-> a <> b.
Proof.
  induction a; induction b; try split; try intros;
  try solve[congruence];
  try solve[simpl; reflexivity];  try solve[simpl in H; inversion H];
  try solve [unfold eqb in H;
             fold eqb in H;
             simplify_boolean_and_false;
             try apply eqb_to_neq in H;
             try apply eqb_to_neq in H0;
             congruence];
  try solve[unfold eqb in H;
            fold eqb in H;
            simplify_boolean_and_false;
            fold_n_neq;
            congruence].
Admitted.
Hint Resolve eqb_iff_neq.

Lemma eqb_trans:
  forall x y z,
    eqb x y = true -> eqb y z = true -> eqb x z = true.
Proof.
  intros.
  pose proof H as H'.
  pose proof H0 as H0'.
  apply eqb_to_eq in H.
  apply eqb_to_eq in H0.
  subst.
  assumption.
Qed.
Hint Resolve eqb_trans.

Lemma eq_trans :
  forall x y z,
    eq x y -> eq y z -> eq x z.
Proof.
  intros.
  apply eqb_eq in H.
  apply eqb_eq in H0.
  apply eqb_eq.
  apply eqb_trans with (x:= x) (y:= y) (z:= z); try assumption.
Qed.

Instance eq_equiv : Equivalence eq.
Proof.
  split.
  exact eq_refl.
  exact eq_sym.
  exact eq_trans.
Defined.

Ltac destruct_evidence :=
  repeat match goal with
    | [ |- {(if ?X then True else False)} + { _ } ] =>
      destruct X; try solve[simpl; right; congruence];
      try solve[simpl; left; trivial]
 end.

Lemma eq_dec : forall x y : Tau, {eq x y} + {~ eq x y}.
Proof.
  intros.
  induction x; induction y; unfold eq; destruct_evidence.
Qed.

Definition t:= Tau.

End TauModule.


Require Import Coqlib.
Require Import Errors.
Require Import Integers.
Require Import Tree.
Require Import String.
Require Import Asm.

Require Extractor.
Require TransUtil.
Require TransLayerStatement.
Require TransBranchInfo.

Local Open Scope error_monad_scope.

Set Implicit Arguments.

Fixpoint calculate_length (e : expression) (pil : list pin_info) : res int :=
  match e with
  | Length_Expression id =>
    do proto_info <- TransUtil.find_protocol_info_in_pin_list id pil;
    OK (proto_length proto_info)
  | Binary_Expression bin_op bin_expr1 bin_expr2 =>
    do len1 <- calculate_length bin_expr1 pil;
    do len2 <- calculate_length bin_expr2 pil;
    OK (Int.add len1 len2)
  | Constant_Expression con =>
    TransUtil.to_int con
  | _ =>
    Error (msg "invalid expression type 1!")
  end.

Definition trans_cell_alpha_pc_item
  (b_index : int)
  (bi : branch_info)
  (pil : list pin_info) : res alpha_pc_item :=
  do stmt_list <- OK (stmt bi);
  do length_expr <- Extractor.extract_length_statement_expression stmt_list;
  do length <- calculate_length length_expr pil;
  OK (Alpha_Pc_Item b_index Int.one length)
  .

Fixpoint trans_cell_alpha_pc_item_list
  (b_index : int)
  (bil : list branch_info)
  (pil : list pin_info) : res (list alpha_pc_item) :=
  match bil with
  | nil =>
    OK nil
  | hd :: tl =>
    do v1 <- trans_cell_alpha_pc_item b_index hd pil;
    do v2 <- trans_cell_alpha_pc_item_list (Int.add b_index Int.one) tl pil;
    OK (v1 :: v2)
  end.

Definition trans_cell_alpha_pc
  (bil : list branch_info)
  (pil : list pin_info) : res alpha_pc :=
  do alpha_pc_item_list <- trans_cell_alpha_pc_item_list Int.one bil pil;
  OK (Alpha_Pc alpha_pc_item_list)
  .

Fixpoint trans_cell_alpha_pb_item
  (l_index : int)
  (b_index : int)
  (bi : branch_info)
  (pil : list pin_info)
  (ps : protocol_set) : res alpha_pb_item :=
  do stmt_list <- OK (stmt bi);
  do next_id <- TransUtil.find_next_header stmt_list ps;
  do bypass_id <- TransUtil.find_bypass stmt_list;

  OK (Alpha_Pb_Item l_index (cond bi) b_index next_id bypass_id ).

Fixpoint trans_cell_alpha_pb_item_list
  (l_index : int)
  (b_index : int)
  (ibl : list branch_info)
  (pil : list pin_info)
  (ps : protocol_set) : res (list alpha_pb_item) :=
  match ibl with
  | nil =>
    OK nil
  | hd :: tl =>
    do v1 <- trans_cell_alpha_pb_item l_index b_index hd pil ps;
    do v2 <- trans_cell_alpha_pb_item_list l_index (Int.add b_index Int.one) tl pil ps;
    OK (v1 :: v2)
  end.

Definition trans_cell_alpha_pb
  (l_index : int)
  (bil : list branch_info)
  (pil : list pin_info)
  (ps : protocol_set) : res alpha_pb :=
  do alpha_pb_item_list <- trans_cell_alpha_pb_item_list  l_index Int.one bil pil ps;
  OK (Alpha_Pb alpha_pb_item_list)
  .

Definition translate
  (l_index : int)
  (caa : cell_a_action)
  (car : cell_a_register)
  (pil : list pin_info)
  (ps : protocol_set) : res cell_alpha :=
  match caa with
  | Cell_A_Action layer_stmt =>
    match layer_stmt with
    | Layer_Statement stmt_list =>
      do layer_branch_info_list <- TransLayerStatement.translate stmt_list pil;
      do proto_branch_info_list <- Extractor.extract_protocol_branch_info_list pil;
      do all_branch_info_list <- TransBranchInfo.mix_branch_info (layer_branch_info_list :: proto_branch_info_list);
      do alpha_pb <- trans_cell_alpha_pb l_index all_branch_info_list pil ps;
      do alpha_pc <- trans_cell_alpha_pc all_branch_info_list pil;
      OK (Cell_Alpha alpha_pb alpha_pc)
    end
  end.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.reals.CReals1.

Section Lists.

(**
* Lists of Real Numbers

In some contexts we will need to work with nested existential quantified formulas of the form $\exists_{n\in\NN}\exists_{x_1,\ldots,x_n}P(x_1,\ldots,x_n)$#exists n exists x1,...,xn P(x1,..,xn)#.  One way of formalizing this kind of statement is through quantifying over lists.  In this file we provide some tools for manipulating lists.

Notice that some of the properties listed below only make sense in the context within which we are working.  Unlike in the other lemma files, no care has been taken here to state the lemmas in their most general form, as that would make them very unpractical to use.

%\bigskip%

We start by defining maximum and minimum of lists of reals and two membership predicates. The value of these functions for the empty list is arbitrarily set to 0, but it will be irrelevant, as we will never work with empty lists.
*)

Fixpoint maxlist (l : list IR) : IR :=
  match l with
  | nil        => [0]
  | cons x nil => x
  | cons x m   => Max x (maxlist m)
  end.

Fixpoint minlist (l : list IR) : IR :=
  match l with
  | nil        => [0]
  | cons x nil => x
  | cons x m   => Min x (minlist m)
  end.

Fixpoint member (x : IR) (l : list IR) {struct l} : CProp :=
  match l with
  | nil      => False
  | cons y m => member x m or x [=] y
  end.

(**
Sometimes the length of the list has to be restricted; the next definition provides an easy way to do that. *)

Definition length_leEq (A : Type) (l : list A) (n : nat) := length l <= n.

(** Length is preserved by mapping. *)

Arguments map [A B].

Lemma map_pres_length : forall (A B : Set) (l : list A) (f : A -> B),
 length l = length (map f l).
Proof.
 intros.
 induction  l as [| a l Hrecl].
  auto.
 simpl in |- *; auto.
Qed.

(**
Often we want to map partial functions through a list; this next operator provides a way to do that, and is proved to be correct. *)

Arguments cons [A].

Definition map2 (F : PartIR) (l : list IR) :
 (forall y, member y l -> Dom F y) -> list IR.
Proof.
 intros H.
 induction l as [| a l Hrecl].
  apply (@nil IR).
 apply cons.
  cut (member a (cons a l)); [ intro | right; algebra ]; rename X into H0.
  apply (Part F a (H a H0)).
 cut (forall y : IR, member y l -> Dom F y); intros; rename X into H0.
  2: apply H; left; assumption.
 apply (Hrecl H0).
Defined.

Lemma map2_wd : forall F l H H' x,
 member x (map2 F l H) -> member x (map2 F l H').
Proof.
 intros. rename X into H0.
 induction  l as [| a l Hrecl].
  simpl in |- *; simpl in H0; assumption.
 simpl in H0; inversion_clear H0. rename X into H0.
  simpl in |- *; left.
  apply Hrecl with (fun (y : IR) (H0 : member y l) => H y (@inl (member y l) (y [=] a) H0)).
  assumption.
 right.
 eapply eq_transitive_unfolded.
  apply H1.
 simpl in |- *; apply pfwdef; algebra.
Qed.

Lemma map2_pres_member : forall (F : PartIR) x Hx l H,
 member x l -> member (F x Hx) (map2 F l H).
Proof.
 intros. rename X into H0.
 induction  l as [| a l Hrecl].
  simpl in |- *; simpl in H; assumption.
 simpl in |- *.
 elim H0.
  intro; left; apply Hrecl; assumption.
 intro; right.
 apply pfwdef; assumption.
Qed.

(**
As [maxlist] and [minlist] are generalizations of [Max] and [Min] to finite sets of real numbers, they have the expected properties: *)

Lemma maxlist_greater : forall l x, member x l -> x [<=] maxlist l.
Proof.
 intros l x H.
 induction  l as [| a l Hrecl].
  exfalso; assumption.
 simpl in |- *.
 induction  l as [| a0 l Hrecl0].
  simpl in H; elim H.
   intro; tauto.
  intro; apply eq_imp_leEq.
  auto.
 simpl in H.
 elim H.
  intro.
  apply leEq_transitive with (maxlist (cons a0 l)).
   apply Hrecl; assumption.
  apply rht_leEq_Max.
 intro; astepl a; apply lft_leEq_Max.
Qed.

(* begin hide *)
Let maxlist_aux :
  forall (a b : IR) (l : list IR),
  maxlist (cons a (cons b l)) [=] maxlist (cons b (cons a l)).
Proof.
 intros.
 case l.
  simpl in |- *; apply Max_comm.
 intros c m.
 astepl (Max a (Max b (maxlist (cons c m)))).
 astepr (Max b (Max a (maxlist (cons c m)))).
 apply leEq_imp_eq; apply Max_leEq.
    eapply leEq_transitive.
     2: apply rht_leEq_Max.
    apply lft_leEq_Max.
   apply Max_leEq.
    apply lft_leEq_Max.
   eapply leEq_transitive.
    2: apply rht_leEq_Max.
   apply rht_leEq_Max.
  eapply leEq_transitive.
   2: apply rht_leEq_Max.
  apply lft_leEq_Max.
 apply Max_leEq.
  apply lft_leEq_Max.
 eapply leEq_transitive.
  2: apply rht_leEq_Max.
 apply rht_leEq_Max.
Qed.
(* end hide *)

Lemma maxlist_leEq_eps : forall l : list IR, {x : IR | member x l} ->
 forall e, [0] [<] e -> {x : IR | member x l | maxlist l[-]e [<=] x}.
Proof.
 intro l; induction  l as [| a l Hrecl].
  intro H; simpl in H; inversion H as [x H0]; inversion H0.
 clear Hrecl.
 intro H; induction  l as [| a0 l Hrecl]; intros e H0.
  simpl in |- *; exists a.
   right; algebra.
  apply less_leEq; apply shift_minus_less; apply shift_less_plus'.
  astepl ZeroR; assumption.
 cut ({Max a0 (maxlist (cons a l)) [-]e [/]TwoNZ [<=] a0} +
   {Max a0 (maxlist (cons a l)) [-]e [/]TwoNZ [<=] maxlist (cons a l)}).
  2: apply Max_minus_eps_leEq; apply pos_div_two; assumption.
 intro H1.
 elim H1; intro H2.
  exists a0.
   simpl in |- *; left; right; algebra.
  apply leEq_transitive with (Max a (maxlist (cons a0 l)) [-]e [/]TwoNZ).
   astepl (Max a (maxlist (cons a0 l)) [-]e).
   apply shift_leEq_minus; apply shift_plus_leEq'.
   rstepr e.
   apply less_leEq; apply pos_div_two'; assumption.
  apply shift_minus_leEq.
  astepl (maxlist (cons a (cons a0 l))).
  eapply leEq_wdl.
   2: apply maxlist_aux.
  astepl (Max a0 (maxlist (cons a l))).
  apply shift_leEq_plus; assumption.
 elim Hrecl with (e [/]TwoNZ).
   intros x p q.
   exists x.
    elim p; intro H3.
     left; left; assumption.
    right; assumption.
   apply shift_minus_leEq; eapply leEq_wdl.
    2: apply maxlist_aux.
   apply shift_leEq_plus.
   astepl (Max a0 (maxlist (cons a l)) [-]e).
   rstepl (Max a0 (maxlist (cons a l)) [-]e [/]TwoNZ[-]e [/]TwoNZ).
   apply leEq_transitive with (maxlist (cons a l) [-]e [/]TwoNZ).
    apply minus_resp_leEq; assumption.
   assumption.
  exists a; right; algebra.
 apply pos_div_two; assumption.
Qed.

Lemma maxlist_less : forall x l,
 0 < length l -> (forall y, member y l -> y [<] x) -> maxlist l [<] x.
Proof.
 simple induction l.
  simpl in |- *; intros; exfalso; inversion H.
 clear l.
 do 2 intro. intro H.
 clear H; induction  l as [| a0 l Hrecl].
  simpl in |- *; intros H H0.
  apply H0; right; algebra.
 generalize l a0 Hrecl; clear Hrecl l a0.
 intros l b; intros. rename X into H0.
 eapply less_wdl.
  2: apply maxlist_aux.
 astepl (Max b (maxlist (cons a l))).
 apply Max_less.
  apply H0; left; right; algebra.
 apply Hrecl.
  simpl in |- *; apply lt_O_Sn.
 intros y H1.  apply H0.
 inversion_clear H1.
  left; left; assumption.
 right; assumption.
Qed.

Lemma maxlist_leEq : forall y l,
 0 < length l -> (forall x, member x l -> x [<=] y) -> maxlist l [<=] y.
Proof.
 simple induction l.
  simpl in |- *; intros; exfalso; inversion H.
 clear l.
 do 3 intro.
 clear H; induction  l as [| a0 l Hrecl].
  simpl in |- *; intros.
  apply H0; right; algebra.
 generalize l a0 Hrecl; clear Hrecl l a0.
 intros l b; intros.
 eapply leEq_wdl.
  2: apply maxlist_aux.
 astepl (Max b (maxlist (cons a l))).
 apply Max_leEq.
  apply H0; left; right; algebra.
 apply Hrecl.
  simpl in |- *; auto with arith.
 intros x H1. apply H0.
 inversion_clear H1.
  left; left; assumption.
 right; assumption.
Qed.

Lemma minlist_smaller : forall l x, member x l -> minlist l [<=] x.
Proof.
 intros l x H.
 induction  l as [| a l Hrecl].
  easy.
 simpl in |- *.
 astepl match l with | nil => a | cons _ _ => Min a (minlist l) end.
 induction  l as [| a0 l Hrecl0].
  simpl in H; elim H.
   intro; tauto.
  intro; cut (a [=] x); [ apply eq_imp_leEq | apply eq_symmetric_unfolded; assumption ].
 simpl in H.
 elim H.
  intro.
  apply leEq_transitive with (minlist (cons a0 l)).
   apply Min_leEq_rht.
  apply Hrecl; assumption.
 intro; astepr a; apply Min_leEq_lft.
Qed.

(* begin hide *)
Let minlist_aux :
  forall (a b : IR) (l : list IR),
  minlist (cons a (cons b l)) [=] minlist (cons b (cons a l)).
Proof.
 intros.
 case l.
  astepl (Min a b); astepr (Min b a); apply Min_comm.
 intros c m.
 astepl (Min a (Min b (minlist (cons c m)))).
 astepr (Min b (Min a (minlist (cons c m)))).
 apply leEq_imp_eq; apply leEq_Min.
    eapply leEq_transitive.
     apply Min_leEq_rht.
    apply Min_leEq_lft.
   apply leEq_Min.
    apply Min_leEq_lft.
   eapply leEq_transitive.
    apply Min_leEq_rht.
   apply Min_leEq_rht.
  eapply leEq_transitive.
   apply Min_leEq_rht.
  apply Min_leEq_lft.
 apply leEq_Min.
  apply Min_leEq_lft.
 eapply leEq_transitive.
  apply Min_leEq_rht.
 apply Min_leEq_rht.
Qed.
(* end hide *)

Lemma minlist_leEq_eps : forall l : list IR, {x : IR | member x l} ->
 forall e, [0] [<] e -> {x : IR | member x l | x [<=] minlist l[+]e}.
Proof.
 intro l; induction  l as [| a l Hrecl].
  intro H; simpl in H; inversion H as [x H0]; inversion H0.
 clear Hrecl.
 intro H; induction  l as [| a0 l Hrecl]; intros e He.
  simpl in |- *; exists a.
   right; algebra.
  apply less_leEq; apply shift_less_plus'.
  astepl ZeroR; assumption.
 cut ({a0 [<=] Min a0 (minlist (cons a l)) [+]e [/]TwoNZ} +
   {minlist (cons a l) [<=] Min a0 (minlist (cons a l)) [+]e [/]TwoNZ}).
  2: apply leEq_Min_plus_eps; apply pos_div_two; assumption.
 intro H1.
 elim H1; intro H2.
  exists a0.
   simpl in |- *; left; right; algebra.
  apply leEq_transitive with (Min a (minlist (cons a0 l)) [+]e [/]TwoNZ).
   apply shift_leEq_plus.
   astepr (minlist (cons a (cons a0 l))).
   eapply leEq_wdr.
    2: apply minlist_aux.
   astepr (Min a0 (minlist (cons a l))).
   apply shift_minus_leEq; assumption.
  astepr (Min a (minlist (cons a0 l)) [+]e).
  apply plus_resp_leEq_lft.
  apply less_leEq; apply pos_div_two'; assumption.
 elim Hrecl with (e [/]TwoNZ).
   intros x p q.
   exists x.
    elim p; intro H3.
     left; left; assumption.
    right; assumption.
   apply shift_leEq_plus; eapply leEq_wdr.
    2: apply minlist_aux.
   apply shift_minus_leEq.
   astepr (Min a0 (minlist (cons a l)) [+]e).
   rstepr (Min a0 (minlist (cons a l)) [+]e [/]TwoNZ[+]e [/]TwoNZ).
   apply leEq_transitive with (minlist (cons a l) [+]e [/]TwoNZ).
    assumption.
   apply plus_resp_leEq; assumption.
  exists a; right; algebra.
 apply pos_div_two; assumption.
Qed.

Lemma less_minlist : forall x l,
 0 < length l -> (forall y, member y l -> x [<] y) -> x [<] minlist l.
Proof.
 simple induction l.
  simpl in |- *; intros; exfalso; inversion H.
 clear l.
 do 2 intro. intro H.
 clear H; induction  l as [| a0 l Hrecl].
  simpl in |- *; intros H H0.
  apply H0; right; algebra.
 generalize l a0 Hrecl; clear Hrecl l a0.
 intros l b; intros. rename X into H0.
 eapply less_wdr.
  2: apply minlist_aux.
 astepr (Min b (minlist (cons a l))).
 apply less_Min.
  apply H0; left; right; algebra.
 apply Hrecl.
  simpl in |- *; auto with arith.
 intros y H1; apply H0.
 inversion_clear H1.
  left; left; assumption.
 right; assumption.
Qed.

Lemma leEq_minlist : forall x l,
 0 < length l -> (forall y, member y l -> x [<=] y) -> x [<=] minlist l.
Proof.
 simple induction l.
  simpl in |- *; intros; exfalso; inversion H.
 clear l.
 do 3 intro.
 clear H; induction  l as [| a0 l Hrecl].
  simpl in |- *; intros.
  apply H0; right; algebra.
 generalize l a0 Hrecl; clear Hrecl l a0.
 intros l b; intros.
 eapply leEq_wdr.
  2: apply minlist_aux.
 astepr (Min b (minlist (cons a l))).
 apply leEq_Min.
  apply H0; left; right; algebra.
 apply Hrecl.
  simpl in |- *; auto with arith.
 intros y H1; apply H0.
 inversion_clear H1.
  left; left; assumption.
 right; assumption.
Qed.

End Lists.


(** * XOR instruction *)
Require Import x86proved.x86.instrrules.core.
Import x86.instrrules.core.instrruleconfig.

(** ** Generic XOR *)
Lemma XOR_rule s (ds:DstSrc s) (v1: VWORD s) :
   |-- specAtDstSrc ds (fun D v2 =>
       basic (D v1 ** OSZCP?)
             (BOP _ OP_XOR ds)
             (let v := xorB v1 v2 in
              D v ** OSZCP false (msb v) (v == #0) false (lsb v))).
Proof. do_instrrule_triple. Qed.

(** We make this rule an instance of the typeclass, and leave
    unfolding things like [specAtDstSrc] to the getter tactic
    [get_instrrule_of]. *)
Global Instance: forall s (ds : DstSrc s), instrrule (BOP s OP_XOR ds) | 2 := @XOR_rule.

Lemma XOR_RR_rule s (r1 r2:VReg s) v1 (v2:VWORD s):
  |-- basic (r1 ~= v1 ** r2 ~= v2 ** OSZCP?) (XOR r1, r2)
            (r1 ~= (xorB v1 v2) ** r2 ~= v2 ** OSZCP false (msb (xorB v1 v2))
                            (xorB v1 v2 == #0) false (lsb (xorB v1 v2))).
Proof. destruct s; basic apply *. Qed.

Lemma XOR_RM_rule (pd:DWORD) (r1 r2:VReg OpSize4) (v1 v2:DWORD) (offset:nat) v :
  xorB v1 v2 = v ->
  |-- basic (r1~=v1 ** r2 ~= pd ** pd +# offset :-> v2 ** OSZCP?)
            (XOR r1, [r2 + offset])
            (r1~=v ** r2 ~= pd ** pd +# offset :-> v2 **
             OSZCP false (msb v) (v == #0) false (lsb v)).
Proof. move => ?; subst. basic apply *. Qed.

(** We make the more specific rule have a higher priority *)
Global Instance: forall (r1 r2 : Reg) (offset : nat), instrrule (XOR r1, [r2 + offset]) | 0
  := fun r1 r2 offset pd v1 v2 => @XOR_RM_rule pd r1 r2 v1 v2 offset _ (refl_equal _).
Global Instance: forall d (r1 r2 : VReg d), instrrule (BOP d OP_XOR (DstSrcRR d r1 r2)) | 1
  := @XOR_RR_rule.

Corollary XOR_RM_ruleNoFlags (pd:DWORD) (r1 r2:VReg OpSize4) v1 (v2:DWORD) (offset:nat):
  |-- basic (r1~=v1) (XOR r1, [r2 + offset]) (r1~=xorB v1 v2)
             @ (r2 ~= pd ** pd +# offset :-> v2 ** OSZCP?).
Proof. autorewrite with push_at. basic apply *. Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Finite sets of integer intervals *)

Require Import Coqlib.

Module ISet.

(** "Raw", non-dependent implementation.  A set of intervals is a
  list of nonempty semi-open intervals [(lo, hi)],
  sorted in increasing order of the low bound,
  and with no overlap nor adjacency between elements.
  In particular, if the list contains [(lo1, hi1)] followed by [(lo2, hi2)],
  we have [lo1 < hi1 < lo2 < hi2]. *)

Module R.

Inductive t : Type := Nil | Cons (lo hi: Z) (tl: t).

Fixpoint In (x: Z) (s: t) :=
  match s with
  | Nil => False
  | Cons l h s' => l <= x < h \/ In x s'
  end.

Inductive ok: t -> Prop :=
  | ok_nil: ok Nil
  | ok_cons: forall l h s
      (BOUNDS: l < h)
      (BELOW: forall x, In x s -> h < x)
      (OK: ok s),
      ok (Cons l h s).

Fixpoint mem (x: Z) (s: t) : bool :=
  match s with
  | Nil => false
  | Cons l h s' => if zlt x h then zle l x else mem x s'
  end.

Lemma mem_In:
  forall x s, ok s -> (mem x s = true <-> In x s).
Proof.
  induction 1; simpl.
- intuition congruence.
- destruct (zlt x h).
+ destruct (zle l x); simpl.
  * tauto.
  * split; intros. congruence.
    exfalso. destruct H0. omega. exploit BELOW; eauto. omega.
+ rewrite IHok. intuition.
Qed.

Fixpoint contains (L H: Z) (s: t) : bool :=
  match s with
  | Nil => false
  | Cons l h s' => (zle H h && zle l L) || contains L H s'
  end.

Lemma contains_In:
  forall l0 h0, l0 < h0 -> forall s, ok s ->
  (contains l0 h0 s = true <-> (forall x, l0 <= x < h0 -> In x s)).
Proof.
  induction 2; simpl.
- intuition. elim (H0 l0); omega.
- destruct (zle h0 h); simpl.
  destruct (zle l l0); simpl.
  intuition.
  rewrite IHok. intuition. destruct (H3 x); auto. exfalso.
  destruct (H3 l0). omega. omega. exploit BELOW; eauto. omega.
  rewrite IHok. intuition. destruct (H3 x); auto. exfalso.
  destruct (H3 h). omega. omega. exploit BELOW; eauto. omega.
Qed.

Fixpoint add (L H: Z) (s: t) {struct s} : t :=
  match s with
  | Nil => Cons L H Nil
  | Cons l h s' =>
      if zlt h L then Cons l h (add L H s')
      else if zlt H l then Cons L H s
      else add (Z.min l L) (Z.max h H) s'
  end.

Lemma In_add:
  forall x s, ok s -> forall l0 h0, (In x (add l0 h0 s) <-> l0 <= x < h0 \/ In x s).
Proof.
  induction 1; simpl; intros.
  tauto.
  destruct (zlt h l0).
  simpl. rewrite IHok. tauto.
  destruct (zlt h0 l).
  simpl. tauto.
  rewrite IHok. intuition.
  assert (l0 <= x < h0 \/ l <= x < h) by xomega. tauto.
  left; xomega.
  left; xomega.
Qed.

Lemma add_ok:
  forall s, ok s -> forall l0 h0, l0 < h0 -> ok (add l0 h0 s).
Proof.
  induction 1; simpl; intros.
  constructor. auto. intros. inv H0. constructor.
  destruct (zlt h l0).
  constructor; auto. intros. rewrite In_add in H1; auto.
  destruct H1. omega. auto.
  destruct (zlt h0 l).
  constructor. auto. simpl; intros. destruct H1. omega. exploit BELOW; eauto. omega.
  constructor. omega. auto. auto.
  apply IHok. xomega.
Qed.

Fixpoint remove (L H: Z) (s: t) {struct s} : t :=
  match s with
  | Nil => Nil
  | Cons l h s' =>
      if zlt h L then Cons l h (remove L H s')
      else if zlt H l then s
      else if zlt l L then
        if zlt H h then Cons l L (Cons H h s') else Cons l L (remove L H s')
      else
        if zlt H h then Cons H h s' else remove L H s'
  end.

Lemma In_remove:
  forall x l0 h0 s, ok s ->
  (In x (remove l0 h0 s) <-> ~(l0 <= x < h0) /\ In x s).
Proof.
  induction 1; simpl.
  tauto.
  destruct (zlt h l0).
  simpl. rewrite IHok. intuition omega.
  destruct (zlt h0 l).
  simpl. intuition. exploit BELOW; eauto. omega.
  destruct (zlt l l0).
  destruct (zlt h0 h); simpl. clear IHok. split.
  intros [A | [A | A]].
  split. omega. left; omega.
  split. omega. left; omega.
  split. exploit BELOW; eauto. omega. auto.
  intros [A [B | B]].
  destruct (zlt x l0). left; omega. right; left; omega.
  auto.
  intuition omega.
  destruct (zlt h0 h); simpl.
  intuition. exploit BELOW; eauto. omega.
  rewrite IHok. intuition. omegaContradiction.
Qed.

Lemma remove_ok:
  forall l0 h0, l0 < h0 -> forall s, ok s -> ok (remove l0 h0 s).
Proof.
  induction 2; simpl.
  constructor.
  destruct (zlt h l0).
  constructor; auto. intros; apply BELOW. rewrite In_remove in H1; tauto.
  destruct (zlt h0 l).
  constructor; auto.
  destruct (zlt l l0).
  destruct (zlt h0 h).
  constructor. omega. intros. inv H1. omega. exploit BELOW; eauto. omega.
  constructor. omega. auto. auto.
  constructor; auto. intros. rewrite In_remove in H1 by auto. destruct H1. exploit BELOW; eauto. omega.
  destruct (zlt h0 h).
  constructor; auto.
  auto.
Qed.

Fixpoint inter (s1 s2: t) {struct s1} : t :=
  let fix intr (s2: t) : t :=
    match s1, s2 with
    | Nil, _ => Nil
    | _, Nil => Nil
    | Cons l1 h1 s1', Cons l2 h2 s2' =>
        if zle h1 l2 then inter s1' s2
        else if zle h2 l1 then intr s2'
        else if zle l1 l2 then
          if zle h2 h1 then Cons l2 h2 (intr s2') else Cons l2 h1 (inter s1' s2)
        else
          if zle h1 h2 then Cons l1 h1 (inter s1' s2) else Cons l1 h2 (intr s2')
    end
  in intr s2.

Lemma In_inter:
  forall x s1, ok s1 -> forall s2, ok s2 ->
  (In x (inter s1 s2) <-> In x s1 /\ In x s2).
Proof.
  induction 1.
  simpl. induction 1; simpl. tauto. tauto.
  assert (ok (Cons l h s)) by (constructor; auto).
  induction 1; simpl.
  tauto.
  assert (ok (Cons l0 h0 s0)) by (constructor; auto).
  destruct (zle h l0).
  rewrite IHok; auto. simpl. intuition. omegaContradiction.
  exploit BELOW0; eauto. intros. omegaContradiction.
  destruct (zle h0 l).
  simpl in IHok0; rewrite IHok0. intuition. omegaContradiction.
  exploit BELOW; eauto. intros; omegaContradiction.
  destruct (zle l l0).
  destruct (zle h0 h).
  simpl. simpl in IHok0; rewrite IHok0. intuition.
  simpl. rewrite IHok; auto. simpl. intuition.  exploit BELOW0; eauto. intros; omegaContradiction.
  destruct (zle h h0).
  simpl. rewrite IHok; auto. simpl. intuition.
  simpl. simpl in IHok0; rewrite IHok0. intuition.
  exploit BELOW; eauto. intros; omegaContradiction.
Qed.

Lemma inter_ok:
  forall s1, ok s1 -> forall s2, ok s2 -> ok (inter s1 s2).
Proof.
  induction 1.
  intros; simpl. destruct s2; constructor.
  assert (ok (Cons l h s)). constructor; auto.
  induction 1; simpl.
  constructor.
  assert (ok (Cons l0 h0 s0)). constructor; auto.
  destruct (zle h l0).
  auto.
  destruct (zle h0 l).
  auto.
  destruct (zle l l0).
  destruct (zle h0 h).
  constructor; auto. intros.
  assert (In x (inter (Cons l h s) s0)) by exact H3.
  rewrite In_inter in H4; auto. apply BELOW0. tauto.
  constructor. omega. intros. rewrite In_inter in H3; auto. apply BELOW. tauto.
  auto.
  destruct (zle h h0).
  constructor. omega. intros. rewrite In_inter in H3; auto. apply BELOW. tauto.
  auto.
  constructor. omega. intros.
  assert (In x (inter (Cons l h s) s0)) by exact H3.
  rewrite In_inter in H4; auto. apply BELOW0. tauto.
  auto.
Qed.

Fixpoint union (s1 s2: t) : t :=
  match s1, s2 with
  | Nil, _ => s2
  | _, Nil => s1
  | Cons l1 h1 s1', Cons l2 h2 s2' => add l1 h1 (add l2 h2 (union s1' s2'))
  end.

Lemma In_ok_union:
  forall s1, ok s1 -> forall s2, ok s2 ->
  ok (union s1 s2) /\ (forall x, In x s1 \/ In x s2 <-> In x (union s1 s2)).
Proof.
  induction 1; destruct 1; simpl.
  split. constructor. tauto.
  split. constructor; auto. tauto.
  split. constructor; auto. tauto.
  destruct (IHok s0) as [A B]; auto.
  split. apply add_ok; auto. apply add_ok; auto.
  intros. rewrite In_add. rewrite In_add. rewrite <- B. tauto. auto. apply add_ok; auto.
Qed.

Fixpoint beq (s1 s2: t) : bool :=
  match s1, s2 with
  | Nil, Nil => true
  | Cons l1 h1 t1, Cons l2 h2 t2 => zeq l1 l2 && zeq h1 h2 && beq t1 t2
  | _, _ => false
  end.

Lemma beq_spec:
  forall s1, ok s1 -> forall s2, ok s2 ->
  (beq s1 s2 = true <-> (forall x, In x s1 <-> In x s2)).
Proof.
  induction 1; destruct 1; simpl.
- tauto.
- split; intros. discriminate. exfalso. apply (H0 l). left; omega.
- split; intros. discriminate. exfalso. apply (H0 l). left; omega.
- split; intros.
+ InvBooleans. subst. rewrite IHok in H3 by auto. rewrite H3. tauto.
+ destruct (zeq l l0). destruct (zeq h h0). simpl. subst.
  apply IHok. auto. intros; split; intros.
  destruct (proj1 (H1 x)); auto. exfalso. exploit BELOW; eauto. omega.
  destruct (proj2 (H1 x)); auto. exfalso. exploit BELOW0; eauto. omega.
  exfalso. subst l0. destruct (zlt h h0).
  destruct (proj2 (H1 h)). left; omega. omega. exploit BELOW; eauto. omega.
  destruct (proj1 (H1 h0)). left; omega. omega. exploit BELOW0; eauto. omega.
  exfalso. destruct (zlt l l0).
  destruct (proj1 (H1 l)). left; omega. omega. exploit BELOW0; eauto. omega.
  destruct (proj2 (H1 l0)). left; omega. omega. exploit BELOW; eauto. omega.
Qed.

End R.

(** Exported interface, wrapping the [ok] invariant in a dependent type. *)

Definition t := { r: R.t | R.ok r }.

Program Definition In (x: Z) (s: t) := R.In x s.

Program Definition empty : t := R.Nil.
Next Obligation. constructor. Qed.

Theorem In_empty: forall x, ~(In x empty).
Proof.
  unfold In; intros; simpl. tauto.
Qed.

Program Definition interval (l h: Z) : t :=
  if zlt l h then R.Cons l h R.Nil else R.Nil.
Next Obligation.
  constructor; auto. simpl; tauto. constructor.
Qed.
Next Obligation.
  constructor.
Qed.

Theorem In_interval: forall x l h, In x (interval l h) <-> l <= x < h.
Proof.
  intros. unfold In, interval; destruct (zlt l h); simpl.
  intuition.
  intuition.
Qed.

Program Definition add (l h: Z) (s: t) : t :=
  if zlt l h then R.add l h s else s.
Next Obligation.
  apply R.add_ok. apply proj2_sig. auto.
Qed.

Theorem In_add: forall x l h s, In x (add l h s) <-> l <= x < h \/ In x s.
Proof.
  unfold add, In; intros.
  destruct (zlt l h).
  simpl. apply R.In_add. apply proj2_sig.
  intuition. omegaContradiction.
Qed.

Program Definition remove (l h: Z) (s: t) : t :=
  if zlt l h then R.remove l h s else s.
Next Obligation.
  apply R.remove_ok. auto. apply proj2_sig.
Qed.

Theorem In_remove: forall x l h s, In x (remove l h s) <-> ~(l <= x < h) /\ In x s.
Proof.
  unfold remove, In; intros.
  destruct (zlt l h).
  simpl. apply R.In_remove. apply proj2_sig.
  intuition.
Qed.

Program Definition inter (s1 s2: t) : t := R.inter s1 s2.
Next Obligation. apply R.inter_ok; apply proj2_sig. Qed.

Theorem In_inter: forall x s1 s2, In x (inter s1 s2) <-> In x s1 /\ In x s2.
Proof.
  unfold inter, In; intros; simpl. apply R.In_inter; apply proj2_sig.
Qed.

Program Definition union (s1 s2: t) : t := R.union s1 s2.
Next Obligation.
  destruct (R.In_ok_union _ (proj2_sig s1) _ (proj2_sig s2)). auto.
Qed.

Theorem In_union: forall x s1 s2, In x (union s1 s2) <-> In x s1 \/ In x s2.
Proof.
  unfold union, In; intros; simpl.
  destruct (R.In_ok_union _ (proj2_sig s1) _ (proj2_sig s2)).
  generalize (H0 x); tauto.
Qed.

Program Definition mem (x: Z) (s: t) := R.mem x s.

Theorem mem_spec: forall x s, mem x s = true <-> In x s.
Proof.
  unfold mem, In; intros. apply R.mem_In. apply proj2_sig.
Qed.

Program Definition contains (l h: Z) (s: t) :=
  if zlt l h then R.contains l h s else true.

Theorem contains_spec:
  forall l h s, contains l h s = true <-> (forall x, l <= x < h -> In x s).
Proof.
  unfold contains, In; intros. destruct (zlt l h).
  apply R.contains_In. auto. apply proj2_sig.
  split; intros. omegaContradiction. auto.
Qed.

Program Definition beq (s1 s2: t) : bool := R.beq s1 s2.

Theorem beq_spec:
  forall s1 s2, beq s1 s2 = true <-> (forall x, In x s1 <-> In x s2).
Proof.
  unfold mem, In; intros. apply R.beq_spec; apply proj2_sig.
Qed.

End ISet.


Generalizable All Variables.
Set Implicit Arguments.

Require Import Coq.Lists.List
        Coq.Strings.String
        Coq.Arith.Arith
        Fiat.Common.ilist
        Fiat.Common.ilist3.

Section i3list2.

  (* Lists of elements whose types depend on an indexing set (CPDT's hlists).
     These lists are a convenient way to implement finite maps
     whose elements depend on their keys. The data structures used
     by our ADT notations uses these to implement notation-friendly
     method lookups.  *)

  Import Vectors.Vector.VectorNotations.

  Context {A : Type}. (* The indexing type. *)
  Context {B : A -> Type}. (* The type of indexed elements. *)
  Variable C : forall a, B a ->  Type. (* The type of doubly-indexed elements. *)

  Fixpoint i3list2 {n}
           {l : Vector.t A n}
    : ilist3 (B := B) l -> Type :=
    match l return ilist3 (B := B) l -> Type with
    | [] => fun _ => unit
    | a :: l' => fun il => @prim_prod (C (ilist3_hd il))
                                      (i3list2 (ilist3_tl il))
    end.

  Definition i3cons2
             {a : A}
             {n}
             {l : Vector.t A n}
             {b : B a}
             {il : ilist3 l}
             (c : C b)
             (il3 : i3list2 il)
  : i3list2 (icons3 b il)
    := {| prim_fst := c; prim_snd := il3 |}.

  Definition i3nil2 : i3list2 inil3 := tt.

  (* Get the car of an i3list. *)
  Definition i3list2_hd {n}
             (As : Vector.t A n)
             (Bs : ilist3 As)
             (i3l : i3list2 Bs) :
    match As return forall Bs : ilist3 As, i3list2 Bs -> Type with
    | a :: As' => fun Bs i3l => C (ilist3_hd Bs)
      | [] => fun _ _ => unit
    end Bs i3l :=
    match As as As' return
          forall Bs i3l,
          match As' return forall Bs : ilist3 As', i3list2 Bs -> Type with
          | a :: As' => fun Bs i3l => C (ilist3_hd Bs)
          | [] => fun _ _ => unit
          end Bs i3l with
    | [] => fun _ _ => tt
    | a :: As' => fun Bs il => prim_fst il
    end Bs i3l.

  (* Get the cdr of an i3list. *)
  Definition i3list2_tl {n}
             (As : Vector.t A n)
             (Bs : ilist3 As)
             (i3l : i3list2 Bs) :
    match As return forall Bs : ilist3 As, i3list2 Bs -> Type with
    | a :: As' => fun Bs i3l => i3list2 (ilist3_tl Bs)
    | [] => fun _ _ => unit
    end Bs i3l :=
    match As as As' return
          forall Bs i3l,
          match As' return forall Bs : ilist3 As', i3list2 Bs -> Type with
          | a :: As' => fun Bs i3l => i3list2 (ilist3_tl Bs)
          | [] => fun _ _ => unit
          end Bs i3l with
    | [] => fun _ _ => tt
    | a :: As' => fun Bs il => prim_snd il
    end Bs i3l.

  Fixpoint i3th2
           {m : nat}
           {As : Vector.t A m}
           {Bs : ilist3 As}
           (i3l : i3list2 Bs)
           (n : Fin.t m)
           {struct n}
    : C (ith3 Bs n) :=
    match n in Fin.t m return
          forall (As : Vector.t A m)
                 (Bs : ilist3 As),
            i3list2 Bs
            -> C (ith3 Bs n) with
    | Fin.F1 k =>
      fun As Bs i3l =>
        Vector.caseS (fun n As =>
                        forall (Bs : ilist3 As), i3list2 Bs
                                   -> C (ith3 Bs (@Fin.F1 n)))
                     (fun a' n' As' (Bs' : ilist3 (a' :: As')) i3l' => prim_fst i3l' ) As Bs i3l
    | Fin.FS k n'' =>
      fun As Bs i3l =>
        Vector_caseS' Fin.t
                      (fun n' As i =>
                        forall (Bs'' : ilist3 As),
                          i3list2 Bs''
                          -> C (ith3 Bs'' (@Fin.FS n' i)))
                     (fun a' n' As' n'' (Bs' : ilist3 (a' :: As')) i3l' => i3th2 (prim_snd i3l') n'')
                     As n'' Bs i3l
    end As Bs i3l.

End i3list2.

Fixpoint i3map2
         {A : Type}
         {B : A -> Type}
         {C C' : forall a, B a ->  Type}
         (f : forall a b, C a b -> C' a b)
         {m : nat}
         {As : Vector.t A m}
         {Bs : ilist3 As}
         (i3l : i3list2 C Bs)
  : i3list2 C' Bs :=
  match As return
        forall (Bs : ilist3 As),
          i3list2 C Bs
          -> i3list2 C' Bs with
  | Vector.nil => fun _ _ => tt
  | Vector.cons a _ l' => fun Bs Cs => {| prim_fst := f a _ (prim_fst Cs);
                                          prim_snd := i3map2 f (prim_snd Cs) |}
  end Bs i3l.

Lemma i3th2_i3map2 {A : Type}
      {B : A -> Type}
      {C C' : forall a, B a ->  Type}
  : forall (f : forall a b, C a b -> C' a b)
           {m : nat}
           (n : Fin.t m)
           {As : Vector.t A m}
           {Bs : ilist3 As}
           (i3l : i3list2 C Bs),
    f _ _ (i3th2 C i3l n) = i3th2 C' (i3map2 f i3l) n.
Proof.
  induction n; intro.
  - eapply Vector.caseS with (v := As); intros; simpl in *; destruct i3l; reflexivity.
  - revert n0 IHn.
    pattern n, As.
    match goal with
      |- ?P n As =>
      simpl; eapply (@Vector.rectS _ P); intros
    end.
    + inversion n0.
    + eapply IHn.
Qed.

Arguments i3cons2 [_ _ _ _ _ _ _ _] _ _.
Arguments i3nil2 {_ _ _}.
Arguments i3th2 [_ _ _ _ _ _] _ _.


From Equations Require Import Equations.
(* Assuming UIP *)
From Coq.Logic Require Import Eqdep.

Section FreeMonad.

  Variable S : Type.
  Variable P : S -> Type.

  Inductive FreeF A : Type :=
  | retFree : A -> FreeF A
  | opr     : forall s, (P s -> FreeF A) -> FreeF A.

  Derive Signature for Relation_Operators.clos_trans.
  Derive NoConfusion Subterm for FreeF.

End FreeMonad.