(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice.
From mathcomp Require Import fintype tuple div path bigop prime finset fingroup.
From mathcomp Require Import finfun perm.

(** * Additional lemmas about ssrnat, seq, eqType, finType, finset, tuple, perm *)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Notation "t '\_' i" := (tnth t i) (at level 9) : tuple_ext_scope.

Lemma addb_tri_ine a b c : a (+) b <= (a (+) c) + (c (+) b).
Proof. move: a b c; by case; case; case. Qed.

Section ssrnat_ext.

Lemma nat_of_pos_not_0 : forall p, nat_of_pos p <> O.
Proof.
elim => // p H.
contradict H.
rewrite /= NatTrec.doubleE in H.
apply/eqP; rewrite -double_eq0; by apply/eqP.
Qed.

Lemma nat_of_pos_inj : forall i j, nat_of_pos i = nat_of_pos j -> i = j.
Proof.
elim=> [i Hi [] | i Hi [] | j /=].
- move=> j /= [] /eqP.
  by rewrite !NatTrec.doubleE -!muln2 eqn_mul2r /= => /eqP/Hi ->.
- move=> j /=.
  rewrite !NatTrec.doubleE => Hj.
  have absurd : odd ((nat_of_pos j).*2) by rewrite -Hj /= odd_double.
  by rewrite odd_double in absurd.
- rewrite /= NatTrec.doubleE.
  case => Habsurd.
  exfalso.
  move: (@nat_of_pos_not_0 i).
  by destruct (nat_of_pos i).
- move=> j /=.
  rewrite !NatTrec.doubleE => Hj.
  have absurd : odd ((nat_of_pos i).*2) by rewrite Hj /= odd_double.
  by rewrite odd_double in absurd.
- move=> j /= /eqP.
  by rewrite !NatTrec.doubleE -!muln2 eqn_mul2r /= => /eqP/Hi ->.
- rewrite /= NatTrec.doubleE => absurd.
  exfalso.
  move: (@nat_of_pos_not_0 i).
  by destruct (nat_of_pos i).
  destruct j => //=;
    rewrite NatTrec.doubleE => absurd ;
      exfalso ;
        move: (@nat_of_pos_not_0 j) => H' ;
          by destruct (nat_of_pos j).
Qed.

Lemma bin_of_nat_inj : forall a b, bin_of_nat a = bin_of_nat b -> a = b.
Proof.
move=> a b X.
have : nat_of_bin (bin_of_nat a) = nat_of_bin (bin_of_nat b) by rewrite X.
by rewrite 2!bin_of_natK.
Qed.

Lemma bin_of_nat_nat_of_pos_not_0 : forall i, bin_of_nat (nat_of_pos i) <> 0%num.
Proof.
elim=> // a Ha /=.
rewrite NatTrec.doubleE.
contradict Ha.
by destruct (nat_of_pos a).
Qed.

Lemma bin_of_nat_expn2 m : bin_of_nat (expn 2 m.+1) = BinNat.N.mul 2 (bin_of_nat (expn 2 m)).
Proof.
set x := BinNat.N.mul _ _.
by rewrite -(nat_of_binK x) {}/x nat_of_mul_bin bin_of_natK expnS.
Qed.

Lemma Nto_natE x : BinNat.N.to_nat x = nat_of_bin x.
Proof.
case x => //=.
elim => [ | | //] p Hp /=.
by rewrite Pnat.Pos2Nat.inj_xI NatTrec.trecE Hp -mul2n.
by rewrite Pnat.Pos2Nat.inj_xO NatTrec.trecE Hp -mul2n.
Qed.

Lemma BinPos_nat_of_P_nat_of_pos : forall i, BinPos.nat_of_P i = nat_of_pos i.
Proof.
elim=> // i /= Hi.
- by rewrite Pnat.nat_of_P_xI NatTrec.doubleE Hi multE mul2n.
- by rewrite Pnat.nat_of_P_xO NatTrec.doubleE Hi multE mul2n.
Qed.

Lemma nat_of_posK k : bin_of_nat (nat_of_pos k) = BinNat.Npos k.
Proof. by rewrite -(nat_of_binK (BinNat.Npos k)). Qed.

End ssrnat_ext.

Section seq_ext.

Variables A B : Type.
Implicit Types l : seq A.

Lemma zip_swap : forall l (k : seq B),
  zip l k = map (fun x => (x.2, x.1)) (zip k l).
Proof. elim => [ [] // | h t IH [|hd tl] //=]; by rewrite IH. Qed.

Lemma sumn_big_addn s : sumn s = \sum_ ( i <- s ) i.
Proof.
elim s => [|a l HR] /= ; first by rewrite big_nil.
by rewrite -cat1s big_cat /= big_seq1 HR.
Qed.

Lemma filter_flatten T u (s : seq (seq T)) : filter u (flatten s) = flatten (map (filter u) s).
Proof.
elim s => // hd tl HR.
rewrite -cat1s map_cat !flatten_cat filter_cat -HR.
f_equal ; by rewrite /flatten /= 2!cats0.
Qed.

Lemma drop_take_iota a b c : a <= b <= c ->
  drop a (take b (iota 0 c)) = filter (fun n => a <= n < b) (iota 0 c).
Proof.
move=> /andP [Hab Hbc].
set f := fun n => a <= n < b.
rewrite -(subnKC Hbc) iota_add take_cat size_iota subnn take0 add0n (ltnn b) cats0 filter_cat.
rewrite (_ : filter f (iota b (c-b)) = [::]) ; last first.
  apply/eqP/negPn ; rewrite -has_filter ; apply/hasPn => l.
  rewrite mem_iota (subnKC Hbc) /f negb_and => /andP [H _].
  by rewrite -leqNgt H orbT.
rewrite cats0 -(subnKC Hab) iota_add drop_cat size_iota subnn drop0 add0n (ltnn a) filter_cat.
rewrite (_ : filter f (iota 0 a) = [::]) ; last first.
  apply/eqP/negPn ; rewrite -has_filter ; apply/hasPn => l.
  rewrite mem_iota /f negb_and add0n => /andP [_ H].
  by rewrite -ltnNge H orTb.
rewrite cat0s.
symmetry ; apply/all_filterP/allP.
move=> l.
by rewrite mem_iota /f (subnKC Hab).
Qed.

Lemma take_take : forall (n m :nat) l, take n (take (n + m) l) = take n l.
Proof.
elim=> [* | n0 IH m0 z0].
- by rewrite !take0.
- destruct z0 => //=; by rewrite IH.
Qed.

Lemma take_drop_take : forall m n l,
  m + n <= size l -> take n (drop m (take (m + n) l)) = (drop m (take (m + n) l)).
Proof.
elim=> [n0 z Hsz | m IH n1 [|hd tl] //=].
- rewrite drop0 add0n take_oversize // size_take.
  case: ifP => // {Hsz}.
  move/negbT; by rewrite -leqNgt.
rewrite addnC addnS => ?; by rewrite IH // addnC.
Qed.

Lemma zip_mask : forall bs l (k : seq B),
  zip (mask bs l) (mask bs k) = mask bs (zip l k).
Proof.
elim=> // h t IH [|a1 a2] [|b1 b2] //=.
- destruct h => //=; by case: mask.
- destruct h => //=; by case: mask.
- destruct h => /=; by rewrite IH.
Qed.

Lemma nseq_add n (a : A) m : nseq (n + m) a = nseq n a ++ nseq m a.
Proof. rewrite cat_nseq; elim: n => // n ih; by rewrite addSn /= ih. Qed.

Variable a : A.

Lemma map_nth_iota_id l : map (nth a l) (iota 0 (size l)) = l.
Proof.
apply: (@eq_from_nth _ a); first by rewrite size_map size_iota.
rewrite size_map; move=> i; rewrite size_iota => Hi.
by rewrite (@nth_map _ 0 _ _ _ _ _) // ?size_iota // nth_iota.
Qed.

Lemma nseq_S : forall n, nseq n.+1 a = rcons (nseq n a) a.
Proof. by elim=> //= n <-. Qed.

Lemma rev_nseq : forall n, rev (nseq n a) = nseq n a.
Proof. elim => // n ih; by rewrite /= rev_cons ih -nseq_S. Qed.

Lemma nseq_cat l l' n : l ++ l' = nseq n a -> l' = nseq (n - size l) a.
Proof.
move=> H2; move/(congr1 (drop (size l))) : (H2).
rewrite drop_cat ltnn subnn drop0 => ->.
move: (nseq_add (size l) a (n - size l)).
rewrite subnKC; last by rewrite -(size_nseq n a) -H2 size_cat leq_addr.
move=> ->; by rewrite drop_cat size_nseq ltnn subnn drop0.
Qed.

End seq_ext.

Section Pad.

Variables (A : Type) (a : A).
Implicit Types s t : seq A.

Definition pad_seq s n :=
  if size s <= n then s ++ nseq (n - size s) a else take n s.

Lemma size_pad_seq s n : size (pad_seq s n) = n.
Proof.
rewrite /pad_seq; case: ifPn; last by rewrite -ltnNge size_take => ->.
by rewrite size_cat size_nseq => /subnKC.
Qed.

Lemma pad_seq_size s n : size s = n -> pad_seq s n = s.
Proof. by rewrite /pad_seq => ->; rewrite leqnn subnn cats0. Qed.

Definition pad_seqL s n :=
  if size s <= n then nseq (n - size s) a ++ s else take n s.

Lemma pad_seqL_inj n s t : size s = n -> size t = n ->
  pad_seqL s n = pad_seqL t n -> s = t.
Proof.
elim: n s t => [[] // [] // | ] n IH [|a' ta] // [|b tb] // [Ha] [Hb].
by rewrite /pad_seqL /= Ha Hb ltnS leqnn subnn.
Qed.

Lemma size_pad_seqL n s : size (pad_seqL s n) = n.
Proof.
rewrite /pad_seqL; case: ifPn; last by rewrite -ltnNge size_take => ->.
by rewrite size_cat size_nseq => /subnK.
Qed.

End Pad.

Section seq_eqType_ext.

Variables A B : eqType.

Lemma in_cat (s : seq A) x : x \in s -> exists hd tl, s = hd ++ x :: tl.
Proof.
elim: s => // h t IH; rewrite in_cons; case/orP.
- move/eqP => ?; subst h.
  by exists [::], t.
- case/IH => h1 [] t1 ht1.
  exists (h ::h1), t1 => /=.
  congruence.
Qed.

Lemma take_index (a : A) l : a \notin take (index a l) l.
Proof.
elim: l => // h t IH /=; case: ifPn => //.
by rewrite inE negb_or eq_sym IH andbT.
Qed.

Lemma uniq_take i (l : seq A) :  i < size l -> uniq l -> uniq (take i l).
Proof.
elim: i l => [l _ _ |i IH [| h t] //=]; first by rewrite take0.
rewrite ltnS => nt /andP[ht ut].
rewrite (IH _ nt ut) andbT; apply: contra ht; exact: mem_take.
Qed.

Lemma nth_of_sorted (l : seq nat) : sorted leq l -> forall i j,
  i <= j < size l -> nth O l i <= nth O l j.
Proof.
elim: l => [/= _ i j|h t IH Ht]; first by rewrite ltn0 andbF.
move/pathP : (Ht) => H; move/path_sorted in Ht.
case => [/= [// | j /=] | i /= [// | j]].
  rewrite ltnS => jt.
  apply: leq_trans; [|by apply: (IH Ht O); rewrite leq0n jt].
  apply: leq_trans; last by apply H; rewrite (leq_ltn_trans _ jt).
  done.
rewrite !ltnS => ijt.
eapply leq_trans; first by apply: (IH _ _ j).
done.
Qed.

Lemma sorted_of_nth (r : rel A) s (r_trans : transitive r) (r_sorted : sorted r s) :
  forall x0 a b, a < b < size s -> r (nth x0 s a) (nth x0 s b).
Proof.
move=> a0 a b /= /andP [Hab Hbs].
set f := nth a0 s.
have Has : a < size s by exact/(leq_ltn_trans _ Hbs)/ltnW.
have H : subseq [:: f a ; f b] s.
  rewrite -(map_nth_iota_id a0 s) (_ : [:: f a; f b] = map f [:: a ; b]) //.
  apply: map_subseq.
  rewrite -(subnK Has) addnC iota_add add0n (_ : [:: a; b] = [::a] ++ [::b]) //.
  apply cat_subseq; rewrite sub1seq mem_iota.
  - by rewrite add0n leq0n ltnSn.
  - by rewrite Hab subnKC.
by case/andP : (subseq_sorted r_trans H r_sorted).
Qed.

Lemma sorted_cat (l k : seq A) (Rel : @rel A) :
  sorted Rel l -> sorted Rel k ->
  (forall a, a \in l -> forall b, b \in k -> Rel a b) ->
  sorted Rel (l ++ k).
Proof.
move=> Hl Hk H.
destruct l => //.
rewrite /sorted /= cat_path.
rewrite /sorted in Hl.
apply/andP; split => //.
destruct k => //.
rewrite /sorted in Hk.
rewrite /= Hk andbC /=.
apply H.
by rewrite mem_last.
by rewrite in_cons eqxx.
Qed.

Lemma sorted_is_flattened leT (Htrans : transitive leT)
  (Hanti : antisymmetric leT) (Hrefl : reflexive leT) :
  forall n (l k : seq A), n = size l -> uniq l -> sorted leT l ->
  sorted leT k -> {subset k <= l} ->
  k = flatten (map (fun elt => filter (pred1 elt) k) l).
Proof.
elim=> [[]// k _ _ _ Hk H|] /=.
  destruct k => //.
  exfalso.
  move: (H s).
  by rewrite !inE eqxx orTb in_nil => /(_ isT).
move=> n0 IH [|hd tl] // v [lst_sz] lst_uniq lst_sorted v_sorted Hincl.
have X1 : v = filter (pred1 hd) v ++ filter (predC (pred1 hd)) v.
  apply eq_sorted with leT => //.
  - apply: sorted_cat.
    + by apply sorted_filter.
    + by apply sorted_filter.
    + move=> a.
      rewrite mem_filter => /andP[/= /eqP ?]; subst hd => av b.
      rewrite mem_filter => /andP[/= ba /Hincl].
      rewrite inE => /orP[|].
      * move/eqP => ?; by subst b.
      * move=> btl.
        rewrite /sorted in lst_sorted.
        move: (@subseq_order_path _ _ (Htrans) a [:: b] tl).
        rewrite /= andbC /=.
        apply => //; by rewrite sub1seq.
  - rewrite perm_eq_sym; by apply perm_eqlE, perm_filterC.
rewrite {1}X1 {X1} /=.
congr (_ ++ _).
move: lst_uniq => /= /andP[hdtl tl_uniq].
rewrite (IH tl (filter (predC (pred1 hd)) v) lst_sz tl_uniq).
- congr flatten.
  apply eq_in_map => i i_tl.
  rewrite -filter_predI.
  apply eq_in_filter => j j_v /=.
  case/boolP: (j == i) => ij //=.
  apply/negP => /eqP ?; subst j.
  move/eqP : ij => ?; subst i.
  by rewrite i_tl in hdtl.
- destruct tl => //=.
  by case/andP : lst_sorted.
- exact: sorted_filter.
- move=> i.
  rewrite mem_filter /= => /andP[ihd] /Hincl.
  rewrite inE => /orP[|//]; by rewrite (negbTE ihd).
Qed.

Lemma filter_zip_L m (l : seq A) (k : seq B) a :
  size l = m -> size k = m ->
  filter (fun x => x.1 == a) (zip l k) =
  zip (filter (pred1 a) l) (mask (map (pred1 a) l) k).
Proof.
move=> Hl Hk.
rewrite filter_mask [in RHS]filter_mask zip_mask; congr mask.
elim: m l k Hl Hk a => [[] // [] //|n ih].
move=> [|a1 a2] // [|b1 b2] // [sza2] [szb2] a /=; by rewrite ih.
Qed.

Lemma filter_zip_R m (l : seq A) (k : seq B) b :
  size l = m -> size k = m ->
  filter (fun x => x.2 == b) (zip l k) =
  zip (mask (map (pred1 b) k) l) (filter (pred1 b) k).
Proof.
move=> Hl Hk.
rewrite filter_mask [in RHS]filter_mask zip_mask; congr mask.
elim: m l k Hl Hk b => [[] // [] // | n ih].
move=> [|a1 a2] // [|b1 b2] // [sza2] [szb2] b /=; by rewrite ih.
Qed.

Lemma undup_filter (P : pred B) l : undup (filter P l) = filter P (undup l).
Proof.
elim: l => // h t IH /=; case/boolP : (P h) => /= Ph.
- case/boolP: (h \in t) => ht.
  + by rewrite mem_filter Ph ht.
  + by rewrite mem_filter (negbTE ht) andbF /= Ph IH.
- rewrite IH; case: ifPn => //= ?; by rewrite (negbTE Ph).
Qed.

Lemma undup_perm (f : A -> B) p h t : undup (map f p) = h :: t ->
  exists preh : seq A,
    exists pret : seq A,
      perm_eq p (preh ++ pret) /\
      undup (map f preh) = [:: h] /\ undup (map f pret) = t.
Proof.
move=> p_t.
exists (filter (preim f [pred x | x == h]) p), (filter (preim f [pred x | x \in t]) p).
split.
- apply/perm_eqlP => x.
  rewrite -(@perm_filterC A (preim f [pred x | (x == h)]) p).
  move: x.
  apply/perm_eqlP.
  rewrite perm_cat2l (@eq_in_filter _ _ [pred x | (f x \in t)]) //.
  move=> x X /=.
  case/orP : (orbN (f x == h)) => Y.
  + rewrite Y /=.
    symmetry.
    apply/negP => abs.
    move/eqP : Y => Y; subst h.
    have : uniq (f x :: t).
      rewrite -p_t; by apply undup_uniq.
    by rewrite /= abs.
  - rewrite Y.
    symmetry.
    have Htmp : f x \in map f p by apply/mapP; exists x.
    have {Htmp}Htmp : f x \in h :: t by rewrite -p_t mem_undup.
    rewrite in_cons in Htmp.
    case/orP : Htmp => [Htmp|->//].
    by rewrite Htmp in Y.
- split.
  + rewrite -filter_map undup_filter p_t /= eqxx.
    have -> : filter [pred x | x == h] t = [::]; last by done.
    apply trans_eq with (filter pred0 t); last by apply filter_pred0.
    apply eq_in_filter => i Hi /=.
    apply/negP => X.
    move/eqP : X => X; subst h.
    have : uniq (i :: t).
      rewrite -p_t; by apply undup_uniq.
    rewrite /=.
    case/andP => H1 H2.
    by rewrite Hi in H1.
  + rewrite -filter_map undup_filter p_t /=.
    have -> : h \in t = false.
      apply/negP => X.
      have : uniq (h :: t).
        rewrite -p_t.
        by apply undup_uniq.
      by rewrite /= X.
    apply trans_eq with (filter predT t); last by apply filter_predT.
    by apply eq_in_filter.
Qed.

End seq_eqType_ext.

Lemma addb_nseq b : forall r v, size v = r ->
  [seq x.1 (+) x.2 | x <- zip (nseq r b) v] = map (pred1 (negb b)) v.
Proof.
elim=> [ [] // | r IH [|h t] //= [] r_t].
rewrite {}IH //; move: b h; by case; case.
Qed.

Definition addb_seq a b := [seq x.1 (+) x.2 | x <- zip a b].

Lemma addb_seq_com : forall n a b, size a = n -> size b = n ->
  addb_seq a b = addb_seq b a.
Proof.
elim => [ [] // [] // | n IH [|ha ta] // [|hb tb] // ] [Ha] [Hb].
by rewrite /addb_seq /= -!/(addb_seq _ _) IH // addbC.
Qed.

Lemma addb_seq_cat a b c d : size a = size c ->
  addb_seq (a ++ b) (c ++ d) = addb_seq a c ++ addb_seq b d.
Proof. move=> a_c; by rewrite /addb_seq /= -map_cat zip_cat. Qed.

Lemma addb_seq_map {A : Type} : forall n (a b : seq A) f,
  size a = n -> size b = n ->
  addb_seq (map f a) (map f b) = map (fun x => f x.1 (+) f x.2) (zip a b).
Proof.
elim => [[] // [] //| n IH [|ha ta] // [|hb tb] //= f [Ha] [Hb]].
by rewrite /addb_seq /= -IH.
Qed.

Section finset_ext.

Variable A : finType.

Lemma seq_index_enum_card : forall l (Y : {set A}) i,
  l =i enum Y -> uniq l -> i \in Y -> index i l < #| Y |.
Proof.
elim => [Y i Y0 _ iY | h t IH Y i htY uniqht iY /= ].
  have {iY} : i \in enum Y by rewrite mem_enum.
  by rewrite -Y0.
case: ifPn => [_|hi]; first by rewrite card_gt0; apply/set0Pn; exists i.
apply (@leq_ltn_trans #|Y :\ h|); last first.
  rewrite (cardsD1 h Y).
  suff : h \in Y by move=> ->; rewrite addnC addn1.
  by rewrite -mem_enum -htY in_cons eqxx.
apply IH.
- move=> j.
  move H : (j \in enum (Y :\ h)) => [].
  + move: H; rewrite mem_enum in_setD1 => /andP[/negbTE H].
    by rewrite -mem_enum -htY in_cons H.
  + move/negbT: H.
    rewrite mem_enum in_setD1 negb_and negbK => /orP[/eqP ->{j}|].
    - by move: uniqht => /= /andP[/negbTE].
    - by rewrite -mem_enum -htY inE negb_or => /andP[_ /negbTE].
- move: uniqht; by case/andP.
- apply/setD1P; by rewrite eq_sym.
Qed.

Lemma inj_card (B : finType) (f : {ffun A -> B}) :
  injective f -> #| A | <= #| B |.
Proof. move=> Hf; by rewrite -(@card_imset _ _ f) // max_card. Qed.

Lemma cardsltn1P (s : {set A}) :
  (1 < #| s |) = [exists a, exists b, (a \in s) && (b \in s) && (a != b)].
Proof.
case/boolP : (s == set0) => [ /eqP -> | /set0Pn [] /= a Ha ].
  rewrite cards0 /=.
  apply/esym/negbTE.
  rewrite negb_exists.
  apply/forallP => a.
  rewrite negb_exists.
  apply/forallP => b.
  by rewrite !inE.
case/boolP : (s :\ a == set0) => [sa | ].
  have Hs : s == [set a].
    apply/eqP/setP => /= a'.
    move/eqP/setP/(_ a') in sa.
    rewrite !inE in sa.
    move/negbT in sa.
    rewrite negb_and negbK in sa.
    case/orP : sa => sa.
      move/eqP in sa; subst a'.
      by rewrite inE eqxx.
    rewrite (negbTE sa) inE.
    apply/esym/negbTE.
    apply/eqP => ?; subst a'.
    by rewrite Ha in sa.
  rewrite (eqP Hs) cards1.
  apply/esym/negbTE.
  rewrite negb_exists.
  apply/forallP => b.
  rewrite negb_exists.
  apply/forallP => c.
  rewrite 2!in_set1.
  case/boolP : (b == c).
    move/eqP => ?; subst c; by rewrite /= andbC.
  rewrite /= andbT negb_and => bc.
  case/boolP : (b == a) => // /eqP ?; subst b => /=; by rewrite eq_sym.
case/set0Pn => b Hb.
have -> : 1 < #| s |.
  by rewrite (cardsD1 a s) Ha /= (cardsD1 b (s :\ a)) Hb.
apply/esym; apply/existsP; exists a; apply/existsP; exists b.
rewrite !inE eq_sym in Hb.
case/andP : Hb => -> ->; by rewrite Ha.
Qed.

Variables (C : {set A}).

Lemma set1_set2 a : a \in C -> C != set1 a -> exists i, (i \in C) && (i != a).
Proof.
move/setD1K => aC Ca.
have /set0Pn[b] : C :\ a != set0.
  apply: contra Ca; rewrite setD_eq0 subset1 => /orP[//|].
  by rewrite -aC => /eqP/setP/(_ a); rewrite !inE eqxx.
rewrite !inE => /andP[ba bC]; exists b; by rewrite bC.
Qed.

Lemma set2_set1 a : (exists i, (i \in C) && (i != a)) -> C != set1 a.
Proof.
case=> b /andP[bC]; apply: contra => /eqP Ca; move: bC; by rewrite Ca !inE.
Qed.

End finset_ext.

Lemma ord0_false (i : 'I_0 ) : False. Proof. by case: i => [[]]. Qed.

Lemma ord1 (i : 'I_1) : i = ord0. Proof. case: i => [[]] // ?; exact/eqP. Qed.

Lemma enum_inord (m : nat) : enum 'I_m.+1 = [seq inord i | i <- iota 0 m.+1].
Proof.
rewrite -val_enum_ord -map_comp.
transitivity ([seq i | i <- enum 'I_m.+1]); first by rewrite map_id.
apply eq_map => i /=; by rewrite inord_val.
Qed.

Module Set2.
Section set2.

Variable X : finType.
Hypothesis HX : #|X| = 2%nat.

Definition a := enum_val (cast_ord (esym HX) ord0).
Definition b := enum_val (cast_ord (esym HX) (lift ord0 ord0)).

Lemma enumE : enum X = a :: b :: [::].
Proof.
apply (@eq_from_nth _ a); first by rewrite -cardE HX.
case=> [_|]; first by rewrite [X in _ = X]/= {2}/a (enum_val_nth a).
case=> [_ |i]; last by rewrite -cardE HX.
by rewrite [X in _ = X]/= {1}/b (enum_val_nth a).
Qed.

Lemma a_neq_b : a != b.
Proof. rewrite /a /b. apply/eqP. by move/enum_val_inj. Qed.

Lemma neq_a_b x : x != a -> x == b.
Proof. have : x \in X by []. by rewrite -mem_enum enumE !inE => /orP[->|]. Qed.

Lemma ind (C : X -> Type) : C a -> C b -> forall a, C a.
Proof.
move=> H1 H2 c; by case/boolP : (c == a) => [/eqP -> //|/neq_a_b/eqP ->].
Qed.

End set2.
End Set2.

Section tuple_ext.

Variable A : Type.

Local Open Scope tuple_ext_scope.

Lemma tcast2tval m n (H : m = n) :
  forall (v : m.-tuple A) (w : n.-tuple A), tcast H v = w -> tval v = tval w.
Proof. subst n. by move=> [v Hv] [w Hw] <- /=. Qed.

Lemma tcast_take_inj n m k (H : minn n k = m) (nk : n = k) (t v : k.-tuple A) :
  tcast H [tuple of take n t] = tcast H [tuple of take n v] -> t = v.
Proof.
subst m n => /=.
case => /= tv.
apply eq_from_tnth => i.
rewrite (tnth_nth t\_i) [in X in _ = X](tnth_nth t\_i).
by rewrite -(@nth_take k) // -[in X in _ = X](@nth_take k) // tv.
Qed.

Lemma eq_tcast n (t : n.-tuple A) m (v : m.-tuple A) (H : m = n) :
  tval t = tval v -> t = tcast H v.
Proof. subst m; rewrite tcast_id => tt'; exact: val_inj. Qed.

Lemma eq_tcast2 n (t : seq A) m (v : m.-tuple A) (H : m = n) :
  t = tval v -> t = tval (tcast H v).
Proof. subst m. by rewrite tcast_id. Qed.

Lemma tnth_zip_1 (B : finType) n (x1 : n.-tuple A) (x2 : n.-tuple B) i:
  (tnth [tuple of zip x1 x2] i).1 = tnth x1 i.
Proof.
rewrite /tnth; set def := tnth_default _ _; case: def => ? ?.
rewrite nth_zip /=; last by rewrite !size_tuple.
apply set_nth_default; by rewrite size_tuple.
Qed.

Lemma tnth_zip_2 (B : finType) n (x1 : n.-tuple A) (x2 : n.-tuple B) i:
  (tnth [tuple of zip x1 x2] i).2 = tnth x2 i.
Proof.
rewrite /tnth; set def := tnth_default _ _; case: def => ? ?.
rewrite nth_zip /=; last by rewrite !size_tuple.
apply set_nth_default; by rewrite size_tuple.
Qed.

Lemma thead_tuple1 : forall (i : 1.-tuple A), [tuple thead i] = i.
Proof. move=> [ [|h []] H] //. by apply val_inj. Qed.

Definition tbehead n (t : n.+1.-tuple A) : n.-tuple A := [tuple of behead t].

Lemma sorted_of_tnth {C : eqType} (r : rel C) k (t : k.-tuple C) :
  transitive r -> sorted r t -> forall a b : 'I_k, a < b -> r (t \_ a) (t \_ b).
Proof.
move=> r_trans r_sorted a b ab.
rewrite (tnth_nth t\_b) {2}(tnth_nth t\_b).
apply sorted_of_nth => //; by rewrite ab size_tuple /=.
Qed.

Lemma sorted_of_tnth_leq (X : finType) (n : nat) (r : rel X) (t : n.-tuple X)
  (r_trans : transitive r) (r_refl : reflexive r) (Hx : sorted r t) :
  forall (l p : 'I_n), l <= p -> r t\_l t\_p.
Proof.
move=> l p leqlp.
case/boolP : (l == p) => Hcase.
- move/eqP in Hcase; rewrite Hcase; apply r_refl.
- apply sorted_of_tnth => //; by rewrite ltn_neqAle leqlp Hcase.
Qed.

Definition sort_tuple (X : eqType) n (r : rel X) (t : n.-tuple X) : n.-tuple X.
apply Tuple with (sort r t).
by rewrite size_sort size_tuple.
Defined.

End tuple_ext.

Section bseq.

Variables (n : nat) (T : Type).

Structure bseq_of : Type := Bseq {bseqval :> seq T; _ : size bseqval <= n}.

Lemma bseqval_inj : injective bseqval.
Proof.
move=> [a Ha] [b Hb] /= H.
move: Ha Hb; rewrite H => Ha Hb.
congr Bseq; exact: eq_irrelevance.
Qed.

Canonical bseq_subType := Eval hnf in [subType for bseqval].

End bseq.

Notation "n .-bseq" := (bseq_of n) (at level 2, format "n .-bseq") : type_scope.

Section canonical.

Variable n : nat.

Definition bseq_eqMixin (T : eqType) := Eval hnf in [eqMixin of n.-bseq T by <:].
Canonical bseq_eqType (T : eqType) := Eval hnf in EqType (n.-bseq T) (bseq_eqMixin T).
Canonical bseq_predType (T : eqType) :=
  Eval hnf in mkPredType (fun t : n.-bseq T => mem_seq t). (* TODO: warning *)
Definition bseq_choiceMixin (T : choiceType) := [choiceMixin of n.-bseq T by <:].
Canonical bseq_choiceType (T : choiceType) :=
  Eval hnf in ChoiceType (n.-bseq T) (bseq_choiceMixin T).
Definition bseq_countMixin (T : countType) := [countMixin of n.-bseq T by <:].
Canonical bseq_countType (T : countType) :=
  Eval hnf in CountType (n.-bseq T) (bseq_countMixin T).
Canonical bseq_subCountType (T : countType) := Eval hnf in [subCountType of n.-bseq T].

End canonical.

Program Definition bseq0 n (T : finType) : n.-bseq T := @Bseq n T [::] _.

Definition bseq_of_tuple n (T : finType) (t : seq T) : n.-bseq T :=
  match Bool.bool_dec (size t <= n) true with
    left H => Bseq H | right _ => @bseq0 n T
  end.

Definition bseq_enum n (T : finType) : seq (n.-bseq T) :=
  flatten (map (fun m => map (@bseq_of_tuple n _) (map (@tval _ _) (enum {: m.-tuple T}))) (iota 0 n.+1)).

Lemma bseq_of_tuple_inj n (T : finType) m (mn : m <= n) :
  injective (bseq_of_tuple n (T:=T) \o @tval m T).
Proof.
move=> /= [a Ha] [b Hb] /=.
rewrite /bseq_of_tuple.
case: Bool.bool_dec; last by rewrite (eqP Ha) mn.
move=> Ha'.
case: Bool.bool_dec => [Hb'|]; last by rewrite (eqP Hb) mn.
case => ?; subst a.
congr Tuple; exact: eq_irrelevance.
Qed.

Lemma bseq_enumP n (T : finType) : Finite.axiom (bseq_enum n T).
Proof.
case=> s sn.
rewrite count_flatten -[in iota _ _](subnKC sn) -addnS iota_add !map_cat.
rewrite sumn_cat add0n /= addnCA -sumn_cat -!map_cat count_uniq_mem; last first.
  rewrite -map_comp map_inj_uniq //; by [rewrite enum_uniq | exact: bseq_of_tuple_inj].
rewrite -map_comp (_ : _ \in _); last first.
  apply/mapP => /=.
  exists (in_tuple s); first by rewrite mem_enum inE.
  rewrite /bseq_of_tuple.
  case: Bool.bool_dec; last by rewrite size_tuple sn.
  move=> sn'; congr Bseq; exact: eq_irrelevance.
rewrite add1n; congr S; apply/eqP/natnseq0P/all_pred1P/allP => /= m.
rewrite -map_comp; case/mapP => /= l Hl ->.
move: Hl; rewrite mem_cat => /orP[|].
  rewrite mem_iota add0n leq0n /= => ls.
  apply/eqP/count_memPn/mapP => /= -[s' /mapP[t' _ ->]].
  rewrite /bseq_of_tuple.
  case: Bool.bool_dec => ln; case => ?; subst s.
  by rewrite size_tuple ltnn in ls.
  by rewrite ltn0 in ls.
rewrite mem_iota => /andP[sl].
rewrite addSn subnKC // ltnS => ln.
apply/eqP/count_memPn/mapP => /= -[s' /mapP[t' _ ->]].
rewrite /bseq_of_tuple.
case: Bool.bool_dec; last by rewrite size_tuple ln.
move=> _ln'; case => ?; subst s.
by rewrite size_tuple ltnn in sl.
Qed.

Canonical bseq_finMixin n (T : finType) := Eval hnf in FinMixin (@bseq_enumP n T).
Canonical bseq_finType n (T : finType) := Eval hnf in FinType (n.-bseq T) (bseq_finMixin n T).
Canonical bseq_subFinType n (T: finType) := Eval hnf in [subFinType of n.-bseq T].

Lemma size_bseq (n : nat) (T : Type) (bs : n.-bseq T) : size bs <= n.
Proof. by case: bs. Qed.

Lemma rcons_bseqP n T (t : n.-bseq T) x : size (rcons t x) <= n.+1.
Proof. by rewrite size_rcons ltnS size_bseq. Qed.
Canonical rcons_bseq n (T : Type) (t : n.-bseq T) x := Bseq (rcons_bseqP t x).

Definition bseq n (T : Type) (t : n.-bseq T) mkT : bseq_of n T :=
  mkT (let: Bseq _ tP := t return size t <= n in tP).

Notation "[ 'bseq' 'of' s ]" := (@bseq _ _ _ (fun sP => @Bseq _ _ s sP))
  (at level 0, format "[ 'bseq'  'of'  s ]") : type_scope.

Section ordered_ranks.

Variable X : finType.

Definition le_rank (x y : X) := enum_rank x <= enum_rank y.

Definition lt_rank x y := le_rank x y && (x != y).

Lemma lt_rank_alt x y : lt_rank x y = (enum_rank x < enum_rank y).
Proof.
rewrite /lt_rank /le_rank ltn_neqAle andbC; apply andb_id2r => _.
case/boolP : (x == y) => [/eqP ->|xy]; first by rewrite eqxx.
apply/esym => /=; apply: contra xy => /eqP H.
by apply/eqP/enum_rank_inj/ord_inj.
Qed.

Lemma le_rank_trans : transitive le_rank.
Proof. rewrite /le_rank /transitive => a b c /leq_trans; by apply. Qed.

Lemma le_rank_refl : reflexive le_rank.
Proof. by rewrite /le_rank /reflexive => a. Qed.

Lemma le_rank_asym : antisymmetric le_rank.
Proof. move=> a b H; apply enum_rank_inj; rewrite -eqn_leq in H; exact/eqP. Qed.

Lemma le_rank_total : total le_rank.
Proof. by rewrite /total => a b; rewrite /le_rank leq_total. Qed.

Lemma lt_le_rank_trans u v w : lt_rank u v -> le_rank v w -> lt_rank u w.
Proof.
rewrite /lt_rank => /andP [uv H] vw.
rewrite (le_rank_trans uv vw) /=; apply: contra H => /eqP ?.
subst w; by rewrite (@le_rank_asym u v) // uv.
Qed.

Lemma le_lt_rank_trans u v w : le_rank u v -> lt_rank v w -> lt_rank u w.
Proof.
rewrite /lt_rank => uv /andP[vw H].
rewrite (le_rank_trans uv vw) /=; apply: contra H => /eqP ?.
subst w. by rewrite (@le_rank_asym u v) // uv.
Qed.

Lemma lt_le_rank_weak u v : lt_rank u v -> le_rank u v.
Proof. by rewrite /lt_rank => /andP [H _]. Qed.

Lemma lt_neq_rank u v : lt_rank u v -> u != v.
Proof. by rewrite /lt_rank => /andP [_ H]. Qed.

Lemma sorted_enum : sorted le_rank (enum X).
Proof.
rewrite /sorted.
move HX : (enum X) => Alst.
destruct Alst => //.
apply/(pathP s) => i Hi.
rewrite /le_rank -HX.
destruct Alst => //.
have iA : i < #|X| by rewrite cardE HX (ltn_trans Hi).
rewrite -(@enum_val_nth X (xpredT) s (Ordinal iA)).
have i1A : i.+1 < #|X| by rewrite cardE HX (leq_ltn_trans Hi).
have -> : (nth s (s0 :: Alst) i) = (nth s (enum X) i.+1) by rewrite /= HX.
by rewrite -(@enum_val_nth X (xpredT) s (Ordinal i1A)) 2!enum_valK leqnSn.
Qed.

End ordered_ranks.

Section perm_tuples.

Local Open Scope tuple_ext_scope.

Variables A : eqType.
Variable n : nat.
Variable s : 'S_n.

Definition perm_tuple (t : n.-tuple A) := [tuple (t \_ (s i)) | i < n].

End perm_tuples.

Section perm_tuples_facts.

Lemma perm_tuple_id {A : finType} {m} (b : m.-tuple A) : perm_tuple 1 b = b.
Proof.
apply eq_from_tnth => i.
by rewrite /perm_tuple /= tnth_map /= perm1 tnth_ord_tuple.
Qed.

Lemma tuple_exist_perm_sort (X : eqType) n (r : rel X) (t : n.-tuple X) :
  exists s : 'S_n, t = perm_tuple s (sort_tuple r t).
Proof.
rewrite /perm_tuple.
have : perm_eq t (sort_tuple r t) by rewrite perm_eq_sym perm_sort perm_eq_refl.
case/tuple_perm_eqP => u Hu; exists u.
case: t Hu => t /= Ht Hu.
apply eq_from_tnth => i /=.
rewrite /tnth /= -Hu.
apply: set_nth_default.
move/eqP : {Hu}Ht => ->; by case: i.
Qed.

Variable A : finType.
Variable n : nat.

Definition perm_tuple_set (s : 'S_n) (E : {set n.-tuple A}) :=
  perm_tuple s @: E.

Lemma perm_tuple_comp (s1 s2 : 'S_n) (b : n.-tuple A) :
  perm_tuple s1 (perm_tuple s2 b) = perm_tuple (s1 * s2) b.
Proof.
apply eq_from_tnth => i.
by rewrite /perm_tuple !tnth_map /= tnth_ord_tuple permM.
Qed.

Lemma perm_tuple_inj (s : 'S_n) : injective (@perm_tuple A n s).
Proof.
rewrite /injective.
move=> a b H.
have H2 : perm_tuple 1 a = perm_tuple 1 b.
- rewrite -(mulVg s).
  rewrite -!perm_tuple_comp.
  f_equal ; apply H.
rewrite !perm_tuple_id in H2 ; apply H2.
Qed.

Lemma perm_tuple0 : forall (u : 'S_0) (t : 0.-tuple A), perm_tuple u t = t.
Proof.
move=> u t.
rewrite (tuple0 t).
have -> : u = 1%g.
  apply/permP => /= x.
  suff : False by done.
  by move/ord0_false in x.
by rewrite perm_tuple_id.
Qed.

Variable B : finType.

Lemma zip_perm_tuple (ta : n.-tuple A) (tb : n.-tuple B) (s : 'S_n) :
  zip_tuple (perm_tuple s ta) (perm_tuple s tb) = perm_tuple s (zip_tuple ta tb).
Proof.
apply eq_from_tnth.
case.
destruct n => //.
case=> [Hi | i Hi].
  rewrite (tnth_nth (thead ta, thead tb)) (tnth_nth (thead (zip_tuple ta tb))).
  rewrite /= enum_ordS /= (tnth_nth (thead ta, thead tb)) /= nth_zip; last
    by rewrite (size_tuple ta) (size_tuple tb).
  by rewrite (tnth_nth (thead ta)) /= (tnth_nth (thead tb)) /=.
rewrite (tnth_nth (thead ta, thead tb)) (tnth_nth (thead (zip_tuple ta tb))) /= enum_ordS /=.
rewrite ltnS in Hi.
rewrite nth_zip; last by rewrite 4!size_map size_enum_ord.
symmetry.
rewrite (nth_map ord0); last by rewrite size_map size_enum_ord.
rewrite (tnth_nth (thead ta, thead tb)) /zip_tuple /=.
rewrite nth_zip; last by rewrite (size_tuple ta) (size_tuple tb).
symmetry.
rewrite (nth_map ord0); last by rewrite size_map size_enum_ord.
rewrite (nth_map ord0); last by rewrite size_map size_enum_ord.
by rewrite (tnth_nth (thead ta)) (tnth_nth (thead tb)).
Qed.

End perm_tuples_facts.

(* TODO: move *)
From mathcomp Require Import fingraph.

Lemma connect_sym1 (D : finType) (r : rel D) : symmetric r ->
  forall x y, connect r x y -> connect r y x.
Proof.
move=> rs x y; case/boolP : (x == y) => [/eqP ->//|xy].
case/connectP => s H1 H2; apply/connectP.
elim/last_ind : s H1 H2 => [|h t _ H1 H2].
  rewrite /= => _ ?; subst y; by rewrite eqxx in xy.
rewrite last_rcons in H2; subst t.
move: H1; rewrite rcons_path => /andP[H1 H2].
exists (rcons (rev h) x); last by rewrite last_rcons.
apply/(pathP x) => i.
rewrite size_rcons ltnS leq_eqVlt size_rev.
case/orP => [/eqP|] Hi.
  case: h => [|h t] in H1 H2 Hi *.
    rewrite /= in H2; by rewrite Hi /= rs.
  rewrite Hi nth_rcons size_rev ltnn eqxx /= nth_rcons size_rev /= ltnS leqnn.
  rewrite nth_rev // subnn rs /=; by case/andP : H1.
rewrite nth_rcons size_rev Hi -cat1s -cats1 catA cats1.
rewrite nth_rcons /= size_rev ltnS (ltnW Hi) nth_rev // -cat1s nth_cat /=.
case: ifPn.
  rewrite ltnS leqn0 => /eqP -> /=; by rewrite subn1 nth_last rs.
rewrite -leqNgt => i0.
rewrite subn1 /= rs nth_rev ?(leq_ltn_trans _ Hi) // ?leq_pred // prednK //.
move/pathP : H1 => /(_ x (size h - i)).
rewrite -cat1s nth_cat /= ifF; last first.
  apply/negbTE; by rewrite -leqNgt subn_gt0 (leq_trans _ Hi).
rewrite -subnDA addn1; apply.
by rewrite -{2}(subn0 (size h)) ltn_sub2l // (leq_trans _ Hi).
Qed.

Lemma connect_sym (D : finType) (r : rel D) : symmetric r -> connect_sym r.
Proof.
move=> ?; rewrite /connect_sym => ? ?; apply/idP/idP => /connect_sym1; exact.
Qed.


Inductive boollist : Type :=
  | bool_nil : boollist
  | bool_cons : bool -> boollist -> boollist.

Check bool_cons. (* bool_cons : bool -> boollist -> boollist *)
Compute bool_cons true bool_nil.

Inductive list (X:Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

Check cons. (* cons : forall X : Type, X -> list X -> list X *)
Compute cons bool true (nil bool).

Check list.

(*
A comment on dependent types
Note that this is different from polymorphism which includes the type as an argument.
*)
Check cons nat.
Check cons bool.

Definition is_nil (X : Type) (l : list X) :=
  match l with
  | nil _ => true
  | _     => false
  end.

Fixpoint list_length (x : Type) (l : list x) :=
  match l with
  | nil _       => 0
  | cons _ _ l' => 1 + list_length x l'
  end.

Compute list_length bool (cons bool true (nil bool)).

Check cons _ 1 (cons _ 2 (nil _)).

(*
This powerful facility means we don't always have to write explicit
type annotations everywhere, although explicit type annotations are
still quite useful as documentation and sanity checks, so we will
continue to use them most of the time.
*)

(*
The Arguments directive specifies the name of the function
(or constructor) and then lists its argument names, with curly
braces around any arguments to be treated as implicit. (If some
arguments of a definition don't have a name, as is often the case
for constructors, they can be marked with a wildcard pattern _.)
*)
Arguments nil {X}.
Arguments cons {X}.
Arguments list_length {x} l.

Compute cons 1 (cons 2 nil).
Compute list_length (cons 1 (cons 2 nil)).

(*
Alternatively, we can declare an argument to be implicit when defining
the function itself, by surrounding it in curly braces instead of parens.
*)
Fixpoint list_length' {x : Type} (l : list x) :=
  match l with
  | nil       => 0
  | cons _ l' => 1 + list_length' l'
  end.

Check list_length'.

Compute list_length' (cons 1 (cons 2 nil)).

Definition cool_pair {X : Type} (x y : X) := fun a => if (Nat.eqb a 1) then x else y.

Compute ((cool_pair 10 20) 1).
Compute ((cool_pair 10 20) 2).


(* This file is part of the Linear Logic  formalization in Coq: https://github.com/brunofx86/LL *)

(** ** Linear Logic Sequent Calculi
We formalize different sequent calculi for Classical Linear Logic: two
sided, one sided and dyadic systems. Some systems also make explicit
the measures (e.g., height of derivation) needed for the
cut-elimination proof.

All the systems internalize the exchange rule. For instance,
the typical rule for [⊤]
<<
--------------- ⊤
|-- Gamma , ⊤
>>

is defined as

[ forall Gamma M, Gamma =mul= {{Top}} U M -> |-- Gamma ]

The considered systems are:

 - [cls] (notation [D |-- L]): two sided system without cut rule.
   Structural rules (weakening and contraction)
   are explicit in the system (see e.g., [cls_questc]).

 - [sig1] (notation [|-- L]): one sided system without cut
   rule. Structural rules (weakening and contraction) are explicit in
   the system.

 - [sig2] (notation [|-- B ; L]): dyadic, one sided system without cut
   rule. [B] is the classical context and [L] the
   linear context. There are no structural rules. Those rules are
   proved to be admissible in the classical context (see e.g., Theorem
   [height_preserving_weakning_sig2h]).

 - [sig2h] (notation [n |-- B ; L]): similar to [sig2] but the height
   of the derivation [n] is explicit. This is useful in proofs that
   require induction on the height of the derivation.

 - [sig2hc] (notation [n '|-c' B ';' L]): dyadic, one sided system
   with cut rule.

 - [sig2hcc] (notation [n '|-cc' B ';' L]): adds to [sig2hc] the
   following cut rule (for the classical context)

<<
|-- B; M, !F   |-- B, F° ; N
----------------------------- CCUT
|-- B ; M, N
>>

  - [sig3] (notation [n => c ; B ; L]) : where we make explicit the
    number of times the cut rules (CUT or CCUT) were used in the
    derivation. It makes also explicit the measures used in the proof
    of cut-elimination: height of the cut and complexity of the cut
    formula (see [sig3_cut_general]).

 *)

Require Export Syntax.
Require Export MultisetLL.
Require Export StrongInduction.
Require Import Coq.Relations.Relations.
Require Import Coq.Arith.EqNat.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Program.Equality.
Require Export List.
Export ListNotations.
Set Implicit Arguments.

Hint Resolve Max.le_max_r.
Hint Resolve Max.le_max_l.

(** Dyadic system  (one-sided) *)
Reserved Notation " '|--' B ';' L" (at level 80).
Inductive sig2: list lexp -> list lexp -> Prop :=

| sig2_init : forall B L A, L =mul= (A ⁺) :: [A ⁻] -> |-- B ; L
| sig2_one : forall B L, L =mul= [1] -> |-- B ; L
| sig2_top : forall B L M, L =mul= Top :: M -> |-- B ; L
| sig2_bot : forall B L M , L =mul= Bot :: M -> |-- B ; M -> |-- B ; L
| sig2_par : forall B L M F G , L =mul= (F $ G) :: M -> |-- B ; F :: G :: M -> |-- B ; L
| sig2_tensor : forall B L M N F G ,
    L =mul= (F ** G) :: (M ++ N)  ->
    |-- B ; F :: M ->
            |-- B ; G :: N ->  |-- B ; L
| sig2_plus1: forall B L M F G , L =mul= (F ⊕ G) :: M -> |-- B ; F :: M -> |-- B ; L
| sig2_plus2: forall B L M F G , L =mul= (F ⊕ G) :: M -> |-- B ; G :: M -> |-- B ; L
| sig2_with: forall B L M F G ,
    L =mul= (F & G) :: M ->
    |-- B ; F :: M ->
            |-- B ; G :: M ->  |-- B ; L
| sig2_copy: forall B D L M F ,
    D =mul= F :: B -> L =mul= F :: M ->
    |-- D ; L ->
            |-- D ; M

| sig2_quest: forall B L M F , L =mul= (? F) :: M  ->
                               |-- F :: B ; M ->
                                            |-- B ; L

| sig2_bang: forall B F L , L =mul= [! F] ->
                            |--  B ; [F] ->
                                     |--  B ; L

where "|-- B ; L" := (sig2 B L).

Lemma sig2_der_compat : forall B1 B2 L1 L2, B1 =mul= B2 -> L1 =mul= L2 -> |-- B1 ; L1 -> |-- B2 ; L2.
Proof.
  intros B1 B2 L1 L2 PB PL H.
  revert dependent B2.
  revert dependent L2.
  induction H; intros;
    try rewrite PB in *;
    try rewrite PL in *. assert (L =mul= L). reflexivity. rewrite H in PL.
  eapply sig2_init; eassumption.
  eapply sig2_one; eassumption.
  eapply sig2_top; eassumption.
  assert (|-- B2 ; M) by solve [apply IHsig2; auto].
  eapply sig2_bot; eassumption.
  assert (|-- B2 ; (F :: G :: M)) by solve [apply IHsig2; auto].
  eapply sig2_par; eassumption.
  assert (|-- B2 ; F :: M) by solve [apply IHsig2_1; auto].
  assert (|-- B2 ; G :: N) by solve [apply IHsig2_2; auto].
  eapply sig2_tensor; eassumption.
  assert (|-- B2 ; F :: M) by solve [apply IHsig2; auto].
  eapply sig2_plus1; eassumption.
  assert (|-- B2 ; G :: M) by solve [apply IHsig2; auto].
  eapply sig2_plus2; eassumption.
  assert (|-- B2 ; F :: M) by solve [apply IHsig2_1; auto].
  assert (|-- B2 ; G :: M) by solve [apply IHsig2_2; auto].
  eapply sig2_with; eassumption.
  assert (|-- B2 ; L) by solve [apply IHsig2; auto].
  eapply sig2_copy; eassumption.
  assert (|-- F :: B2; M) by solve [apply IHsig2; auto].
  eapply sig2_quest; eassumption.
  assert (|-- B2; [F]) by solve [apply IHsig2; auto].
  eapply sig2_bang; eassumption.
Qed.

Instance sig2_der_morphism :
  Proper (meq ==> meq ==> iff) (sig2).
Proof.
  unfold Proper; unfold respectful.
  intros B1 B2 PB L1 L2 PL.
  split; intro H.
  refine (sig2_der_compat PB PL H).
  refine (sig2_der_compat (symmetry PB) (symmetry PL) H).
Qed.

(** Dyadic system with explicit heights of derivations *)
Reserved Notation " n '|--' B ';' L" (at level 80).
Inductive sig2h: nat -> list lexp -> list lexp -> Prop :=

| sig2h_init : forall B L A, L =mul= (A ⁺) :: [A ⁻] -> 0 |-- B ; L
| sig2h_one : forall B L, L =mul= [1] -> 0 |-- B ; L
| sig2h_top : forall B L M, L =mul= Top :: M -> 0 |-- B ; L
| sig2h_bot : forall B L M n, L =mul= Bot :: M -> n |-- B ; M -> S n |-- B ; L
| sig2h_par : forall B L M F G n, L =mul= (F $ G) :: M -> n |-- B ; F :: G :: M -> S n |-- B ; L
| sig2h_tensor : forall B L M N F G n m,
    L =mul= (F ** G) :: (M ++ N)  ->
    m |-- B ; F :: M ->
              n |-- B ; G :: N -> S (max n m) |-- B ; L
| sig2h_plus1: forall B L M F G n, L =mul= (F ⊕ G) :: M -> n |-- B ; F :: M -> S n |-- B ; L
| sig2h_plus2: forall B L M F G n, L =mul= (F ⊕ G) :: M -> n |-- B ; G :: M -> S n |-- B ; L
| sig2h_with: forall B L M F G n m,
    L =mul= (F & G) :: M ->
    m |-- B ; F :: M ->
              n |-- B ; G :: M -> S (max n m) |-- B ; L
| sig2h_copy: forall B D L M F n,
    D =mul= F :: B -> L =mul= F :: M ->
    n |-- D ; L ->
              S n|-- D ; M

| sig2h_quest : forall B L M F n, L =mul= (? F) :: M  ->
                                  n |-- F :: B ; M ->
                                                 S n |-- B ; L

| sig2h_bang : forall B F L n, L =mul= [! F] ->
                               n |--  B ; [F] ->
                                          S n |--  B ; L

where "n |-- B ; L" := (sig2h n B L).

Lemma sig2h_der_compat : forall n (B1 B2 L1 L2 : list lexp), B1 =mul= B2 -> L1 =mul= L2 -> n |-- B1 ; L1 -> n |-- B2 ; L2.
Proof.
  intros n B1 B2 L1 L2 PB PL H.
  revert L1 L2 PL B1 B2 PB H;
    induction n using strongind; intros.
  - inversion H; subst.
    +
      refine (sig2h_init _ (transitivity (symmetry PL) H0)).
    +
      refine (sig2h_one _ (transitivity (symmetry PL) H0)).
    +
      refine (sig2h_top _ (transitivity (symmetry PL) H0)).
  - inversion H0; subst; try rewrite PL in H3; try rewrite PL in H2;
      try rewrite PB in H3; try rewrite PB in H2.
    +
      refine (sig2h_bot H2 _); auto.
      apply H with (L1:= M) (B1:=B1); auto.
    +
      refine (sig2h_par H2 _); auto.
      apply H with (L1:= F :: G :: M) (B1:=B1); auto.
    +
      refine (sig2h_tensor H2 _ _).
      apply H with (L1:= F :: M) (B1:=B1); auto.
      apply H with (L1:= G :: N) (B1:=B1); auto.
    +
      refine (sig2h_plus1 H2 _).
      apply H with (L1:= F :: M) (B1:=B1); auto.
    +
      refine (sig2h_plus2 H2 _).
      apply H with (L1:= G :: M) (B1:=B1); auto.
    +
      refine (sig2h_with H2 _ _).
      apply H with (L1:= F :: M) (B1:=B1); auto.
      apply H with (L1:= G :: M) (B1:=B1); auto.
    +
      refine (sig2h_copy H2 H3 _).
      apply H with (L1:= L) (B1:=B1); auto.
    +
      refine (sig2h_quest H2 _).
      apply H with (L1:= M) (B1:= F :: B1); auto.
    +
      refine (sig2h_bang H2 _).
      apply H with (L1:= [F]) (B1:=B1); auto.
Qed.

Generalizable All Variables.
Instance sig2h_der_morphism :
  Proper (meq ==> meq ==> iff) (sig2h n).
Proof.
  unfold Proper; unfold respectful.
  intros n B1 B2 PB L1 L2 PL.
  split; intro H.
  refine (sig2h_der_compat PB PL H).
  refine (sig2h_der_compat (symmetry PB) (symmetry PL) H).
Qed.

(** Dyadic system + Cut rule *)
Reserved Notation "n '|-c' B ';' L" (at level 80).
Inductive sig2hc: nat -> list lexp -> list lexp -> Prop :=

| sig2hc_init : forall B L A, L =mul= (A ⁺) :: [A ⁻] -> 0 |-c B ; L
| sig2hc_one : forall B L, L =mul= [1] -> 0 |-c B ; L
| sig2hc_top : forall B L M, L =mul= Top :: M -> 0 |-c B ; L
| sig2hc_bot : forall B L M n, L =mul= Bot :: M -> n |-c B ; M -> S n |-c B ; L
| sig2hc_par : forall B L M F G n, L =mul= (F $ G) :: M -> n |-c B ; F :: G :: M -> S n |-c B ; L
| sig2hc_cut : forall B L M N F m n,
    L =mul= (M ++ N)  ->
    m|-c B ; F :: M ->
             n|-c B ; F° :: N -> S (max n m)|-c B ; L
| sig2hc_tensor : forall B L M N F G n m,
    L =mul= (F ** G) :: (M ++ N)  ->
    m |-c B ; F :: M ->
              n |-c B ; G :: N -> S (max n m) |-c B ; L
| sig2hc_plus1: forall B L M F G n, L =mul= (F ⊕ G) :: M -> n |-c B ; F :: M -> S n |-c B ; L
| sig2hc_plus2: forall B L M F G n, L =mul= (F ⊕ G) :: M -> n |-c B ; G :: M -> S n |-c B ; L
| sig2hc_with: forall B L M F G n m,
    L =mul= (F & G) :: M ->
    m |-c B ; F :: M ->
              n |-c B ; G :: M -> S (max n m) |-c B ; L

| sig2hc_copy: forall B D L M F n,
    D =mul= F :: B -> L =mul= F :: M ->
    n |-c D ; L ->
              S n|-c D ; M

| sig2hc_quest : forall B L M F n, L =mul= (? F) :: M  ->
                                   n |-c F :: B ; M ->
                                                  S n |-c B ; L

| sig2hc_bang : forall B F L n, L =mul= [! F] ->
                                n |-c  B ; [F] ->
                                           S n |-c  B ; L

where "n |-c B ; L" := (sig2hc n B L).

Lemma sig2hc_der_compat : forall n (B1 B2 L1 L2 : list lexp), B1 =mul= B2 -> L1 =mul= L2 -> n |-c B1 ; L1 -> n |-c B2 ; L2.
Proof.
  intros n B1 B2 L1 L2 PB PL H.
  revert L1 L2 PL B1 B2 PB H;
    induction n using strongind; intros.
  - inversion H; subst.
    +
      refine (sig2hc_init _ (transitivity (symmetry PL) H0)).
    +
      refine (sig2hc_one _ (transitivity (symmetry PL) H0)).
    +
      refine (sig2hc_top _ (transitivity (symmetry PL) H0)).
  - inversion H0; subst; try rewrite PL in H3; try rewrite PL in H2;
      try rewrite PB in H3; try rewrite PB in H2.
    +
      refine (sig2hc_bot H2 _); auto.
      apply H with (L1:= M) (B1:=B1); auto.
    +
      refine (sig2hc_par H2 _); auto.
      apply H with (L1:= F :: G :: M) (B1:=B1); auto.
    +
      refine (sig2hc_cut H2 _ _).
      eapply H with (L1:= F :: M) (B1:=B1); auto.
      eapply H with (L1:= F° :: N) (B1:=B1); auto.
    +
      refine (sig2hc_tensor H2 _ _).
      apply H with (L1:= F :: M) (B1:=B1); auto.
      apply H with (L1:= G :: N) (B1:=B1); auto.
    +
      refine (sig2hc_plus1 H2 _).
      apply H with (L1:= F :: M) (B1:=B1); auto.
    +
      refine (sig2hc_plus2 H2 _).
      apply H with (L1:= G :: M) (B1:=B1); auto.
    +
      refine (sig2hc_with H2 _ _).
      apply H with (L1:= F :: M) (B1:=B1); auto.
      apply H with (L1:= G :: M) (B1:=B1); auto.
    +
      refine (sig2hc_copy H2 H3 _).
      apply H with (L1:= L) (B1:=B1); auto.
    +
      refine (sig2hc_quest H2 _).
      apply H with (L1:= M) (B1:= F :: B1); auto.
    +
      refine (sig2hc_bang H2 _).
      apply H with (L1:= [F]) (B1:=B1); auto.
Qed.

Generalizable All Variables.
Instance sig2hc_der_morphism :
  Proper (meq ==> meq ==> iff) (sig2hc n).
Proof.
  unfold Proper; unfold respectful.
  intros n B1 B2 PB L1 L2 PL.
  split; intro H.
  refine (sig2hc_der_compat PB PL H).
  refine (sig2hc_der_compat (symmetry PB) (symmetry PL) H).
Qed.

(** Dyadic system + Cut  + Cut! rules *)
Reserved Notation " n '|-cc' B ';' L" (at level 80).
Inductive sig2hcc: nat -> list lexp -> list lexp -> Prop :=

| sig2hcc_init : forall B L A, L =mul= (A ⁺) :: [A ⁻] -> 0 |-cc B ; L
| sig2hcc_one : forall B L, L =mul= [1] -> 0 |-cc B ; L
| sig2hcc_top : forall B L M, L =mul= Top :: M -> 0 |-cc B ; L
| sig2hcc_bot : forall B L M n, L =mul= Bot :: M -> n |-cc B ; M -> S n |-cc B ; L
| sig2hcc_par : forall B L M F G n, L =mul= (F $ G) :: M -> n |-cc B ; F :: G :: M -> S n |-cc B ; L
| sig2hcc_cut : forall B L M N F m n,
    L =mul= (M ++ N)  ->
    m|-cc B ; F :: M ->
              n|-cc B ; F° :: N -> S (max n m)|-cc B ; L
| sig2hcc_ccut : forall B L M N F m n,
    L =mul= (M ++ N) ->
    m|-cc B ; (! F) :: M ->
              n|-cc F° :: B ; N -> S (max n m)|-cc B ; L
| sig2hcc_tensor : forall B L M N F G n m,
    L =mul= (F ** G) :: (M ++ N)  ->
    m |-cc B ; F :: M ->
               n |-cc B ; G :: N -> S (max n m) |-cc B ; L
| sig2hcc_plus1: forall B L M F G n, L =mul= (F ⊕ G) :: M -> n |-cc B ; F :: M -> S n |-cc B ; L
| sig2hcc_plus2: forall B L M F G n, L =mul= (F ⊕ G) :: M -> n |-cc B ; G :: M -> S n |-cc B ; L
| sig2hcc_with: forall B L M F G n m,
    L =mul= (F & G) :: M ->
    m |-cc B ; F :: M ->
               n |-cc B ; G :: M -> S (max n m) |-cc B ; L

| sig2hcc_copy: forall B D L M F n,
    D =mul= F :: B -> L =mul= F :: M ->
    n |-cc D ; L ->
               S n|-cc D ; M

| sig2hcc_quest : forall B L M F n, L =mul= (? F) :: M  ->
                                    n |-cc F :: B ; M ->
                                                    S n |-cc B ; L

| sig2hcc_bang : forall B F L n, L =mul= [! F] ->
                                 n |-cc  B ; [F] ->
                                             S n |-cc  B ; L
where "n |-cc B ; L" := (sig2hcc n B L).

Lemma sig2hcc_der_compat : forall n (B1 B2 L1 L2 : list lexp), B1 =mul= B2 -> L1 =mul= L2 -> n |-cc B1 ; L1 -> n |-cc B2 ; L2.
Proof.
  intros n B1 B2 L1 L2 PB PL H.
  revert L1 L2 PL B1 B2 PB H;
    induction n using strongind; intros.
  - inversion H; subst.
    +
      refine (sig2hcc_init _ (transitivity (symmetry PL) H0)).
    +
      refine (sig2hcc_one _ (transitivity (symmetry PL) H0)).
    +
      refine (sig2hcc_top _ (transitivity (symmetry PL) H0)).
  - inversion H0; subst; try rewrite PL in H3; try rewrite PL in H2;
      try rewrite PB in H3; try rewrite PB in H2.
    +
      refine (sig2hcc_bot H2 _); auto.
      apply H with (L1:= M) (B1:=B1); auto.
    +
      refine (sig2hcc_par H2 _); auto.
      apply H with (L1:= F :: G :: M) (B1:=B1); auto.
    +
      refine (sig2hcc_cut H2 _ _).
      eapply H with (L1:= F :: M) (B1:=B1); auto.
      eapply H with (L1:= F° :: N) (B1:=B1); auto.
    +
      refine (sig2hcc_ccut H2 _ _).
      eapply H with (L1:= (! F) :: M) (B1:=B1); auto.
      eapply H with (L1:=N) (B1:= F° :: B1); auto.
    +
      refine (sig2hcc_tensor H2 _ _).
      apply H with (L1:= F :: M) (B1:=B1); auto.
      apply H with (L1:= G :: N) (B1:=B1); auto.
    +
      refine (sig2hcc_plus1 H2 _).
      apply H with (L1:= F :: M) (B1:=B1); auto.
    +
      refine (sig2hcc_plus2 H2 _).
      apply H with (L1:= G :: M) (B1:=B1); auto.
    +
      refine (sig2hcc_with H2 _ _).
      apply H with (L1:= F :: M) (B1:=B1); auto.
      apply H with (L1:= G :: M) (B1:=B1); auto.
    +
      refine (sig2hcc_copy H2 H3 _).
      apply H with (L1:= L) (B1:=B1); auto.
    +
      refine (sig2hcc_quest H2 _).
      apply H with (L1:= M) (B1:= F :: B1); auto.
    +
      refine (sig2hcc_bang H2 _).
      apply H with (L1:= [F]) (B1:=B1); auto.
Qed.

Generalizable All Variables.
Instance sig2hcc_der_morphism :
  Proper (meq ==> meq ==> iff) (sig2hcc n).
Proof.
  unfold Proper; unfold respectful.
  intros n B1 B2 PB L1 L2 PL.
  split; intro H.
  refine (sig2hcc_der_compat PB PL H).
  refine (sig2hcc_der_compat (symmetry PB) (symmetry PL) H).
Qed.

Reserved Notation " n '|~>' m ';' B ';' L" (at level 80).

Inductive sig3: nat -> nat -> list lexp -> list lexp -> Prop :=
| sig3_init : forall (B L: list lexp) A, L =mul= (A ⁺) :: [A ⁻] -> 0 |~> 0 ; B ; L
| sig3_one : forall (B L: list lexp), L =mul= [1] -> 0 |~> 0 ; B ; L
| sig3_top : forall (B L M: list lexp), L =mul= Top :: M -> 0 |~> 0 ; B ; L
| sig3_bot : forall (B L M: list lexp) n c, L =mul= Bot :: M -> n |~> c ; B ; M -> S n |~> c ; B ; L
| sig3_par : forall (B L M: list lexp) F G n c, L =mul= (F $ G) :: M -> n |~> c ; B ; F :: G :: M -> S n |~> c ;B ; L
| sig3_tensor : forall (B L M N: list lexp) F G n m c1 c2, L =mul= (F ** G) :: (M ++ N) -> m |~> c1 ; B ; F :: M -> n |~> c2 ; B ; G :: N -> S (max n m)  |~> c1+c2 ;B ; L
| sig3_plus1: forall (B L M: list lexp) F G n c, L =mul= (F ⊕ G) :: M -> n |~> c ; B ; F :: M -> S n |~> c ; B ; L
| sig3_plus2: forall (B L M: list lexp) F G n c, L =mul= (F ⊕ G) :: M -> n |~> c ; B ; G :: M -> S n |~> c ; B ; L
| sig3_with: forall (B L M: list lexp) F G n m c1 c2, L =mul= (F & G) :: M -> m |~> c1 ; B ; F :: M ->
                                                                                n |~> c2 ; B ; G :: M -> S (max n m) |~> c1 + c2; B ; L
| sig3_copy: forall (B L M D: list lexp) F n c, D =mul= F :: B -> L =mul= F :: M -> n |~> c; D ; L -> S n |~> c ; D ; M
| sig3_quest : forall (B L M: list lexp) F n c, L =mul= (? F) :: M  -> n |~> c; F :: B ; M -> S n |~> c; B ; L
| sig3_bang : forall (B L: list lexp) F n c, L =mul= [! F] -> n |~>  c; B ; [F] -> S n |~> c ; B ; L
| sig3_CUT : forall (B L: list lexp) n c w h, sig3_cut_general w h n c B L -> S n |~> S c ; B ; L

with
sig3_cut_general : nat -> nat -> nat -> nat -> list lexp -> list lexp -> Prop :=
| sig3_cut : forall (B L M N: list lexp) F m n c1 c2 w h,
    w = lexp_weight F ->
    h = m + n ->
    L =mul= (M ++ N) ->
    m |~> c1 ; B ; F :: M ->
                   n |~> c2 ; B ; F° :: N ->
                                  sig3_cut_general w h (max n m) (c1 + c2) B L
| sig3_ccut : forall (B L M N: list lexp) F m n c1 c2 w h,
    w = lexp_weight (! F) ->
    h = m + n ->
    L =mul= (M ++ N) ->
    m |~> c1 ; B ; (! F) :: M ->
                   n |~> c2 ; F° :: B ; N ->
                                        sig3_cut_general w h (max n m) (c1 + c2) B L
where "n |~> m ; B ; L" := (sig3 n m B L).

Notation " n '~>' m ';' w ';' h ';' B ';' L"
  := (sig3_cut_general w h n m B L) (at level 80).

Arguments sig3_plus1 [B L M F G n c].

Lemma sig3_der_compat : forall n c (B1 B2 L1 L2: list lexp),
    B1 =mul= B2 -> L1 =mul= L2 -> n |~> c ; B1 ; L1 -> n |~> c ; B2 ; L2.
Proof.
  intros n c B1 B2 L1 L2 PB PL H.
  revert dependent L1;
    revert dependent L2;
    revert dependent B1;
    revert dependent B2;
    revert dependent c;
    induction n using strongind; intros.
  - inversion H; subst.
    refine (sig3_init _ (transitivity (symmetry PL) H0)).
    refine (sig3_one _ (transitivity (symmetry PL) H0)).
    refine (sig3_top _ (transitivity (symmetry PL) H0)).

  - inversion H0; subst; try rewrite PL in H3; try rewrite PL in H2;
      try rewrite PB in H3; try rewrite PB in H2.
    +
      refine (sig3_bot H2 _); auto.
      apply H with (L1:= M) (B1:=B1); auto.
    +
      refine (sig3_par H2 _); auto.
      apply H with (L1:= F :: G :: M) (B1:=B1); auto.
    +
      refine (sig3_tensor H2 _ _).
      apply H with (L1:= F :: M) (B1:=B1); auto.
      apply H with (L1:= G :: N) (B1:=B1); auto.
    +
      refine (sig3_plus1 H2 _).
      apply H with (L1:= F :: M) (B1:=B1); auto.
    +
      refine (sig3_plus2 H2 _).
      apply H with (L1:= G :: M) (B1:=B1); auto.
    +
      refine (sig3_with H2 _ _).
      apply H with (L1:= F :: M) (B1:=B1); auto.
      apply H with (L1:= G :: M) (B1:=B1); auto.
    +
      refine (sig3_copy H2 H3 _).
      apply H with (L1:= L) (B1:=B1); auto.
    +
      refine (sig3_quest H2 _).
      apply H with (L1:= M) (B1:= F :: B1); auto.
    +
      refine (sig3_bang H2 _).
      apply H with (L1:= [F]) (B1:=B1); auto.
    +
      inversion H2; subst.
      ++
        eapply sig3_CUT.
        eapply sig3_cut with (F:=F); [ auto | auto | | |].
        rewrite <- PL. exact H4.
        apply H with (L1:= F :: M) (B1:=B1); auto.
        apply H with (L1:= F° :: N) (B1:=B1); auto.
      ++
        eapply sig3_CUT.
        eapply sig3_ccut with (F:=F) (M:=M) (N:=N) ; [ auto | auto | | | ].
        rewrite <- PL. exact H4.
        eapply H with (L1:= (! F) :: M) (B1:=B1); auto.
        apply H with (L1:= N) (B1:= F° :: B1); auto.
Qed.

Generalizable All Variables.
Instance sig3_der_morphism :
  Proper (meq ==> meq ==> iff) (sig3 n c).
Proof.
  unfold Proper; unfold respectful.
  intros n c B1 B2 PB L1 L2 PL.
  split; intro H.
  refine (sig3_der_compat PB PL H).
  refine (sig3_der_compat (symmetry PB) (symmetry PL) H).
Qed.

Hint Constructors sig2h.
Hint Constructors sig2hc.
Hint Constructors sig2hcc.
Hint Constructors sig3.

Theorem sig2_iff_sig2h :  forall B L, |-- B ; L <-> exists m, m |-- B ; L .
Proof.
  split; intros.
  *
    induction H; try destruct IHsig2; try destruct IHsig2_1; try destruct IHsig2_2;
      eexists;
      [eapply sig2h_init; eassumption |
       eapply sig2h_one; eassumption |
       eapply sig2h_top; eassumption |
       eapply sig2h_bot; eassumption |
       eapply sig2h_par; eassumption |
       eapply sig2h_tensor; eassumption |
       eapply sig2h_plus1; eassumption |
       eapply sig2h_plus2; eassumption |
       eapply sig2h_with; eassumption |
       eapply sig2h_copy; eassumption |
       eapply sig2h_quest; eassumption |
       eapply sig2h_bang; eassumption].
  *
    destruct H.
    revert B L H.
    induction x using strongind; intros B L Hsig2h.
    inversion Hsig2h; subst;
      [eapply sig2_init; eassumption |
       eapply sig2_one; eassumption |
       eapply sig2_top; eassumption ].
    inversion Hsig2h; subst.
    assert (|-- B; M) by solve [eapply H; auto].
    eapply sig2_bot; eassumption.
    assert (|-- B; F :: G :: M) by solve [eapply H; auto].
    eapply sig2_par; eassumption.
    assert (|-- B; F :: M) by solve [eapply H with (m0:=m); auto].
    assert (|-- B; G :: N) by solve [eapply H with (m0:=n); auto].
    eapply sig2_tensor; eassumption.
    assert (|--  B; F :: M) by solve [eapply H; auto].
    eapply sig2_plus1; eassumption.
    assert (|--  B; G :: M) by solve [eapply H; auto].
    eapply sig2_plus2; eassumption.
    assert (|-- B; F :: M) by solve [eapply H with (m0:=m); auto].
    assert (|-- B; G :: M) by solve [eapply H with (m0:=n); auto].
    eapply sig2_with; eassumption.
    assert (|--  B; L0) by solve [eapply H; auto].
    eapply sig2_copy ; eassumption.
    assert (|-- F :: B; M) by solve [eapply H; auto].
    eapply sig2_quest; eassumption.
    assert (|-- B; [F]) by solve [eapply H; auto].
    eapply sig2_bang; eassumption.
Qed.

Theorem sig2hc_then_sig2hcc: forall n B L, sig2hc n B L -> sig2hcc n B L.
Proof.
  intros.
  induction H.
  eapply sig2hcc_init; eassumption.
  eapply sig2hcc_one; eassumption.
  eapply sig2hcc_top; eassumption.
  eapply sig2hcc_bot; eassumption.
  eapply sig2hcc_par; eassumption.
  eapply sig2hcc_cut; eassumption.
  eapply sig2hcc_tensor; eassumption.
  eapply sig2hcc_plus1; eassumption.
  eapply sig2hcc_plus2; eassumption.
  eapply sig2hcc_with; eassumption.
  eapply sig2hcc_copy; eassumption.
  eapply sig2hcc_quest; eassumption.
  eapply sig2hcc_bang; eassumption.
Qed.

Theorem sig2hcc_then_sig2hc: forall n B L, sig2hcc n B L -> exists m, sig2hc m B L.
Proof.
  intros.
  induction H; try destruct IHsig2hcc; try destruct IHsig2hcc1; try destruct IHsig2hcc2;
    eexists.
  eapply sig2hc_init; eassumption.
  eapply sig2hc_one; eassumption.
  eapply sig2hc_top; eassumption.
  eapply sig2hc_bot; eassumption.
  eapply sig2hc_par; eassumption.
  eapply sig2hc_cut; eassumption.
  eapply sig2hc_cut with (F:=!F) (M:=M) (N:=N) (m:=x); auto.
  eapply sig2hc_quest with (F:=F°); eauto.
  eapply sig2hc_tensor; eassumption.
  eapply sig2hc_plus1; eassumption.
  eapply sig2hc_plus2; eassumption.
  eapply sig2hc_with; eassumption.
  eapply sig2hc_copy; eassumption.
  eapply sig2hc_quest; eassumption.
  eapply sig2hc_bang; eassumption.
Qed.

Theorem sig2hc_iff_sig2hcc: forall B L, (exists n, sig2hc n B L) <-> exists m, sig2hcc m B L.
Proof.
  split; intros.
  *
    destruct H.
    eexists.
    apply sig2hc_then_sig2hcc; eauto.
  *
    destruct H.
    eapply sig2hcc_then_sig2hc; eauto.
Qed.

Theorem sig2hcc_then_sig3 :  forall B L n,
    n |-cc B ; L -> exists c, n |~> c ; B ; L.
Proof.
  intros.
  revert dependent B;
    revert dependent L.
  induction n using strongind; intros L B Hyp.
  **
    inversion Hyp; subst; eexists.
    eapply sig3_init; eassumption.
    eapply sig3_one; eassumption.
    eapply sig3_top; eassumption.
  **
    inversion Hyp; subst.
    ***
      assert (exists c : nat, n |~> c ; B; M) as Hn by solve [eapply H; auto].
      destruct Hn.
      eexists.
      refine (sig3_bot H1 H0).
    ***
      assert (exists c : nat, n |~> c ; B; F :: G :: M) as Hn by solve [eapply H; auto].
      destruct Hn.
      eexists.
      refine (sig3_par H1 H0).
    ***
      assert (exists c : nat, m |~> c ; B; F :: M) as Hn1 by solve [eapply H; auto].
      assert (exists c : nat, n0 |~> c ; B; F° :: N) as Hn2 by solve [eapply H; auto].
      destruct Hn1, Hn2.
      eexists.
      eapply sig3_CUT.
      refine (sig3_cut _ _ _ H0 H4); auto.
    ***
      assert (exists c : nat, m |~> c ; B; (! F) :: M) as Hn1 by solve [eapply H; auto].
      assert (exists c : nat, n0 |~> c ; F° :: B; N) as Hn2 by solve [eapply H; auto].
      destruct Hn1, Hn2.
      eexists.
      eapply sig3_CUT.
      refine (sig3_ccut _ _ _ H0 H4); auto.
    ***
      assert (exists c : nat, m |~> c ; B; F :: M) as Hn1 by solve [eapply H; auto].
      assert (exists c : nat, n0 |~> c ; B; G :: N) as Hn2 by solve [eapply H; auto].
      destruct Hn1, Hn2.
      eexists.
      refine (sig3_tensor H1 H0 H4).
    ***
      assert (exists c : nat, n |~> c ; B; F :: M) as Hn by solve [eapply H; auto].
      destruct Hn.
      eexists.
      refine (sig3_plus1 H1 H0).
    ***
      assert (exists c : nat, n |~> c ; B; G :: M) as Hn by solve [eapply H; auto].
      destruct Hn.
      eexists.
      refine (sig3_plus2 H1 H0).
    ***
      assert (exists c : nat, m |~> c ; B; F :: M) as Hn1 by solve [eapply H; auto].
      assert (exists c : nat, n0 |~> c ; B; G :: M) as Hn2 by solve [eapply H; auto].
      destruct Hn1, Hn2.
      eexists.
      refine (sig3_with H1 H0 H4).
    ***
      assert (exists c : nat, n |~> c ; B; L0) as Hn by solve [eapply H; auto].
      destruct Hn.
      eexists.
      rewrite H2 in H0.
      refine (sig3_copy H1 _ H0); auto.
    ***
      assert (exists c : nat, n |~> c ; F :: B; M) as Hn by solve [eapply H; auto].
      destruct Hn.
      eexists.
      refine (sig3_quest H1 H0).
    ***
      assert (exists c : nat, n |~> c ; B; [F]) as Hn by solve [eapply H; auto].
      destruct Hn.
      eexists.
      refine (sig3_bang H1 H0).
Qed.

Theorem sig3_then_sig2hcc :  forall B L n c,
    n |~> c ; B ; L  -> n |-cc B ; L.
Proof.
  intros.
  revert dependent B;
    revert dependent L;
    revert dependent c.
  induction n using strongind; intros c L B Hyp.
  **
    inversion Hyp; subst.
    eapply sig2hcc_init; eassumption.
    eapply sig2hcc_one; eassumption.
    eapply sig2hcc_top; eassumption.
  **
    inversion Hyp; subst.
    ***
      assert (n |-cc B; M) as Hc by
            solve [eapply H; auto; eassumption].
      refine (sig2hcc_bot H1 _); auto.
    ***
      assert (n |-cc B; F :: G :: M) as Hc by
            solve [eapply H; auto; eassumption].
      refine (sig2hcc_par H1 _); auto.
    ***
      assert (m |-cc B; F :: M) as Hc1 by
            solve [eapply H; auto; eassumption].
      assert (n0 |-cc B; G :: N) as Hc2 by
            solve [eapply H; auto; eassumption].
      refine (sig2hcc_tensor H1 Hc1 Hc2).
    ***
      assert (n |-cc B; F :: M) as Hc by
            solve [eapply H; auto; eassumption].
      refine (sig2hcc_plus1 H1 Hc).
    ***
      assert (n |-cc B; G :: M) as Hc by
            solve [eapply H; auto; eassumption].
      refine (sig2hcc_plus2 H1 Hc).
    ***
      assert (m |-cc B; F :: M) as Hc1 by
            solve [eapply H; auto; eassumption].
      assert (n0 |-cc B; G :: M) as Hc2 by
            solve [eapply H; auto; eassumption].
      refine (sig2hcc_with H1 Hc1 Hc2).
    ***
      assert (n |-cc B; L0) as Hc by
            solve [eapply H; auto; eassumption].
      refine (sig2hcc_copy H1 H2 Hc).
    ***
      assert (n |-cc F :: B; M) as Hc by
            solve [eapply H; auto; eassumption].
      refine (sig2hcc_quest H1 Hc).
    ***
      assert (n |-cc B; [F]) as Hc by
            solve [eapply H; auto; eassumption].
      refine (sig2hcc_bang H1 Hc).
    ***
      inversion H1; subst.
      assert (m |-cc B; F :: M) as Hc1 by
            solve [eapply H; auto; eassumption].
      assert (n0 |-cc B; F° :: N) as Hc2 by
            solve [eapply H; auto; eassumption].
      refine (sig2hcc_cut H3 Hc1 Hc2).

      assert (m |-cc B; (! F) :: M) as Hc1 by
            solve [eapply H; auto; eassumption].
      assert (n0 |-cc F° :: B; N) as Hc2 by
            solve [eapply H; auto; eassumption].
      refine (sig2hcc_ccut _ Hc1 Hc2); auto.
Qed.

Theorem sig3_iff_sig2hcc :  forall B L,
    (exists n c, n |~> c ; B ; L) <-> exists m, m |-cc B ; L.
Proof.
  split; intros.
  *
    do 2 destruct H.
    eexists.
    eapply sig3_then_sig2hcc; eauto.
  *
    destruct H.
    eexists.
    eapply sig2hcc_then_sig3; eauto.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Compare.
Require Import Rbase.
Require Import Rfunctions.
Require Import Rseries.
Require Import PartSum.
Require Import Binomial.
Require Import Omega.
Local Open Scope R_scope.

(** TT Ak; 0<=k<=N *)
Fixpoint prod_f_R0 (f:nat -> R) (N:nat) : R :=
  match N with
    | O => f O
    | S p => prod_f_R0 f p * f (S p)
  end.

Notation prod_f_SO := (fun An N => prod_f_R0 (fun n => An (S n)) N).

(**********)
Lemma prod_SO_split :
  forall (An:nat -> R) (n k:nat),
    (k < n)%nat ->
    prod_f_R0 An n =
    prod_f_R0 An k * prod_f_R0 (fun l:nat => An (k +1+l)%nat) (n - k -1).
Proof.
  intros; induction  n as [| n Hrecn].
  absurd (k < 0)%nat; omega.
  cut (k = n \/ (k < n)%nat);[intro; elim H0; intro|omega].
  replace (S n - k - 1)%nat with O; [rewrite H1; simpl|omega].
  replace (n+1+0)%nat with (S n); ring.
  replace (S n - k-1)%nat with (S (n - k-1));[idtac|omega].
  simpl; replace (k + S (n - k))%nat with (S n).
  replace (k + 1 + S (n - k - 1))%nat with (S n).
  rewrite Hrecn; [ ring | assumption ].
  omega.
  omega.
Qed.

(**********)
Lemma prod_SO_pos :
  forall (An:nat -> R) (N:nat),
    (forall n:nat, (n <= N)%nat -> 0 <= An n) -> 0 <= prod_f_R0 An N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl; apply H; trivial.
  simpl; apply Rmult_le_pos.
  apply HrecN; intros; apply H; apply le_trans with N;
    [ assumption | apply le_n_Sn ].
  apply H; apply le_n.
Qed.

(**********)
Lemma prod_SO_Rle :
  forall (An Bn:nat -> R) (N:nat),
    (forall n:nat, (n <= N)%nat -> 0 <= An n <= Bn n) ->
    prod_f_R0 An N <= prod_f_R0 Bn N.
Proof.
  intros; induction  N as [| N HrecN].
  elim  H with O; trivial.
  simpl; apply Rle_trans with (prod_f_R0 An N * Bn (S N)).
  apply Rmult_le_compat_l.
  apply prod_SO_pos; intros; elim (H n (le_trans _ _ _ H0 (le_n_Sn N))); intros;
    assumption.
  elim (H (S N) (le_n (S N))); intros; assumption.
  do 2 rewrite <- (Rmult_comm (Bn (S N))); apply Rmult_le_compat_l.
  elim (H (S N) (le_n (S N))); intros.
  apply Rle_trans with (An (S N)); assumption.
  apply HrecN; intros; elim (H n (le_trans _ _ _ H0 (le_n_Sn N))); intros;
    split; assumption.
Qed.

(** Application to factorial *)
Lemma fact_prodSO :
  forall n:nat, INR (fact n) = prod_f_R0 (fun k:nat =>
     (match (eq_nat_dec k 0) with
          | left   _ => 1%R
          | right _ => INR k
                        end)) n.
Proof.
  intro; induction  n as [| n Hrecn].
  reflexivity.
  simpl; rewrite <- Hrecn.
  case n; auto with real.
  intros; repeat rewrite plus_INR;rewrite mult_INR;ring.
Qed.

Lemma le_n_2n : forall n:nat, (n <= 2 * n)%nat.
Proof.
  simple induction n.
  replace (2 * 0)%nat with 0%nat; [ apply le_n | ring ].
  intros; replace (2 * S n0)%nat with (S (S (2 * n0))).
  apply le_n_S; apply le_S; assumption.
  replace (S (S (2 * n0))) with (2 * n0 + 2)%nat; [ idtac | ring ].
  replace (S n0) with (n0 + 1)%nat; [ idtac | ring ].
  ring.
Qed.

(** We prove that (N!)^2<=(2N-k)!*k! forall k in [|O;2N|] *)
Lemma RfactN_fact2N_factk :
  forall N k:nat,
    (k <= 2 * N)%nat ->
    Rsqr (INR (fact N)) <= INR (fact (2 * N - k)) * INR (fact k).
Proof.
  assert (forall (n:nat), 0 <= (if eq_nat_dec n 0 then 1 else INR n)).
  intros; case (eq_nat_dec n 0); auto with real.
  assert (forall (n:nat), (0 < n)%nat ->
     (if eq_nat_dec n 0 then 1 else INR n) = INR n).
  intros n; case (eq_nat_dec n 0); auto with real.
  intros; absurd (0 < n)%nat; omega.
  intros; unfold Rsqr; repeat rewrite fact_prodSO.
  cut ((k=N)%nat \/ (k < N)%nat \/ (N < k)%nat).
  intro H2; elim H2; intro H3.
  rewrite H3; replace (2*N-N)%nat with N;[right; ring|omega].
  case H3; intro; clear H2 H3.
  rewrite (prod_SO_split (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) (2 * N - k) N).
  rewrite Rmult_assoc; apply Rmult_le_compat_l.
  apply prod_SO_pos; intros; auto.
  replace (2 * N - k - N-1)%nat with (N - k-1)%nat.
  rewrite Rmult_comm; rewrite (prod_SO_split
        (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) N k).
  apply Rmult_le_compat_l.
  apply prod_SO_pos; intros; auto.
  apply prod_SO_Rle; intros; split; auto.
  rewrite H0.
  rewrite H0.
  apply le_INR; omega.
  omega.
  omega.
  assumption.
  omega.
  omega.
  rewrite <- (Rmult_comm (prod_f_R0 (fun l:nat =>
          if eq_nat_dec l 0 then 1 else INR l) k));
    rewrite (prod_SO_split (fun l:nat =>
          if eq_nat_dec l 0 then 1 else INR l) k N).
  rewrite Rmult_assoc; apply Rmult_le_compat_l.
  apply prod_SO_pos; intros; auto.
  rewrite Rmult_comm;
    rewrite (prod_SO_split (fun l:nat =>
          if eq_nat_dec l 0 then 1 else INR l) N (2 * N - k)).
  apply Rmult_le_compat_l.
  apply prod_SO_pos; intros; auto.
  replace (N - (2 * N - k)-1)%nat with (k - N-1)%nat.
  apply prod_SO_Rle; intros; split; auto.
  rewrite H0.
  rewrite H0.
  apply le_INR; omega.
  omega.
  omega.
  omega.
  omega.
  assumption.
  omega.
Qed.

(**********)
Lemma INR_fact_lt_0 : forall n:nat, 0 < INR (fact n).
Proof.
  intro; apply lt_INR_0; apply neq_O_lt; red; intro;
    elim (fact_neq_0 n); symmetry ; assumption.
Qed.

(** We have the following inequality : (C 2N k) <= (C 2N N) forall k in [|O;2N|] *)
Lemma C_maj : forall N k:nat, (k <= 2 * N)%nat -> C (2 * N) k <= C (2 * N) N.
Proof.
  intros; unfold C; unfold Rdiv; apply Rmult_le_compat_l.
  apply pos_INR.
  replace (2 * N - N)%nat with N.
  apply Rmult_le_reg_l with (INR (fact N) * INR (fact N)).
  apply Rmult_lt_0_compat; apply INR_fact_lt_0.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_comm;
    apply Rmult_le_reg_l with (INR (fact k) * INR (fact (2 * N - k))).
  apply Rmult_lt_0_compat; apply INR_fact_lt_0.
  rewrite Rmult_1_r; rewrite <- mult_INR; rewrite <- Rmult_assoc;
    rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l; rewrite mult_INR; rewrite (Rmult_comm (INR (fact k)));
    replace (INR (fact N) * INR (fact N)) with (Rsqr (INR (fact N))).
  apply RfactN_fact2N_factk.
  assumption.
  reflexivity.
  rewrite mult_INR; apply prod_neq_R0; apply INR_fact_neq_0.
  apply prod_neq_R0; apply INR_fact_neq_0.
  omega.
Qed.


(** * Option-List (OList) *)

(* TODO: edit imports. *)
Require Import Bool.
Require Import List.
Import ListNotations.
Require Import Basics.

Module OList.

(** Dimensions and configurations. *)
Definition dim := nat.
Definition tag := bool.
Definition L : tag := true.
Definition R : tag := false.
Definition config := dim -> tag.

(** Formula syntax. *)
Inductive formula : Type :=
  | litT : tag -> formula
  | litD : dim -> formula
  | comp : formula -> formula
  | join : formula -> formula -> formula
  | meet : formula -> formula -> formula.

(* TODO: add scope to notation. *)
Notation "~ x" := (comp x) (at level 75, right associativity).
Infix "\/" := join (at level 85, right associativity).
Infix "/\" := meet (at level 80, right associativity).

(** Formula semantics. *)
Fixpoint semf (x : formula) (c : config) : tag :=
  match x with
  | litT t   => t
  | litD d   => c d
  | ~ x      => negb (semf x c)
  | x1 \/ x2 => (semf x1 c) || (semf x2 c)
  | x1 /\ x2 => (semf x1 c) && (semf x2 c)
  end.

(** Variational option definition. *)
Inductive var : Type :=
  | one : option nat -> var
  | chc : formula -> var -> var -> var.

(** Selection operation for variational option. *)
Fixpoint vsel (c : config) (v : var) : option nat :=
  match v with
  | one o      => o
  | chc x l r  => if semf x c then vsel c l else vsel c r
  end.

(** Option-list definition. *)
Definition olist := list var.

(** Selection operation for option-list. *)
Fixpoint osel (c : config) (o : olist) : list nat :=
  match o with
  | []     => []
  | h :: t => match vsel c h with
              | None   => osel c t
              | Some y => y :: osel c t
              end
  end.

(** ** Map *)
(** Definition of map operation for option-list and a formal proof of
    soundness. *)
Section Map.

(** Helper function of map operation for option-list. *)
Fixpoint hmap (f : nat -> nat) (v : var) : var :=
  match v with
  | one None     => one None
  | one (Some n) => one (Some (f n))
  | chc x l r    => chc x (hmap f l) (hmap f r)
  end.

(** Map operation for option-list. *)
Fixpoint omap (f : nat -> nat) (o : olist) : olist :=
  match o with
  | []     => []
  | h :: t => hmap f h :: omap f t
  end.

(* Lemma used in proof of [omap_sound]. *)
Lemma vsel_none : forall (c : config) (f : nat -> nat) (e : var),
                  vsel c e = None ->
                  vsel c (hmap f e) = None.
Proof.
  intros c f e H.
  induction e as [o | x l IHl r IHr].
  (* Case: [e = one o]. *)
    destruct o as [n |].
    (* Subcase: [o = Some n]. *)
      simpl vsel in H.
      inversion H.
    (* Subcase: [o = None]. *)
      reflexivity.
  (* Case: [e = chc x l r]. *)
    simpl.
    simpl in H.
    destruct (semf x c).
    (* Subcase: [semf x c = L]. *)
      rewrite -> IHl by apply H.
      reflexivity.
    (* Subcase: [semf x c = R]. *)
      rewrite -> IHr by apply H.
      reflexivity.
Qed.

(* Lemma used in proof of [omap_sound]. *)
Lemma vsel_some : forall (c : config) (f : nat -> nat) (e : var) (n : nat),
                  vsel c e = Some n ->
                  vsel c (hmap f e) = Some (f n).
Proof.
  intros c f e n H.
  induction e as [o | x l IHl r IHr].
  (* Case: [e = one o]. *)
    destruct o as [n' |].
    (* Subcase: [o = Some n']. *)
      simpl vsel in H.
      inversion H.
      reflexivity.
    (* Subcase: [o = None]. *)
      simpl vsel in H.
      inversion H.
  (* Case: [e = chc x l r]. *)
    simpl.
    simpl in H.
    destruct (semf x c).
    (* Subcase: [semf x c = L]. *)
      rewrite -> IHl by apply H.
      reflexivity.
    (* Subcase: [semf x c = R]. *)
      rewrite -> IHr by apply H.
      reflexivity.
Qed.

Infix "*" := compose.

(** The map operation for option-list is sound. *)
Theorem omap_sound : forall (c : config) (f : nat -> nat) (o : olist),
                       (osel c * omap f) o = (map f * osel c) o.
Proof.
  intros c f o.
  unfold compose.
  induction o as [| h t IH].
  (* Case: [o = nil]. *)
    reflexivity.
  (* Case: [o = cons h t]. *)
    simpl omap.
    destruct (vsel c h) as [n |] eqn : H.
    (* Subcase: [vsel c h = Some n]. *)
      simpl osel.
      rewrite -> vsel_some with (n := n) by apply H.
      rewrite -> H.
      simpl map.
      rewrite -> IH.
      reflexivity.
    (* Subcase: [vsel c h = None]. *)
      simpl osel.
      rewrite -> vsel_none by apply H.
      rewrite -> H.
      apply IH.
Qed.

End Map.

(** ** Bind *)
(** Definition of bind operation for option-list and a formal proof of
    soundness. *)
Section Bind.

(** Helper function of bind operation for option-list. *)
Fixpoint hzip (x : formula) (o o' : olist) : olist :=
  match o, o' with
  | [], _            => map (fun v : var => chc x (one None) v) o'
  | _, []            => map (fun v : var => chc x v (one None)) o
  | h :: t, h' :: t' => chc x h h' :: hzip x t t'
  end.

(** Helper function of bind operation for option-list. *)
Fixpoint hbind (f : nat -> olist) (v : var) : olist :=
  match v with
  | one None     => []
  | one (Some n) => f n
  | chc x l r    => hzip x (hbind f l) (hbind f r)
  end.

(** Bind operation for option-list. *)
Fixpoint obind (f : nat -> olist) (o : olist) : olist :=
  match o with
  | []     => []
  | h :: t => hbind f h ++ obind f t
  end.

(** Lemma used to simplify goals in later proofs. *)
Lemma osel_cons_chc_l :
  forall (c : config) (x : formula) (l r : var) (o : olist),
  semf x c = L ->
  osel c (chc x l r :: o) = osel c (l :: o).
Proof.
  intros c x l r o H.
  simpl.
  rewrite -> H.
  reflexivity.
Qed.

(** Lemma used to simplify goals in later proofs. *)
Lemma osel_cons_chc_r :
  forall (c : config) (x : formula) (l r : var) (o : olist),
  semf x c = R ->
  osel c (chc x l r :: o) = osel c (r :: o).
Proof.
  intros c x l r o H.
  simpl.
  rewrite -> H.
  reflexivity.
Qed.

(** Selection for option-list distributes over append. *)
Lemma osel_app : forall (c : config) (o o' : olist),
                 osel c (o ++ o') = osel c o ++ osel c o'.
Proof.
  intros c o o'.
  induction o as [| h t IH].
  (* Case: [o = nil]. *)
    reflexivity.
  (* Case: [o = cons h t]. *)
    simpl.
    destruct (vsel c h) as [n |].
    (* Subcase: [vsel c h = Some n]. *)
      rewrite <- app_comm_cons.
      rewrite -> IH.
      reflexivity.
    (* Subcase: [vsel c h = None]. *)
      apply IH.
Qed.

(** Lemma used to simplify goals in later proofs. *)
Lemma ozip_nil_l : forall (x : formula) (o : olist),
                   hzip x [] o = map (fun v : var => chc x (one None) v) o.
Proof.
  destruct o;
    unfold hzip;
    reflexivity.
Qed.

(** Lemma used to simplify goals in later proofs. *)
Lemma ozip_nil_r : forall (x : formula) (o : olist),
                   hzip x o [] = map (fun v : var => chc x v (one None)) o.
Proof.
  destruct o;
    unfold hzip;
    reflexivity.
Qed.

(** Lemma used to simplify goals in later proofs. *)
Lemma osel_ozip_l : forall (c : config) (x : formula),
                    semf x c = L ->
                    forall o o' : olist, osel c (hzip x o o') = osel c o.
Proof.
  intros c x H.
  assert (H' : forall o : olist, osel c (hzip x [] o) = []).
  (* Proof of assertion [H']. *)
    intro o.
    induction o as [| h t IH].
    (* Case: [o = nil]. *)
      reflexivity.
    (* Case: [o = cons h t]. *)
      rewrite -> ozip_nil_l.
      simpl map.
      rewrite -> osel_cons_chc_l by apply H.
      simpl.
      rewrite <- ozip_nil_l.
      apply IH.
  (* Proof of [osel_ozip_l]. *)
  intro o.
  induction o as [| h t IH].
  (* Case: [o = nil]. *)
    apply H'.
  (* Case: [o = cons h t]. *)
    destruct o' as [| h' t'];
      simpl hzip;
      rewrite -> osel_cons_chc_l by apply H;
      try (rewrite <- ozip_nil_r);
      destruct h as [o | y l r];
        try (destruct o);
        simpl;
        rewrite -> IH;
        reflexivity.
Qed.

(** Lemma used to simplify goals in later proofs. *)
Lemma osel_ozip_r : forall (c : config) (x : formula),
                    semf x c = R ->
                    forall o o' : olist,
                    osel c (hzip x o' o) = (osel c o).
Proof.
  intros c x H.
  assert (H' : forall o : olist, osel c (hzip x o []) = []).
  (* Proof of assertion [H']. *)
    intro o.
    induction o as [| h t IH].
    (* Case: [o = nil]. *)
      reflexivity.
    (* Case: [o = cons h t]. *)
      rewrite -> ozip_nil_r.
      simpl map.
      rewrite -> osel_cons_chc_r by apply H.
      simpl.
      rewrite <- ozip_nil_r.
      apply IH.
  (* Proof of [osel_ozip_r]. *)
  intros o.
  induction o as [| h t IH].
  (* Case: [o = nil]. *)
    apply H'.
  (* Case: [o = cons h t]. *)
    destruct o' as [| h' t'];
      simpl hzip;
      rewrite -> osel_cons_chc_r by apply H;
      try (rewrite <- ozip_nil_l);
      destruct h as [o | y l r];
        try (destruct o);
        simpl;
        try (rewrite <- ozip_nil_l);
        rewrite -> IH;
        reflexivity.
Qed.

Infix "*" := compose.

(** The bind operation for option-list is sound. *)
Theorem obind_sound : forall (c : config) (f : nat -> olist) (o : olist),
                        (osel c * obind f) o =
                        (flat_map (osel c * f) * osel c) o.
Proof.
  intros c f o.
  unfold compose.
  induction o as [| h t IH].
  (* Case: [o = nil]. *)
    reflexivity.
  (* Case: [o = cons h t]. *)
    simpl obind.
    rewrite -> osel_app.
    induction h as [o | x l IHl r IHr].
    destruct o.
    (* Subcase: [h = one (Some n)]. *)
      simpl.
      rewrite -> IH.
      reflexivity.
    (* Subcase: [h = one None]. *)
      simpl.
      apply IH.
    (* Subcase: [h = chc x l r]. *)
      simpl hbind.
      destruct (semf x c) eqn : H.
        rewrite -> osel_ozip_l by apply H.
        rewrite -> osel_cons_chc_l by apply H.
        apply IHl.
        rewrite -> osel_ozip_r by apply H.
        rewrite -> osel_cons_chc_r by apply H.
        apply IHr.
Qed.

End Bind.

End OList.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2007-02-08

number of occurrences of an element in a list
proof of the pigeon-hole principle
*)

Set Implicit Arguments.

From CoLoR Require Import ListUtil NatUtil LogicUtil.

(***********************************************************************)
(** number of occurrences *)

Section occur.

  Variables (A : Type) (eq_dec : forall x y : A, {x=y}+{~x=y}).

  Definition delta x y :=
    match eq_dec x y with
      | left _ => 1
      | right _ => 0
    end.

  Lemma eq_delta : forall x, delta x x = 1.

  Proof.
    intros. unfold delta. case (eq_dec x x); intro. refl. cong.
  Qed.

  Lemma neq_delta : forall x y, x <> y -> delta x y = 0.

  Proof.
    intros. unfold delta. case (eq_dec x y); intro. contr. refl.
  Qed.

  Fixpoint occur x (l : list A) : nat :=
    match l with
      | nil => O
      | y :: m => delta x y + occur x m
    end.

  Lemma occur_app : forall x l m, occur x (l ++ m) = occur x l + occur x m.

  Proof.
    induction l; simpl; intros. refl. rewrite IHl. unfold delta.
    case (eq_dec x a); intro; lia.
  Qed.

  Lemma in_occur : forall x l, In x l -> occur x l > 0.

  Proof.
    induction l; simpl; intros. contr. unfold delta.
    case (eq_dec x a); intro. lia. destruct H. subst a. cong. auto.
  Qed.

  Lemma notin_occur : forall x l, ~In x l -> occur x l = 0.

  Proof.
    induction l; simpl; intros. refl. unfold delta. case (eq_dec x a); intro.
    subst a. absurd (x=x \/ In x l). exact H. auto.
    apply IHl. intro. apply H. auto.
  Qed.

  Arguments notin_occur [x l] _.

  Lemma occur_in : forall x l, occur x l > 0 -> In x l.

  Proof. induction l; simpl. lia. unfold delta. case (eq_dec x a); auto. Qed.

  Arguments occur_in [x l] _.

  Lemma occur_notin : forall x l, occur x l = 0 -> ~In x l.

  Proof.
    induction l; simpl. do 2 intro. contr. unfold delta.
    case (eq_dec x a); intros.
    discr. intro. destruct H0. subst a. cong. intuition.
  Qed.

  Lemma occur_S : forall x l n, occur x l = S n ->
    exists m, exists p, l = m ++ x :: p /\ ~In x m /\ occur x p = n.

  Proof.
    intros. assert (occur x l > 0). lia. ded (occur_in H0).
    ded (in_elim_dec eq_dec H1). do 3 destruct H2. subst l.
    exists x0. exists x1. (* intuition makes occur untypable ! *)
    split. refl. split. exact H3.
    rewrite occur_app in H. simpl in H. rewrite eq_delta in H.
    ded (notin_occur H3). lia.
  Qed.

End occur.

Arguments in_occur [A] _ [x l] _.
Arguments notin_occur [A] _ [x l] _.
Arguments occur_S [A] _ [x l n] _.

(***********************************************************************)
(** pigeon-hole principle *)

Section pigeon_hole.

  Variables (A : Type) (eq_dec : forall x y : A, {x=y}+{~x=y}).

  Notation occur := (occur eq_dec).
  Notation delta := (delta eq_dec).

  Lemma pigeon_hole : forall s l,
    incl l s -> length l > length s -> exists x : A, occur x l >= 2.

  Proof.
    induction s; simpl; intros.
    (* case s=nil *)
    apply False_ind. destruct l. simpl in H0. lia.
    unfold incl in H. simpl in H. apply (H a). auto.
    (* case s=a::s *)
    destruct l. apply False_ind. simpl in H0. lia.
    case (In_dec eq_dec a0 l); intro. ded (in_occur eq_dec i).
    exists a0. simpl. rewrite eq_delta. lia.
    case (le_lt_dec (occur a l) 1); intro.
    (* case occur a l <= 1 *)
    ded (incl_cons_l H). clear H. destruct H1.
    ded (incl_cons_r H1). destruct H2.
    (* case In a l *)
    simpl in H. destruct H. subst a0. contr.
    ded (in_elim_dec eq_dec H2). do 3 destruct H3.
    (* ~In a x0 *)
    assert (~In a x0). apply (occur_notin eq_dec).
    rewrite H3, occur_app in l0. simpl in l0. rewrite eq_delta in l0. lia.
    (* x and x0 included in s *)
    rewrite H3 in H1. ded (incl_app_elim H1). clear H1. destruct H6.
    ded (incl_cons_r H1). clear H1. destruct H7. contr.
    ded (incl_cons_l H6). clear H6. destruct H7. clear H6.
    ded (incl_cons_r H7). clear H7. destruct H6. contr.
    (* l' = l - a + a0 *)
    set (l' := x ++ a0 :: x0).
    assert (incl l' s). unfold l'. apply incl_app. exact H1.
    apply incl_cons. exact H. exact H6.
    assert (length l' > length s). unfold l'. rewrite length_app. simpl.
    simpl in H0. rewrite H3, length_app in H0. simpl in H0. lia.
    ded (IHs l' H7 H8). destruct H9. exists x1.
    assert (occur x1 (a0::l) = occur x1 l' + delta x1 a). unfold l'. rewrite H3.
    simpl. rewrite !occur_app. simpl. lia. lia.
    (* incl l s *)
    assert (length l > length s). simpl in H0. lia.
    ded (IHs l H2 H3). destruct H4. exists x. simpl. lia.
    (* 1 < occur a l *)
    exists a. simpl. lia.
  Qed.

End pigeon_hole.


Load "ch3_ref".

(* Chapter 3 Exercises *)
Section Chapter_3_Exercises.

  (* Exercise 3.1 *)
  Lemma equiv_of_sets {A B : UU}
        (e : A ≃ B)
        (isA : isSet A)
  : isSet B.
  Proof. (* fill in here... *)
  Admitted.

  (* Exercise 3.2 *)
  Lemma coprod_isSet {A B : UU}
        (isA : isSet A) (isB : isSet B)
    : isSet (A+B)%type.
  Proof. (* fill in here... *)
  Admitted.

  (* Exercise 3.3 *)
  Lemma sig_isSet_exercise {A : UU} {B : A -> UU}
        (isA : isSet A) (isB : ∏ x:A, isSet (B x))
    : isSet (total B).
  Proof. (* fill in here... *)
  Admitted.

  (* Exercise 3.4 *)
  Lemma isProp_iff_automorphisms_isContr (A : UU)
    : (isProp A) <-> (isContr (A -> A)).
  Proof. (* fill in here... *)
  Admitted.

  (* Exercise 3.5 *)
  Lemma isProp_equiv_inhabited_implies_isContr (A : UU)
    : (isProp A) ≃ (A -> isContr A).
  Proof. (* fill in here... *)
  Admitted.

  (* Exercise 3.6. *)
  Lemma coprod_decision_isProp {A : UU}
    : (isProp A) -> (A + ¬A).
  Proof. (* fill in here... *)
  Admitted.

  (* Exercise 3.7 *)
  Lemma coprod_disjoint_isProp {A B : UU}
        (isA : isProp A) (isB : isProp B)
    : ¬(A×B) -> isProp (A + B)%type.
  Proof. (* fill in here... *)
  Admitted.

  (* Exercise 3.8 *)
  Lemma trunc_qinv_is_an_equivalence {A B : UU} (f : A -> B)
        (Eqv_f : UU) (* some equivalence type satisfying... *)
        (from_qinv : (qinv f) -> Eqv_f)
        (to_qinv   : Eqv_f -> (qinv f))
        (is        : isProp Eqv_f)
    : Σ (qfrom     : (qinv f) -> ∥ qinv f ∥)
        (qto       : ∥ qinv f ∥ -> (qinv f))
        (qis       : isProp (∥ qinv f ∥)),
      (Eqv_f ≃ ∥ qinv f ∥).
  Proof. (* fill in here... *)
  Admitted.

  (* Exercise 3.9 *)
  Lemma Props_are_true_or_false_assuming_LEM
        (LEM : LEM_Statement)
    : UProp ≃ 𝟚.
  Proof. (* fill in here... *)
  Admitted.

  (* Exercise 3.10 *)
  (* work on paper because it involves universes *)

  (* Exercise 3.11 *)
  Lemma truncation_cannot_always_be_removed
    : ¬(∏ A:UU, ∥A∥ -> A).
  Proof. (* fill in here... *)
  Admitted.

  (* Exercise 3.12 *)
  Lemma truncated_truncation_removal_if_LEM {A : UU}
        (LEM : LEM_Statement)
    : ∥ (∥A∥ -> A) ∥.
  Proof. (* fill in here... *)
  Admitted.

  (* Exercise 3.13 *)
  (* NOTE: you need to avoid using Univalence in this proof *)
  (* Check whether some other result relies on univalence as follows: *)
  Print Assumptions bool_isSet.
  (* note how ua occurs in the assumption set *)
  (* next, note what happens if we use this result in another result... *)
  Lemma booleqv_isSet : isSet (𝟚 ≃ 𝟚).
  Proof. apply equiv_isSet; apply bool_isSet. Defined.
  Print Assumptions booleqv_isSet.
  (* and sure enough, there's ua and company again... *)
  Print ua. (* we can see it's defined in terms of idtoeqv_isequiv *)
  Print idtoeqv_isequiv. (* this is the root axiom we used *)
  Lemma naive_LEM_implies_AC
    : (∏ A:UU, A + ¬A) -> Axiom_of_Choice_statement.
  Proof. (* fill in here... *)
  Admitted.

  (* Exercise 3.14 *)
  (* Think about how to state and prove these results
     inside of Coq... *)
  (* fill in here... *)

  (* Exercise 3.15 *)
  (* maybe do this on paper.  We ruined it a bit by doing it
     in the chapter development to get some encoding *)
  (* However, the definition relies on propositional resizing rules.
     Can you ensure those are sound in this approach?  Is the specific
     definition encoded in the chapter 3 reference sound? *)

  (* Exercise 3.16 *)
  Lemma double_not_commutes_with_pi_over_sets_assuming_LEM
        {A : UU} {P : A -> UU}
        (isA : isSet A) (isP : ∏ x:A, isProp (P x))
        (LEM : LEM_Statement)
  : (∏ x:A, ¬¬(P x)) ≃ (¬¬∏ x:A, P x).
  Proof. (* fill in here... *)
  Admitted.

  (* Exercise 3.17 *)
  Lemma prop_rect (A : UU) (B : ∥A∥ -> UU)
        (BP : ∏ a:∥A∥, isProp (B a))
        (inB : ∏ a:A, B (elemP a))
    : ∏ a:∥A∥, B a.
  Proof. (* fill in here... *)
  Admitted.

  (* Exercise 3.18 *)
  Lemma LEM_equiv_Double_Negation
    : LEM_Statement <-> Law_of_Double_Negation_Statement.
  Proof. (* fill in here... *)
  Admitted.

  (* Exercise 3.19 *)
  Lemma Untruncate_Decidable_Nat_Indexed_Propositions
        (P : ℕ -> UU)
        (isP : ∏ n:ℕ, isProp (P n))
        (isD : DecidableFibration P)
    : ∥ Σ n:ℕ, P n ∥ -> Σ n:ℕ, P n.
  Proof. (* fill in here... *)
  Admitted.

  (* Exercise 3.20 *)
  Lemma contr_sigbase {A : UU} {P : A -> UU}
        (isC : isContr A)
    : (Σ x:A, P x) ≃ P isC.1 .
  Proof. (* fill in here... *)
  Admitted.

  (* Exercise 3.21 *)
  Lemma isProp_equiv_P_equiv_Ptrunc (P : UU) : (isProp P) ≃ (P ≃ ∥P∥).
  Proof. (* fill in here... *)
  Admitted.

  (* Exercise 3.22 *)
  (* still haven't worked out how to encode Fin ... *)

  (* Exercise 3.23 *)
  Lemma Untruncate_Decidable_Nat_Indexed_Fibration
        (P : ℕ -> UU)
        (isD : DecidableFibration P)
    : ∥ Σ n:ℕ, P n ∥ -> Σ n:ℕ, P n.
  Proof. (* fill in here... *)
  Admitted.

End Chapter_3_Exercises.


Require Import
  Coq.Sets.Ensembles
  Coq.Sets.Finite_sets
  Coq.Sets.Finite_sets_facts
  Coq.Classes.Morphisms
  Coq.Setoids.Setoid
  Coq.Relations.Relation_Definitions.

Program Instance Same_set_Equivalence {A} : Equivalence (@Same_set A).
Obligation 1.
  intro x.
  constructor; intros y H; exact H.
Qed.
Obligation 2.
  intros x y H.
  destruct H.
  split; trivial.
Qed.
Obligation 3.
  intros x y z H1 H2.
  destruct H1, H2.
  split; trivial.
    intros w H3.
    apply H1.
    apply H.
    exact H3.
  intros w H3.
  apply H0.
  apply H2.
  exact H3.
Qed.

Add Parametric Relation {A : Type} : (Ensemble A) (Same_set A)
  reflexivity  proved by (@Equivalence_Reflexive  _ _ Same_set_Equivalence)
  symmetry     proved by (@Equivalence_Symmetric  _ _ Same_set_Equivalence)
  transitivity proved by (@Equivalence_Transitive _ _ Same_set_Equivalence)
  as Same_set_relation.

Add Parametric Morphism A : (Same_set A)
  with signature (Same_set A ==> Same_set A ==> Basics.impl)
    as Same_set_equiv.
Proof.
  unfold Basics.impl; intros.
  destruct H, H0, H1.
  split; intros z H5.
    apply H0, H1, H2, H5.
  apply H, H4, H3, H5.
Qed.

Add Parametric Morphism A : (Same_set A)
  with signature (Same_set A ==> Same_set A ==> Basics.flip Basics.impl)
    as Same_set_equiv'.
Proof.
  unfold Basics.impl; intros.
  destruct H, H0, H1.
  split; intros z H5.
    apply H3, H1, H, H5.
  apply H2, H4, H0, H5.
Qed.

Add Parametric Morphism A : (Singleton A)
  with signature (eq ==> Same_set A)
    as Singleton_Same_set.
Proof. intros; reflexivity. Qed.

Add Parametric Morphism A : (In A)
  with signature (Same_set A ==> Same_set A)
    as In_Same_set.
Proof.
  intros.
  exact H.
Qed.

Add Parametric Morphism A : (In A)
  with signature (Same_set A ==> eq ==> Basics.impl)
    as In_Same_set_eq.
Proof.
  unfold Basics.impl; intros; subst.
  destruct H.
  apply H, H0.
Qed.

Add Parametric Morphism A : (In A)
  with signature (Same_set A ==> eq ==> Basics.flip Basics.impl)
    as In_Same_set_eq'.
Proof.
  unfold Basics.impl; intros; subst.
  destruct H.
  apply H1, H0.
Qed.

Add Parametric Morphism A : (In A)
  with signature (Same_set A --> eq ==> Basics.impl)
    as In_Same_set_eq''.
Proof.
  unfold Basics.impl; intros; subst.
  destruct H.
  apply H1, H0.
Qed.

Add Parametric Morphism A : (In A)
  with signature (Same_set A --> eq ==> Basics.flip Basics.impl)
    as In_Same_set_eq'''.
Proof.
  unfold Basics.impl; intros; subst.
  destruct H.
  apply H, H0.
Qed.

Add Parametric Morphism A : (Union A)
  with signature (Same_set A ==> Same_set A ==> Same_set A)
    as Union_Same_set.
Proof.
  intros.
  destruct H, H0.
  split; intros z H3;
  inversion H3; subst; clear H3.
  - apply Union_introl.
    apply H, H4.
  - apply Union_intror.
    apply H0, H4.
  - apply Union_introl.
    apply H1, H4.
  - apply Union_intror.
    apply H2, H4.
Qed.

Add Parametric Morphism A : (Add A)
  with signature (Same_set A ==> eq ==> Same_set A)
    as Add_Same_set.
Proof.
  unfold Add; intros.
  subst.
  rewrite H.
  reflexivity.
Qed.

Add Parametric Morphism A : (Setminus A)
  with signature (Same_set A ==> Same_set A ==> Same_set A)
    as Setminus_Same_set.
Proof.
  intros.
  destruct H, H0.
  split; intros z H3;
  inversion H3; subst; clear H3.
    split.
      apply H, H4.
    unfold not; intros.
    contradiction H5.
    apply H2, H3.
  split.
    apply H1, H4.
  unfold not; intros.
  contradiction H5.
  apply H0, H3.
Qed.

Add Parametric Morphism A : (Subtract A)
  with signature (Same_set A ==> eq ==> Same_set A)
    as Subtract_Same_set.
Proof.
  unfold Subtract; intros.
  subst.
  rewrite H.
  reflexivity.
Qed.

Add Parametric Morphism A : (Included A)
  with signature (Same_set A ==> Same_set A ==> Basics.impl)
    as Included_Same_set.
Proof.
  unfold Basics.impl, Included; intros.
  rewrite <- H0.
  rewrite <- H in H2.
  exact (H1 _ H2).
Qed.

Instance Included_Same_set_subrelation A :
  subrelation (@Same_set A) (@Included A).
Proof. intros ? ? [? ?]; assumption. Qed.

Require Import Fiat.ADT Fiat.ADTNotation.

Lemma refineEquiv_Same_set : forall A x y,
  Same_set A x y <-> refineEquiv x y.
Proof.
  split; intros;
  destruct H;
  split; intros.
  - intros v H1.
    apply H0, H1.
  - intros v H1.
    apply H, H1.
  - intros v H1.
    apply H0, H1.
  - intros v H1.
    apply H, H1.
Qed.

Add Parametric Morphism {A} : refine
  with signature (Same_set A ==> Same_set A ==> Basics.impl)
    as refine_Same_set.
Proof.
  unfold impl, refine; intros.
  destruct H, H0.
  apply H, H1, H4, H2.
Qed.

Add Parametric Morphism {A} : refine
  with signature (Same_set A ==> Same_set A ==> Basics.flip Basics.impl)
    as refine_Same_set'.
Proof.
  unfold impl, refine; intros.
  destruct H, H0.
  apply H3, H1, H0, H2.
Qed.

Add Parametric Morphism {A B} : (@Bind A B)
  with signature
    (Same_set A ==> pointwise_relation _ (Same_set B) ==> Same_set B)
    as Bind_Same_set.
Proof.
  unfold pointwise_relation; intros.
  split; intros; intros z H1.
    inversion H1.
    destruct H2.
    rewrite <- H.
    exists x1.
    split.
      exact H2.
    rewrite <- H0.
    exact H3.
  inversion H1.
  destruct H2.
  rewrite H.
  exists x1.
  split.
    exact H2.
  rewrite H0.
  exact H3.
Qed.

Add Parametric Morphism {A} : (@Pick A)
  with signature (Same_set A ==> Same_set A)
    as Pick_Same_set.
Proof.
  intros.
  split; intros; intros z H1;
  apply Pick_inv in H1;
  apply PickComputes;
  destruct H.
    apply H.
    exact H1.
  apply H0.
  exact H1.
Qed.

Add Parametric Morphism {A} : (@Return A)
  with signature (eq ==> Same_set A)
    as Return_Same_set.
Proof.
  split; intros z H1;
  apply Return_inv in H1; subst; constructor.
Qed.

Add Parametric Morphism A (c : bool) : (If_Then_Else c)
  with signature (Same_set A ==> Same_set A ==> Same_set A)
    as Same_set_If_Then_Else.
Proof.
  unfold If_Then_Else; intros.
  destruct c; eassumption.
Qed.

Add Parametric Morphism A B (c : option A) : (@If_Opt_Then_Else A (Comp B) c)
    with signature
    ((pointwise_relation A (Same_set B))
       ==> Same_set B
       ==> Same_set B )
      as Same_set_If_Opt_Then_Else.
Proof.
  unfold If_Opt_Then_Else; intros.
  destruct c; eauto.
Qed.

Program Instance Finite_Proper A :
  Proper (Same_set A ==> impl) (Finite A).
Obligation 1.
  intros ????.
  eapply Finite_downward_closed; eauto with sets.
  intros ? H1.
  rewrite <- H in H1.
  assumption.
Qed.

Program Instance Finite_Proper_flip A :
  Proper (Same_set A --> flip impl) (Finite A).
Obligation 1.
  intros ????.
  eapply Finite_downward_closed; eauto with sets.
  intros ? H1.
  rewrite H in H1.
  assumption.
Qed.


(* File: Normal_Form.v  (last edited on 27/10/2000) (c) Klaus Weich  *)

From IPC Require Export Forms.

(*******   Normal forms    ***********************************************)

Inductive normal_form : Set :=
  | NFalsum : normal_form
  | NAtom : Int -> normal_form
  | NDisj : Int -> Int -> normal_form
  | AImp : Int -> normal_form -> normal_form
  | NImp_NF : nimp -> normal_form
with nimp : Set :=
    NImp : Int -> Int -> normal_form -> nimp.

Fixpoint nf2form (x : normal_form) : form :=
  match x with
  | NFalsum => Falsum
  | NAtom i => Atom i
  | NDisj i j => OrF (Atom i) (Atom j)
  | AImp i b => Imp (Atom i) (nf2form b)
  | NImp_NF x => nimp2form x
  end

 with nimp2form (x : nimp) : form :=
  match x with
  | NImp i j b => Imp (Imp (Atom i) (Atom j)) (nf2form b)
  end.

Definition nf_list := list normal_form.
Definition nf_nil := nil (A:=normal_form).

Fixpoint nvimp (l : list Int) : normal_form -> normal_form :=
  match l with
  | nil => fun a : normal_form => a
  | i :: l => fun a : normal_form => nvimp l (AImp i a)
  end.

Lemma vimp2nform :
 forall (l : list Int) (a : normal_form),
 {b : normal_form | nf2form b = vimp l (nf2form a)}.
intros l; elim l; clear l.
intros a; exists a; trivial.
intros i l ih a.
elim (ih (AImp i a)); clear ih.
intros b nf_b.
exists b; assumption.
Qed.

Lemma vimp2nvimp :
 forall (l : list Int) (a : normal_form), {b : normal_form | b = nvimp l a}.
intros l; elim l; clear l.
intros a; exists a; trivial.
intros i l ih a.
elim (ih (AImp i a)); clear ih.
intros b nf_b.
exists b; assumption.
Qed.

Lemma vimp_eq_nvimp :
 forall (l : list Int) (a : normal_form),
 vimp l (nf2form a) = nf2form (nvimp l a).
intros l; elim l; clear l.
intros a; trivial.
intros i l ih a.
apply (ih (AImp i a)).
Qed.