(* cmd + shift + i for interpret to point *)
Module TuplePlayground.
    Inductive bit : Type :=
        | B0
        | B1.
    Inductive nybble : Type :=
        | bits (b0 b1 b2 b3 : bit).
    Check (bits B1 B0 B1 B0) : nybble.

    (* The bits constructor acts as a wrapper for its contents. Unwrapping can be done by pattern-matching, as in the all_zero function which tests a nybble to see if all its bits are B0. We use underscore (_) as a wildcard pattern to avoid inventing variable names that will not be used. *)
    Definition all_zero (nb : nybble) : bool :=
        match nb with
        | (bits B0 B0 B0 B0) => true
        | (bits _ _ _ _) => false
        end.

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

End TuplePlayground.


(*===========================================================================
  Properties of bit vectors
  ===========================================================================*)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq tuple fintype div zmodp ssralg.
Require Import ZArith.
Require Import tuplehelp bitsrep nathelp.

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

Lemma trivialBits (p q: BITS 0) : p = q.
Proof. by rewrite (tuple0 p) (tuple0 q). Qed.

(*---------------------------------------------------------------------------
    Properties of conversion to and from natural numbers.
  ---------------------------------------------------------------------------*)
Lemma toNatCons n b (p:BITS n) : toNat (consB b p) = b + (toNat p).*2.
Proof. done. Qed.

Lemma toNatNil (p:BITS 0) : toNat p = 0.
Proof. by rewrite (tuple0 p). Qed.

(* toNat is left-inverse to fromNat *)
Lemma toNatK n : cancel (@toNat n) (@fromNat n).
Proof. induction n; first (move => p; apply trivialBits).
+ case/tupleP => b x. rewrite toNatCons/fromNat-/fromNat /= half_bit_double.
rewrite IHn odd_add odd_double. by case b.
Qed.

(* Hence toNat is injective *)
Definition toNat_inj n := can_inj (@toNatK n).

(* toNat result is bounded *)
Lemma toNatBounded n : forall (p: BITS n), toNat p < 2^n.
Proof. induction n. move => p. by rewrite toNatNil.
case/tupleP => [b p].
rewrite expnS mul2n toNatCons.
case b.
+ rewrite ltn_Sdouble. apply IHn.
+ rewrite ltn_double. apply IHn.
Qed.

Lemma toNat_fromNatBounded n : forall m, m < 2^n -> toNat (fromNat (n:=n) m) = m.
Proof. induction n.
+ rewrite expn0. by case.
+ rewrite expnS. move => m.  specialize (IHn m./2).
  move => LT.
  assert (m./2 < 2^n).
  rewrite -ltn_double. rewrite -(odd_double_half m) mul2n in LT.
  rewrite -(ltn_add2l (odd m)).
  by apply ltn_addl.
  specialize (IHn H).
  rewrite /toNat-/toNat/=.
  rewrite /toNat/= in IHn. rewrite IHn.
  by rewrite odd_double_half.
Qed.

Lemma fromNatBounded_eq m1 m2 n : m1 < 2^n -> m2 < 2^n ->
  (m1==m2) = (fromNat (n:=n) m1 == fromNat m2).
Proof. move => B1 B2.
case E: (m1 == m2);
case E': (#m1 == #m2) => //. by rewrite (eqP E) eq_refl in E'.
rewrite -(toNat_fromNatBounded B1) -(toNat_fromNatBounded B2) in E.
by rewrite (eqP E') eq_refl in E.
Qed.

Lemma fromNatHalf n m : cons_tuple (odd m) (fromNat (n:=n) m./2) = fromNat m.
Proof. done. Qed.

Lemma fromNat_wrap n : forall m, fromNat (n:=n) m = fromNat (n:=n) (m + 2^n).
Proof. induction n => //.
rewrite expnS.
move => m.
case ODD: (odd m); rewrite /fromNat-/fromNat /=ODD odd_add odd_mul/=ODD/= halfD ODD/=.
specialize (IHn m./2). by rewrite odd_mul/= add0n mul2n doubleK IHn.
specialize (IHn m./2). by rewrite add0n mul2n doubleK IHn.
Qed.

Lemma fromNat_wrapMany n c : forall m, fromNat (n:=n) m = fromNat (n:=n) (m + c * 2^n).
Proof. induction c => m. by rewrite mul0n addn0.
rewrite mulSn (addnC (2^n)) addnA fromNat_wrap. rewrite IHc.
by rewrite -addnA (addnC (2^n)) addnA.
Qed.

Lemma toNat_mod n (p:BITS n): toNat p = toNat p %% 2^n.
Proof. rewrite modn_small => //. apply toNatBounded. Qed.

Lemma toNat_fromNat n m : @toNat n (fromNat m) = m %% 2^n.
Proof. have H:= divn_eq m (2^n). rewrite {1}H.
have HH:= @fromNat_wrapMany n (m %/ 2^n) (m %% 2^n). rewrite addnC in HH. rewrite -HH.
rewrite toNat_fromNatBounded. done. apply ltn_pmod. apply expn_gt0. Qed.

Lemma fromNat_succn n : forall b c, @fromNat n b = fromNat c -> @fromNat n (b.+1) = fromNat(c.+1).
Proof. induction n => //.
move => b c EQ. rewrite /fromNat-/fromNat. rewrite /fromNat-/fromNat in EQ.
elim: (splitTuple EQ) => [EQ1 EQ2]. simpl in EQ1. simpl in EQ2.
specialize (IHn _ _ EQ2). rewrite/= !uphalf_half /=EQ1.
case ODD: (odd c). + by rewrite !add1n IHn. + by rewrite !add0n EQ2.
Qed.

Lemma fromNat_addn n : forall a b c, @fromNat n b = fromNat c -> @fromNat n (a+b) = fromNat(a+c).
Proof. induction a => //.
move => b c EQ. rewrite -addn1 -!addnA !add1n. apply IHa. by apply fromNat_succn.
Qed.

Lemma toZp_fromNat n m : toZp (fromNat (n:=n.+1) m) = (m%:R)%R.
Proof. apply val_inj.
rewrite /toZp toNat_fromNat Zp_nat.
rewrite /=Zp_cast; last apply pow2_gt1.
by rewrite modn_mod.
Qed.

Lemma toZpAux_fromNat n c : toZpAux (m:=n.+1) (fromNat (n:=n.+1) c) = (c%:R)%R.
Proof. apply val_inj.
rewrite /toZpAux toNat_fromNat Zp_nat.
rewrite /=Zp_cast; last apply pow2_gt1.
by rewrite modn_mod.
Qed.

Hint Rewrite toZp_fromNat toZpAux_fromNat : ZpHom.

Lemma toNat_droplsb n (p: BITS n.+1) : toNat (droplsb p) = (toNat p)./2.
Proof. case/tupleP: p => [b p]. rewrite /droplsb/splitlsb beheadCons theadCons.
by rewrite toNatCons/= half_bit_double.
Qed.

Lemma toNatCat m n (p : BITS m) (q: BITS n) : toNat (p ## q) = toNat p * 2^n + toNat q.
Proof. induction n. rewrite (tuple0 q). by rewrite expn0 muln1.
case/tupleP: q => [b q].
unfold "##".  rewrite catCons. rewrite !toNatCons. unfold "##" in IHn.
rewrite IHn. rewrite expnS. rewrite -!muln2. ring.
Qed.

(*---------------------------------------------------------------------------
    Properties of conversion to and from 'Z_(2^n)
  ---------------------------------------------------------------------------*)

(* This only holds for n.+1 because 'Z_1 actually has two elements - it's
   definitionally the same as 'Z_2 in order to force a ring structure. See zmodp
   for more details *)
Lemma fromZpK n : cancel (@fromZp n.+1) (@toZp n.+1).
Proof.
  move => x. rewrite /toZp/fromZp. rewrite  toNat_fromNat modn_small. apply valZpK.
  destruct x. simpl. rewrite Zp_cast in i => //.
  apply pow2_gt1.
Qed.

Lemma toZpK n : cancel (@toZp n) (@fromZp n).
Proof. case E: (n == 0).
+ rewrite /cancel. rewrite (eqP E). move => x. apply trivialBits.
+ move => x. rewrite /fromZp/toZp/=.
  rewrite Zp_cast. by rewrite (modn_small (toNatBounded _)) toNatK.
  apply negbT in E. destruct n => //. apply pow2_gt1.
Qed.

Lemma toZp_inj n : injective (@toZp n).
Proof. apply (can_inj (@toZpK _)). Qed.

Lemma fromZp_inj n : injective (@fromZp n.+1).
Proof. apply (can_inj (@fromZpK _)). Qed.

Lemma toZp_eq n (x y: BITS n) : (x == y) = (toZp x == toZp y).
Proof. destruct n. by rewrite (tuple0 x) (tuple0 y).
case E: (toZp x == toZp y).
rewrite (toZp_inj (eqP E)). by rewrite eq_refl.
apply (contraFF (b:=false)) => // => H.
rewrite (eqP H) (eq_refl) in E. done.
Qed.

Corollary toZp_neq n (x y: BITS n) : (x != y) = (toZp x != toZp y).
Proof. by rewrite toZp_eq. Qed.

(*---------------------------------------------------------------------------
    Properties of bit get and set
  ---------------------------------------------------------------------------*)

Lemma setBitThenGetSame n : forall (p: BITS n) i b, i<n -> getBit (setBit p i b) i = b.
Proof.
induction n => //.
case/tupleP => [b' p]. move => i b LT.
destruct i => //.
simpl. rewrite theadCons beheadCons. assert (LT' : i < n) by done.
rewrite /getBit/=. apply IHn; done.
Qed.

Lemma setBitThenGetDistinct n :
  forall (p: BITS n) i i' b, i<n -> i'<n -> i<>i' -> getBit (setBit p i b) i' = getBit p i'.
Proof.
induction n => //.
case/tupleP => [b' p]. move => i i' b LT LT' NEQ.
destruct i.
(* i = 0 *) simpl. rewrite beheadCons. destruct i' => //.
(* i <> 0 *)
destruct i' => //.
rewrite /= theadCons beheadCons /getBit/=.
assert (lt : i < n) by done.
assert (lt' : i' < n) by done.
assert (neq' : i <> i') by  intuition.
specialize (IHn p _ _ b lt lt' neq'). apply IHn.
Qed.

(*---------------------------------------------------------------------------
    Properties of all zeroes and all ones
  ---------------------------------------------------------------------------*)
Lemma fromNat0 n : #0 = zero n.
Proof. induction n; first apply trivialBits.
+ rewrite /zero /copy. rewrite /zero /copy in IHn. by rewrite /fromNat-/fromNat IHn nseqCons.
Qed.

Lemma toNat_zero n : toNat (zero n) = 0.
Proof. induction n => //. rewrite /toNat/=. rewrite /toNat in IHn. by rewrite IHn. Qed.

Corollary toNat_fromNat0 n : @toNat n #0 = 0.
Proof. by rewrite fromNat0 toNat_zero. Qed.

Lemma msb_zero n : msb (zero n) = false.
Proof. by induction n. Qed.

Lemma toNat_ones_succ n : (toNat (ones n)).+1 = 2^n.
Proof. induction n => //.
rewrite /toNat/=. rewrite /toNat/= in IHn.
by rewrite expnS mul2n addnC addn1 -doubleS IHn.
Qed.

Corollary toNat_ones n : toNat (ones n) = (2^n).-1.
Proof. by rewrite -toNat_ones_succ succnK. Qed.

Lemma msb_ones n : msb (ones n.+1) = true.
Proof. by induction n. Qed.

Lemma toZp_zero n : toZp (zero n) = 0%R.
Proof. rewrite /toZp toNat_zero. by apply val_inj. Qed.

Lemma toZpAux_zero m n : toZpAux (m:=m) (zero n) = 0%R.
Proof. rewrite /toZpAux toNat_zero. by apply val_inj. Qed.

Lemma toZp_ones n : toZp (ones n.+1) = (-1)%R.
Proof. rewrite /toZp toNat_ones. apply val_inj.
rewrite /= Zp_cast; last apply pow2_gt1.
rewrite -subn1. replace (1 %% 2^n.+1) with 1 => //.
by rewrite modn_small; last apply pow2_gt1.
Qed.

Hint Rewrite toZpK fromZpK toZp_zero toZpAux_zero toZp_ones : ZpHom.

(*---------------------------------------------------------------------------
    Properties of joinmsb and splitmsb
  ---------------------------------------------------------------------------*)

Lemma toNat_joinmsb n : forall c (p: BITS n), toNat (joinmsb (c, p)) = c * 2^n + toNat p.
Proof. induction n.
+ move => c p. by rewrite /joinmsb (tuple0 p) expn0 muln1.
+ move => c. case/tupleP => [b p].
  rewrite /joinmsb-/joinmsb /splitlsb theadCons beheadCons !toNatCons expnS IHn.
  by rewrite doubleD addnCA -mul2n mulnCA.
Qed.

Lemma toNat_joinmsb0 n (p: BITS n) : toNat (joinmsb0 p) = toNat p.
Proof. by rewrite toNat_joinmsb. Qed.

Lemma splitmsb_fromNat n :
  forall m, splitmsb (n:=n) (fromNat m) = (odd (m %/ 2^n), fromNat m).
Proof. induction n => m.
+ by rewrite /dropmsb/=beheadCons!theadCons expn0 divn1.
+ rewrite expnS. rewrite /fromNat-/fromNat/=.
  rewrite /joinlsb !beheadCons!theadCons fromNatHalf. specialize (IHn m./2). rewrite IHn.
  by rewrite -divn2 -divnMA.
Qed.

Corollary dropmsb_fromNat n m : dropmsb (n:=n) (fromNat m) = (fromNat m).
Proof. by rewrite /dropmsb splitmsb_fromNat. Qed.

Corollary toNat_dropmsb n (p: BITS n.+1) : toNat (dropmsb p) = toNat p %% 2^n.
Proof. rewrite -{1}(toNatK p). rewrite dropmsb_fromNat. by rewrite toNat_fromNat. Qed.

Lemma toZp_joinmsb0 n (p: BITS n) : toZp (joinmsb0 p) = toZpAux p.
Proof. apply val_inj.
rewrite /toZp/toZpAux/= Zp_cast; last apply pow2_gt1.
by rewrite toNat_joinmsb0.
Qed.

Lemma toZp_dropmsb n (p: BITS n.+2) : toZp (n:=n.+1) (dropmsb p) = toZpAux (m:=n.+1) p.
Proof.
apply val_inj.
rewrite /toZp/toZpAux/= Zp_cast; last apply pow2_gt1.
rewrite toNat_dropmsb.
by rewrite modn_mod.
Qed.

Hint Rewrite toZp_joinmsb0 toZp_dropmsb : ZpHom.

Lemma splitmsbK n : cancel (@splitmsb n) (@joinmsb n).
Proof. induction n.
+ case/tupleP => [b p]. by rewrite (tuple0 p).
+ case/tupleP => [b p]. rewrite /= beheadCons theadCons. specialize (IHn p).
case E: (splitmsb p) => [b' p'].
rewrite beheadCons theadCons.
rewrite E in IHn. by rewrite IHn.
Qed.

Lemma joinmsbK n : cancel (@joinmsb n) (@splitmsb n).
Proof. induction n.
+ move => [b p]. by rewrite !(tuple0 p) /= theadCons beheadCons.
+ move => [c p]. case/tupleP: p => [b p].
  by rewrite /= !theadCons !beheadCons IHn.
Qed.

Corollary dropmsb_joinmsb n b (p:BITS n) : dropmsb (joinmsb (b, p)) = p.
Proof. by rewrite /dropmsb joinmsbK. Qed.

Lemma splitlsbK n : cancel (@splitlsb n) (@joinlsb n).
Proof. case/tupleP => [b p]. by rewrite /splitlsb beheadCons theadCons. Qed.

Lemma joinlsbK n : cancel (@joinlsb n) (@splitlsb n).
Proof. move => [p b]. by rewrite /joinlsb /splitlsb beheadCons theadCons. Qed.

Lemma toNat_joinlsb n (p:BITS n) b : toNat (joinlsb (p, b)) = b + (toNat p).*2.
Proof. done. Qed.

(* Totally ridiculous proof *)
Lemma splitmsb_rev n : forall (b: BITS n.+1) hi (lo:BITS n),
   splitmsb b = (hi,lo) -> rev b = hi::rev lo.
Proof. induction n => b hi lo/=.
+ move => [<- <-] {lo}/=. case/tupleP:b => [b u]//=. by rewrite tuple0/=.
+ move => H.
specialize (IHn (behead_tuple b) hi).
destruct (splitmsb (behead_tuple b)).
injection H => [H1 H2] {H}. rewrite H2 {H2} in IHn.
specialize (IHn b1 refl_equal). rewrite -H1/=.
case/tupleP E: b => [b' u]/=. rewrite E/= in IHn.
by rewrite 2!rev_cons IHn rcons_cons.
Qed.

(*---------------------------------------------------------------------------
    Properties of concatenation and splitting of bit strings
  ---------------------------------------------------------------------------*)
Lemma high_catB n2 n1 (p:BITS n1) (q:BITS n2) : high n1 (p ## q) = p.
Proof. induction n2.
- rewrite /high (tuple0 q). by apply catNil.
- case/tupleP: q => x q. rewrite /catB catCons /= beheadCons. apply IHn2.
Qed.

Lemma low_catB n2 n1 (p:BITS n1) (q:BITS n2) : low n2 (p ## q) = q.
Proof. induction n2; first apply trivialBits.
case/tupleP: q => x q. rewrite /catB catCons /= beheadCons. by rewrite IHn2.
Qed.

Lemma low_fromNat n2 n1: forall m, low n2 (fromNat (n:=n2+n1) m) = fromNat (n:=n2) m.
Proof. induction n2 => m //. by rewrite /= /joinlsb !beheadCons !theadCons/= IHn2. Qed.

Lemma split2eta : forall n2 n1 p, let (p1,p2) := split2 n1 n2 p in p = p1 ## p2.
Proof. unfold split2. induction n2.
- move =>n1 p. by rewrite /catB catNil.
- move => n1. case/tupleP => x p. rewrite /= (IHn2 n1 p).
rewrite beheadCons theadCons high_catB low_catB. by rewrite /catB catCons. Qed.

Lemma split2app n2 n1 p1 p2 : split2 n1 n2 (p1 ## p2) = (p1,p2).
Proof. by rewrite /split2 high_catB low_catB. Qed.

Lemma split3app n3 n2 n1 p1 p2 p3 : split3 n1 n2 n3 (p1 ## p2 ## p3) = (p1,p2,p3).
Proof. by rewrite /split3 !split2app. Qed.

Lemma split4app n4 n3 n2 n1 p1 p2 p3 p4 :
  split4 n1 n2 n3 n4 (p1 ## p2 ## p3 ## p4) = (p1,p2,p3,p4).
Proof. by rewrite /split4 !split2app. Qed.

Lemma split3eta n3 n2 n1 p: match split3 n1 n2 n3 p with (p1,p2,p3) => p1 ## p2 ## p3 end = p. Proof. rewrite /split3 /=. by rewrite -!split2eta. Qed.

Lemma split4eta n4 n3 n2 n1 p:
  match split4 n1 n2 n3 n4 p with (p1,p2,p3,p4) => p1 ## p2 ## p3 ## p4 end = p.
Proof. rewrite /split4 /=. by rewrite -!split2eta. Qed.

Lemma split4eta' n4 n3 n2 n1 p:
  let: (p1,p2,p3,p4) := split4 n1 n2 n3 n4 p in p1 ## p2 ## p3 ## p4 = p.
Proof. rewrite /split4 /=. by rewrite -!split2eta. Qed.

Lemma catB_inj n1 n2 (p1 q1: BITS n1) (p2 q2: BITS n2) :
  p1 ## p2 = q1 ## q2 -> p1 = q1 /\ p2 = q2.
Proof.
move => EQ.
have H1 := high_catB p1 p2.
have H2 := high_catB q1 q2.
have L1 := low_catB p1 p2.
have L2 := low_catB q1 q2.
split. by rewrite -H1 -H2 EQ.
by rewrite -L1 -L2 EQ.
Qed.

Lemma toNat_low n1 n2 (p: BITS (n1+n2)) : toNat (low n1 p) = toNat p %% 2^n1.
Proof. by rewrite -{1}(toNatK p) low_fromNat toNat_fromNat. Qed.

(*---------------------------------------------------------------------------
    Zero and sign extension
  ---------------------------------------------------------------------------*)

Lemma signExtendK extra n : pcancel (@signExtend extra n) (signTruncate extra).
Proof. move => p. rewrite /signExtend /signTruncate split2app.
case: (msb p).
+ by rewrite /ones eq_refl.
+ by rewrite /zero eq_refl.
Qed.

Lemma signTruncateK extra n p q :
  signTruncate extra (n:=n) p = Some q ->
  signExtend extra (n:=n) q = p.
Proof. rewrite /signTruncate/signExtend.
rewrite (split2eta p) split2app.
case P: (_ || _) => // H.
have EQ: low n.+1 p = q by congruence. subst.
case M: (msb _).
+ rewrite M andTb andFb orbF in P. by rewrite (eqP P).
+ rewrite M andTb andFb orFb in P. by rewrite (eqP P).
Qed.

Lemma zeroExtendK extra n : pcancel (@zeroExtend extra n) (zeroTruncate extra).
Proof. move => p. by rewrite /zeroExtend/zeroTruncate split2app eq_refl. Qed.

Lemma zeroTruncateK extra n p q :
  zeroTruncate extra (n:=n) p = Some q ->
  zeroExtend extra (n:=n) q = p.
Proof. rewrite /zeroTruncate/zeroExtend.
rewrite (split2eta p) split2app.
case P: (high extra p == zero extra) => // H.
have EQ: low n p = q by congruence. subst.
by rewrite (eqP P).
Qed.

Lemma toNat_zeroExtend extra n (p: BITS n) : toNat (zeroExtend extra p) = toNat p.
Proof. rewrite /zeroExtend. rewrite toNatCat. by rewrite toNat_zero. Qed.

Lemma toNat_zeroExtendAux extra n (p: BITS n) : toNat (zeroExtendAux extra p) = toNat p.
Proof. induction extra => //. by rewrite /= toNat_joinmsb0 IHextra. Qed.

(*---------------------------------------------------------------------------
    Properties of equality
  ---------------------------------------------------------------------------*)

Lemma iffBool (b1 b2:bool) : (b1 <-> b2) -> b1==b2.
Proof. destruct b1; destruct b2; intuition. Qed.

Lemma bitsEq_nat n {b1 b2: BITS n} :  (b1 == b2) = (toNat b1 == toNat b2).
Proof. suff: b1 == b2 <-> (toNat b1 == toNat b2).

move => H. assert (H' := iffBool H). apply (eqP H').
split. move => H. rewrite (eqP H). done.
move => H. assert (EQ:toNat b1 = toNat b2) by apply (eqP H). by rewrite (toNat_inj EQ).
Qed.


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

Require Import Nat.

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

Inductive queue : Type :=
  | Queue : lst -> lst -> queue.

Fixpoint len (l : lst) : nat :=
match l with
  | Nil => 0
  | Cons a l1 => 1 + (len l1)
end.

Definition qlen (q : queue) : nat :=
match q with
  | Queue l1 l2 => (len l1) + (len l2)
end.

Fixpoint app (l : lst) (m: lst): lst :=
match l with
  | Nil => m
  | Cons a l1 => Cons a (app l1 m)
end.

Fixpoint rev (l: lst): lst :=
match l with
  | Nil => Nil
  | Cons a l1 => app (rev l1) (Cons a Nil)
end.

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

Definition amortizeQueue (l1 l2 : lst) : queue :=
  if leb (len l2)  (len l1) then Queue l1 l2
  else Queue (app l1 (rev l2)) Nil.

Definition qpush (q : queue) (n : nat) : queue :=
match q with
  | Queue l1 l2 => amortizeQueue l1 (Cons n l2)
end.

Lemma len_app : forall l1 l2, len (app l1 l2) = (len l1) + (len l2).
Proof.
  intros. induction l1.
  - reflexivity.
  - simpl. rewrite IHl1. reflexivity.
Qed.

Lemma plus_comm: forall m n, m + n = n + m.
Proof.
induction m.
- intros. simpl. rewrite <- plus_n_O. reflexivity.
- intros. simpl. rewrite IHm. rewrite plus_n_Sm. reflexivity.
Qed.

Lemma len_rev : forall l, len (rev l) = len l.
Proof.
induction l.
- reflexivity.
- simpl. rewrite len_app. simpl. rewrite plus_comm. simpl. rewrite IHl. reflexivity.
Qed.

Theorem queue_push : forall q n, qlen (qpush q n) = 1 + (qlen q).
Proof.
  intros. simpl. destruct q. unfold qpush. unfold qlen. unfold amortizeQueue.
  destruct (leb (len (Cons n l0)) (len l)).
  - simpl. rewrite plus_n_Sm. reflexivity.
  - simpl. rewrite <- plus_n_O.
    rewrite len_app.
    rewrite len_app. rewrite len_rev.
    simpl. rewrite plus_n_Sm. lfind. Admitted.


Require Export Imports.

Set Universe Polymorphism.

Polymorphic Cumulative Class Category: Type :=
 mk_Category
 {
     obj       : Type;
     arrow     : obj -> obj -> Type;
     identity  : forall a, arrow a a;
     comp      : forall {a b c}, (arrow c b) -> (arrow b a) -> (arrow c a);
     compose_respects x y z : Proper (eq ==> eq ==> eq) (@comp x y z);
     assoc     : forall {a b c d} (f : arrow b a) (g : arrow c b) (h : arrow d c),
                              comp h (comp g f) = comp (comp h g) f;
     identity_f: forall {a b} (f: arrow b a), comp (@identity b) f = f;
     f_identity: forall {a b} (f: arrow b a), comp f (@identity a) = f
  }.

Notation " g 'o' f " := (@comp _ _ _ _ g f) (at level 40, left associativity).

(** sameness of categories *)
Lemma C_split: forall C D: Category,
               @obj C = @obj D ->
               JMeq (@arrow C) (@arrow D) ->
               JMeq (@identity C) (@identity D) ->
               JMeq (@comp C) (@comp D) -> C = D.
Proof. intros C D H0 H1 H2 H3.
       destruct C, D. cbn in *. subst.
       apply JMeq_eq in H1. subst. apply JMeq_eq in H2. subst. f_equal.
       now destruct (proof_irrelevance _ compose_respects0 compose_respects1).
       now destruct (proof_irrelevance _ assoc0 assoc1).
       now destruct (proof_irrelevance _ identity_f0 identity_f1).
       now destruct (proof_irrelevance _ f_identity0 f_identity1).
Defined.

Class SubCategory (C: Category): Type :=
  mk_SubCategory
  {
     s_obj     : @obj C -> Type;
     s_arrow   : forall (a b: @obj C), s_obj a -> s_obj b -> @arrow C a b -> Type;
     s_identity: forall (a: @obj C) (sa: s_obj a), s_arrow a a sa sa (@identity C a);
     s_comp    : forall (a b c: @obj C) (sa: s_obj a) (sb: s_obj b) (sc: s_obj c)
                        (f: arrow b c) (g: arrow a b),
                         s_arrow a b sa sb g -> s_arrow b c sb sc f ->
                         s_arrow a c sa sc (g o f)
  }.

Definition Product_Category (C D: Category) : Category.
Proof.
  refine (@mk_Category
           (@obj C * @obj D)%type
           (fun a b => (@arrow C (fst a) (fst b) * @arrow D (snd a) (snd b))%type)
           (fun a => (@identity C (fst a), @identity D (snd a)))
           (fun a b c g f => (fst g o fst f, snd g o snd f))
           _ _ _ _
         ).
  - setoid_rewrite <- assoc. reflexivity.
  - intros. simpl. rewrite !identity_f. destruct f. now simpl.
  - intros. simpl. rewrite !f_identity. destruct f. now simpl.
Defined.

Definition Dual_Category (C: Category) : Category.
Proof.
  refine (@mk_Category
           (@obj C)%type
           (fun a b => (@arrow C b a %type))
           (fun a => (@identity C a))
           (fun a b c f1 f2 => f2 o f1)
           _ _ _ _
         ).
 - intros. now rewrite <- assoc.
 - intros. now rewrite f_identity.
 - intros. now rewrite identity_f.
Defined.

Notation "C × D ":= (@Product_Category C D) (at level 40, left associativity).
Notation "C ^op" := (@Dual_Category C) (at level 40, left associativity).

(** Coq Universes as categories *)
Notation CoqCat U :=
{|
  obj := U;
  arrow := (fun A B => B -> A);
  identity := (fun _ => id);
  comp :=   (fun A B C (g: B -> C) (f: A -> B) a => g (f a))
|}.

Program Definition CoqCatT: Category := CoqCat Type.
Program Definition CoqCatS: Category := CoqCat Set.
Program Definition CoqCatP: Category := CoqCat Prop.


Require Import Coq.Lists.List.
Import ListNotations.

Theorem silly2a_using_apply : forall (n m : nat), (n,n) = (m,m)->
    (forall (q r : nat),(q,q)=(r,r) -> [q]=[r]) -> [n] = [m].
Proof.
    intros. apply H0. apply H.
Qed.

Theorem silly2a_using_rewrite : forall (n m : nat), (n,n) = (m,m)->
    (forall (q r : nat),(q,q)=(r,r) -> [q]=[r]) -> [n] = [m].
Proof.
    intros. rewrite (H0 n m). reflexivity. rewrite H. reflexivity.
Qed.


Require Import Coq.Arith.EqNat Coq.MSets.MSets Coq.Arith.Peano_dec Coq.Arith.Compare_dec.

Inductive name :=
  | name_cons : nat -> name.

Lemma name_S : forall x y, name_cons (S x) = name_cons (S y) <-> name_cons x = name_cons y.
Proof.
  induction x; induction y; split; intros; auto; try discriminate; try (inversion H; auto).
Qed.

Lemma name_cons_prop : forall n m, name_cons n = name_cons m <-> n = m.
Proof.
  split; induction n, m; intros; auto; try discriminate; try (inversion H; auto).
Qed.

Definition beq_name (n1 n2 : name) : bool :=
  match n1, n2 with
    | name_cons n1', name_cons n2' => beq_nat n1' n2'
  end.

Lemma beq_name_refl : forall x, beq_name x x = true.
Proof.
  destruct x.
  simpl.
  rewrite <- beq_nat_refl.
  auto.
Qed.

Lemma beq_name_true_iff : forall x y, beq_name x y = true <-> x = y.
Proof.
  destruct x, y.
  simpl.
  split.
    intro.
    apply beq_nat_true in H.
    rewrite H.
    auto.

    intro.
    apply beq_nat_true_iff.
    apply name_cons_prop in H.
    auto.
Qed.

Lemma beq_name_false_iff : forall x y, beq_name x y = false <-> x <> y.
Proof.
  destruct x, y.
  simpl.
  split.
    intro.
    apply beq_nat_false_iff in H.
    intro.
    apply name_cons_prop in H0.
    auto.

    intro.
    apply beq_nat_false_iff.
    intro.
    rewrite H0 in H.
    apply H.
    auto.
Qed.

Lemma beq_name_sym : forall x y, beq_name x y = beq_name y x.
Proof.
  intros.
  destruct (beq_name x y) eqn:?.
  symmetry.
  apply beq_name_true_iff.
  apply beq_name_true_iff in Heqb.
  auto.

  symmetry.
  apply beq_name_false_iff.
  apply beq_name_false_iff in Heqb.
  intro.
  rewrite H in Heqb.
  auto.
Qed.

Lemma eq_name_double_neg : forall (x y : name), ~ ~ x = y <-> x = y.
Proof.
  split; intros.
    apply beq_name_true_iff.
    destruct (beq_name x y) eqn:?.
      auto.

      exfalso; apply H; apply beq_name_false_iff; auto.
    intro.
    apply H0; auto.
Qed.

Lemma name_dec : forall x y : name, {x = y} + {x <> y}.
Proof.
  intros.
  destruct (beq_name x y) eqn:?.
    apply beq_name_true_iff in Heqb.
    left; auto.

    apply beq_name_false_iff in Heqb.
    right; auto.
Qed.

Inductive star :=
  | star_name : name -> star
  | star_bottom : star
  | star_star : star.

Definition beq_star (s1 s2 : star) : bool :=
  match s1, s2 with
    | star_name n1, star_name n2 => beq_name n1 n2
    | star_bottom, star_bottom => true
    | star_star, star_star => true
    | _, _ => false
  end.

Theorem star_dec : forall s t : star, {s = t} + {s <> t}.
Proof.
  intros.
  destruct s, t.
  - destruct (name_dec n n0).
    + rewrite e; left; auto.
    + right; intro.
      inversion H; auto.
  - right; intro; discriminate.
  - right; intro; discriminate.
  - right; intro; discriminate.
  - left; auto.
  - right; intro; discriminate.
  - right; intro; discriminate.
  - right; intro; discriminate.
  - left; auto.
Qed.

Module NameDecidableType <: DecidableType.

  Definition t := name.
  Definition eq (name1 name2 : name) :=
    match name1, name2 with
      | name_cons n1, name_cons n2 => n1 = n2
    end.
  Lemma name_refl : Reflexive eq.
  Proof.
    unfold Reflexive.
    intros.
    destruct x.
    simpl.
    auto.
  Qed.
  Lemma name_sym : Symmetric eq.
  Proof.
    unfold Symmetric.
    intros.
    destruct x, y.
    simpl; simpl in H.
    auto.
  Qed.
  Lemma name_trans : Transitive eq.
  Proof.
    unfold Transitive.
    intros.
    destruct x, y, z.
    simpl; simpl in H, H0.
    rewrite H; rewrite H0; auto.
  Qed.
  Definition eq_equiv :=
    Build_Equivalence t eq name_refl name_sym name_trans.
  Definition eq_dec (x y : t) : {eq x y} + {~ eq x y} :=
    match x, y with
      | name_cons x', name_cons y' => eq_nat_dec x' y'
    end.
End NameDecidableType.

Lemma name_eq_iff : forall x y, NameDecidableType.eq x y <-> x = y.
Proof.
  intros.
  unfold NameDecidableType.eq.
  destruct x, y.
  split.
    intro.
    f_equal; auto.
    intro.
    apply name_cons_prop; auto.
Qed.

Lemma name_neq_iff : forall x y, ~NameDecidableType.eq x y <-> x <> y.
Proof.
  intros.
  unfold NameDecidableType.eq.
  destruct x, y.
  split.
    intro.
    intro.
    apply H.
    apply name_cons_prop; auto.
    intro.
    intro.
    apply H.
    f_equal; auto.
Qed.

Module StarDecidableType <: DecidableType.

  Definition t := star.
  Definition eq (s1 s2 : star) :=
    match s1, s2 with
      | star_name n1, star_name n2 => NameDecidableType.eq n1 n2
      | _, _ => s1 = s2
    end.
  Lemma star_refl : Reflexive eq.
  Proof.
    unfold Reflexive.
    intros.
    destruct x; simpl; auto.
    apply NameDecidableType.name_refl.
  Qed.
  Lemma star_sym : Symmetric eq.
    unfold Symmetric.
    intros.
    destruct x, y; simpl; auto.
    apply NameDecidableType.name_sym.
    simpl in H.
    auto.
  Qed.
  Lemma star_trans : Transitive eq.
  Proof.
    unfold Transitive.
    intros.
    destruct x, y, z; simpl; auto; try inversion H; try inversion H0.
    simpl in H, H0.
    generalize n, n0, n1, H, H0.
    fold (Transitive NameDecidableType.eq).
    apply NameDecidableType.name_trans.
  Qed.
  Definition eq_equiv :=
    Build_Equivalence t eq star_refl star_sym star_trans.
  Theorem eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
  Proof.
    intros.
    destruct x, y; simpl; try solve [ left; auto | right; intro H; inversion H ].
    apply NameDecidableType.eq_dec.
  Qed.
End StarDecidableType.

Module NameOrderedType <: OrderedType.
  Definition t := name.
  Definition eq :=
    fun name1 name2 =>
      match name1, name2 with
        | name_cons n1, name_cons n2 => n1 = n2
      end.
  Lemma name_refl : Reflexive eq.
  Proof.
    unfold Reflexive.
    intros.
    destruct x.
    simpl.
    auto.
  Qed.
  Lemma name_sym : Symmetric eq.
  Proof.
    unfold Symmetric.
    intros.
    destruct x, y.
    simpl; simpl in H.
    auto.
  Qed.
  Lemma name_trans : Transitive eq.
  Proof.
    unfold Transitive.
    intros.
    destruct x, y, z.
    simpl; simpl in H, H0.
    omega.
  Qed.
  Definition eq_equiv :=
    Build_Equivalence t eq name_refl name_sym name_trans.
  Definition lt :=
    fun name1 name2 =>
      match name1, name2 with
        | name_cons n1, name_cons n2 => lt n1 n2
      end.
  Lemma name_irrefl : Irreflexive lt.
  Proof.
    unfold Irreflexive.
    unfold Reflexive, complement.
    intros.
    destruct x.
    simpl in H.
    omega.
  Qed.
  Lemma name_trans_lt : Transitive lt.
  Proof.
    unfold Transitive.
    intros.
    destruct x, y, z.
    simpl; simpl in H, H0.
    omega.
  Qed.
  Definition lt_strorder :=
    Build_StrictOrder t lt name_irrefl name_trans_lt.
  Theorem lt_compat : Proper (eq ==> eq ==> iff) lt.
  Proof.
    unfold Proper, respectful, iff.
    intros.
    destruct x, y, x0, y0.
    simpl; simpl in H, H0.
    omega.
  Qed.
  Definition compare :=
    fun name1 name2 =>
      match name1, name2 with
        | name_cons n1, name_cons n2 => nat_compare n1 n2
      end.
  Theorem compare_spec : forall x y : t,
    CompareSpec (eq x y) (lt x y) (lt y x) (compare x y).
  Proof.
    destruct x, y.
    simpl.
    remember (nat_compare n n0).
    destruct c.
      apply CompEq.
      apply nat_compare_eq.
      auto.

      apply CompLt.
      apply nat_compare_lt.
      auto.

      apply CompGt.
      apply nat_compare_gt.
      auto.
  Qed.
  Theorem eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
  Proof.
    destruct x, y.
    simpl.
    apply eq_nat_dec.
  Qed.
End NameOrderedType.


Theorem Modus_ponens : forall P Q : Prop, P -> (P -> Q) -> Q.
Proof.
  intros.
  apply H0.
  assumption.
Qed.


Require Utf8.

Require Import S00_setoid_basics S30_IdType.

(* Discrete setoids *)

Definition isDscrStd (A : setoid) : Set
  := ∀ x x' : A, x ≈ x' ↔ x == x'.

Definition dscrStd : Set → setoid.

  intro X. apply (Build_setoid X Identity).
  apply (Build_setoidaxioms).
  intro x. apply rfl.
  intros x x' p. apply (p ⁻¹).
  intros x x' x'' p p'. apply (p ⊙ᵐ p').
Defined.

(* Discrete setoid families *)

(* Definition 5.1 *)

Definition isDscrStdFam {X : Set}(B : setoidfamily (dscrStd X)) : Set
  := ∀ x, ∀ b b' : B x,
      b ≈ b' ↔ ∃ p : x == x, |B|•ᵐp b == b'.

(* Discrete setoid family of a type family *)

Section DscrStdF.
  Context {X : Set}(Y : X → Set).

  Definition dscrStdfam_std (x : X) : setoid.

    apply (Build_setoid (Y x) (λ y y', ∃ p : x == x, Y•ᵐp y == y')).
    apply (Build_setoidaxioms).
    intro y. exists rfl. apply rfl.
    intros y y' [p q]. exists (p ⁻¹). apply Identity_sym.
    apply transpflip. apply q.
    intros y y' y'' [p q] [p' q'].
    exists (p⊙ᵐp').
    apply (transpcmp Y p p' q q').
  Defined.

  Definition dscrStdfam_map {x x' : X}(p : x == x')
    : dscrStdfam_std x ⇒ dscrStdfam_std x'.

    apply (Build_setoidmap (dscrStdfam_std x) (dscrStdfam_std x') (transp Y p)).
    intros y y' [p' q].
    destruct p. cbn. exists p'. apply q.
  Defined.

  Definition dscrStdfam : setoidfamily (dscrStd X).

    apply (Build_setoidfamily (dscrStd X) dscrStdfam_std (λ x x' p, dscrStdfam_map p)).
    apply (Build_setoidfamilyaxioms).
    intros x y. cbn. exists rfl. apply rfl.
    intros x x' p p' y. cbn. exists (p ⁻¹ ⊙ᵐ p').
    destruct p. apply rfl.
    intros x x' x'' p p' y. cbn. exists rfl.
    apply Identity_sym. apply (Id2HΠ (transpIsFunct p p') y).
  Defined.
End DscrStdF.

(* Transport of setoid families over discrete setoids is *)
(* equal to transport of the underlying type families    *)

Lemma StdFamObj_aux {X : Set}(B : setoidfamily (dscrStd X)){x x' : X}(p : x == x')
  : ∀ b, B•p b ≈ |B|•ᵐp b.
Proof.
  intro b. induction p. simpl. apply (setoidfamilyref B).
Qed.

(* Equation (31) *)

Lemma trspDscrSF {X : Set}{B : setoidfamily (dscrStd X)}
       (isdscrsf : isDscrStdFam B){x x' : X}(p : x == x')
  : ∀ b, ∃ l : x' == x',
             |B|•ᵐl (B•p b) == |B|•ᵐp b.
Proof.
  intro b. set (eq := fst (isdscrsf x' _ _) (StdFamObj_aux B p b)).
  apply eq.
Qed.


(*Check dec_nat.*)
Require Import Coq.Arith.Arith.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import List.
Import ListNotations.

Section nod.
Context {A:Type}.
Context (decA: forall x y : A, {x = y} + {x <> y}).

Fixpoint nodup (l : list A) : list A :=
  match l with
    | [] => []
    | x::xs => if in_dec decA x xs then nodup xs else x::(nodup xs)
  end.
End nod.

Check Bool.bool_dec.
Definition count_uniques (l : list nat) : nat :=
  length (nodup eq_nat_dec l).

Eval compute in count_uniques [1; 2; 2; 4; 1].

Fixpoint A2 l :fold_left orb l true = true.
Proof.
destruct l; simpl.
reflexivity.
apply A2.
Defined.

Theorem A1 (x y:bool): (orb x y = false)->(x=false)/\(y=false).
Proof. intro H. destruct x, y; firstorder || inversion H. Defined.

Fixpoint A0 b l : fold_left orb (b :: l) false = orb b (fold_left orb l false) .
Proof.
destruct l.
simpl. firstorder.
simpl.
destruct b.
simpl.
apply A2.
simpl.
reflexivity.
Defined.

Fixpoint all_then_some (l:list bool) {struct l}:
(List.fold_left orb l false) = false ->
(forall (p:nat), (List.nth p l false) = false).
Proof.
intros.
destruct l. simpl. destruct p; trivial.
simpl.
rewrite A0 in H.
pose (Q:=A1 _ _ H).
destruct Q.
destruct p. trivial.
apply all_then_some.
trivial.
Defined.
(*
compute.

destruct b0;simpl.
simpl.
unfold fold_left.
destruct b.

Admitted.

assert (A0 :
unfold fold_left in H.
2 : {


Require Export List Program Arith Omega MoreList.
Export Nat.
Set Implicit Arguments.
Inductive letter := M | I | U.
Inductive Generatable { init } : list letter -> Prop :=
| Init : Generatable init
| Rule1 : forall l, Generatable (l ++ [I]) -> Generatable (l ++ [I;U])
| Rule2 : forall l, Generatable (M :: l) -> Generatable (M :: l ++ l)
| Rule3 : forall l r, Generatable (l ++ I :: I :: I :: r) -> Generatable (l ++ U :: r)
| Rule4 : forall l r, Generatable (l ++ U :: U :: r) -> Generatable (l ++ r).
Arguments Generatable : clear implicits.
Arguments Init : clear implicits.
Hint Constructors Generatable letter.
Theorem Rule1' i l r : l = r ++ [I;U] -> Generatable i (r ++ [I]) -> Generatable i l.
  intros;subst;auto.
Qed.
Theorem Rule2' i l r : l = M :: r ++ r -> Generatable i (M :: r) -> Generatable i l.
  intros;subst;auto.
Qed.
Theorem Rule3' i li l r : li = l ++ U :: r ->
  Generatable i (l ++ I :: I :: I :: r) -> Generatable i li.
  intros;subst;auto.
Qed.
Theorem Rule4' i li l r : li = l ++ r ->
  Generatable i (l ++ U :: U :: r) -> Generatable i li.
  intros;subst;auto.
Qed.
Goal Generatable [M;I;U] [M;I;U;I;U].
  eapply Rule2';eauto;eauto.
Qed.
Goal Generatable [M;U;M] [M;U;M;U;M].
  eapply Rule2';eauto;eauto.
Qed.
Goal Generatable [M;U] [M;U;U].
  eapply Rule2';eauto;eauto.
Qed.
Goal Generatable [U;M;I;I;I;M;U] [U;M;U;M;U].
  eapply Rule3' with (l := [U;M])(r := [M;U]);eauto.
Qed.
Goal Generatable [M;I;I;I;I] [M;I;U].
  eapply Rule3' with (l := [M;I])(r := []);eauto.
Qed.
Goal Generatable [M;I;I;I;I] [M;U;I].
  eapply Rule3' with (l := [M])(r := [I]);eauto.
Qed.
Goal Generatable [M;I;I;I] [M;U].
  eapply Rule3' with (l := [M])(r := []);eauto.
Qed.
Goal Generatable [U;U;U] [U].
  eapply Rule4' with (l := [U])(r := []);eauto.
Qed.
Goal Generatable [M;U;U;U;I;I;I] [M;U;I;I;I].
  eapply Rule4' with (l := [M;U])(r := [I;I;I]);eauto.
Qed.
Theorem gen_non_div_three l : Generatable [M;I] l ->
  ~ divide 3 (fold_left (fun (n : nat) e => match e with M => 0 | I => 1 | U => 3 end + n) l 0).
  induction 1;
  unfold divide in *;
  repeat (rewrite !fold_left_app in *||simpl in *);
  intuition;
  match goal with H : exists _, _ |- _ => destruct H end;
  omega||apply IHGeneratable.
  destruct x;omega||exists x;omega.
  erewrite (foldl_identity ((fun (n : nat) (e : letter) => match e with
                                              | M => 0
                                              | I => 1
                                              | U => 3
                                              end + n))) in H0.
Admitted.
Goal ~ Generatable [M;I] [M;U].
  intuition;apply gen_non_div_three in H.
  simpl in *;intuition.
Qed.


Module Form.

Require Export name_arq.

Import Name.

Inductive Formula : Type :=
  | TRUE_FORMULA : Formula
  | FALSE_FORMULA : Formula
  | NAME_FORMULA : Name -> Formula
  | NOT_FORMULA : Formula -> Formula
  | AND_FORMULA : Formula -> Formula -> Formula
  | IMPLIES_FORMULA : Formula -> Formula -> Formula.

End Form.


Require Import List.

Notation "[]" := nil.
Notation "[ a ]" := (cons a nil).
Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).
Infix "::" := cons.

Definition type_context := list nat.

Fixpoint type_lower (tc :type_context) : type_context :=
  match tc with
    | [] => []
    | n::t => match n with
                | 0 => type_lower t
                | S n' => n'::(type_lower t)
              end
  end.

(* typing derivations carry their terms with them *)
Inductive type : type_context -> Type :=
| type_top : type []
| type_var : forall n, type [n]
| type_arrow : forall L M, type L -> type M -> type (L++M)
| type_all : forall L, type L -> type (type_lower L)
| type_fp : forall L, type L -> type (type_lower L).
Implicit Arguments type_arrow [L M].
Implicit Arguments type_all [L].
Implicit Arguments type_fp [L].
Coercion type_var : nat >-> type.

Inductive post_type : Type :=
| post_type_top : post_type
| post_type_var : nat -> post_type
| post_type_arrow : post_type -> post_type -> post_type
| post_type_all : post_type -> post_type
| post_type_fp : post_type -> post_type.

Inductive type_eq : forall C C', type C -> type C' -> Prop :=
| type_eq_top : type_eq [] [] type_top type_top
| type_eq_var : forall n n', n = n' -> type_eq [n] [n'] (type_var n) (type_var n')
| type_eq_arrow : forall L M A B L' M' A' B',
  type_eq L L' A A' ->
  type_eq M M' B B' ->
  type_eq (L++M) (L'++M') (type_arrow A B) (type_arrow A' B')
| type_eq_all : forall L L' A A',
  type_eq L L' A A' ->
  type_eq (type_lower L) (type_lower L') (type_all A) (type_all A')
| type_eq_fp : forall L L' A A',
  type_eq L L' A A' ->
  type_eq (type_lower L) (type_lower L') (type_fp A) (type_fp A').
Implicit Arguments type_eq [C C'].
Hint Constructors type_eq.

Definition type_simpl : forall C, type C -> post_type.
Proof.
  induction 1.
  apply post_type_top.
  apply (post_type_var n).
  apply (post_type_arrow IHtype1 IHtype2).
  apply (post_type_all IHtype).
  apply (post_type_fp IHtype).
Defined.
Implicit Arguments type_simpl [C].

Theorem type_eq_impl_simpl_eq : forall C C' (A:type C) (B:type C'), type_eq A B -> (type_simpl A) = (type_simpl B).
Proof.
  intros C C' A B. induction 1.
  (* top *)
  reflexivity.
  (* var *)
  subst. reflexivity.
  (* arrow *)
  simpl. rewrite IHtype_eq1. rewrite IHtype_eq2. reflexivity.
  (* all *)
  simpl. rewrite IHtype_eq. reflexivity.
  (* fp *)
  simpl. rewrite IHtype_eq. reflexivity.
Defined.

Theorem type_eq_impl_context : forall C C' (A:type C) (B:type C'), type_eq A B -> C = C'.
Proof.
  intros C C' A B. induction 1 ; subst ; auto.
Defined.

Require Import JMeq.
Lemma type_eq_impl_jmeq : forall L M (A :type L) (B:type M),
  type_eq A B -> JMeq A B.
Proof.
  intros L M A B ; induction 1. reflexivity. subst ; auto.
  (* arrow *)
  cut (type_eq A A'). intros HeqA. apply type_eq_impl_context in HeqA. subst.
  apply JMeq_eq in IHtype_eq1. rewrite IHtype_eq1.
  cut (type_eq B B'). intros HeqB. apply type_eq_impl_context in HeqB. subst.
  apply JMeq_eq in IHtype_eq2. rewrite IHtype_eq2. reflexivity. auto. auto.
  (* all *)
  cut (type_eq A A'). intros HeqA. apply type_eq_impl_context in HeqA. subst.
  apply JMeq_eq in IHtype_eq. rewrite IHtype_eq. auto. auto.
  (* fp *)
  cut (type_eq A A'). intros HeqA. apply type_eq_impl_context in HeqA. subst.
  apply JMeq_eq in IHtype_eq. rewrite IHtype_eq. auto. auto.
Defined.

Lemma type_eq_refl : forall L (A:type L), type_eq A A.
Proof.
  induction A ; auto.
Defined.

Lemma type_eq_symm : forall L M (A:type L) (B:type M), type_eq A B -> type_eq B A.
Proof.
  induction 1 ; auto.
Defined.

Lemma type_eq_trans : forall L M N (A:type L) (B:type M) (C:type N), type_eq A B -> type_eq B C -> type_eq A C.
Proof.
  induction 2 ; auto.
  subst ; auto.
  (* arrow *)
  inversion H. simpl. subst.
  dependent rewrite H3. simpl.
  assert (L0 = L'). eapply type_eq_impl_context with (A:=A0) (B:=A'). auto.
  assert (M = M'). eapply type_eq_impl_context with (A:=B) (B:=B'). auto. auto.
  apply type_eq_impl_jmeq in H0_. apply type_eq_impl_jmeq in H0_0. subst.
  apply JMeq_eq in H0_. subst. apply JMeq_eq in H0_0. subst. auto.
  (* all *)
  assert (L0 = L'). eapply type_eq_impl_context. eauto. subst.
  apply type_eq_impl_jmeq in H0. apply JMeq_eq in H0. subst ; auto.
  (* fp *)
  assert (L0 = L'). eapply type_eq_impl_context. eauto. subst.
  apply type_eq_impl_jmeq in H0. apply JMeq_eq in H0. subst ; auto.
Defined.

Require Import Arith.
Infix "===" := eq_nat_dec (at level 50).
Definition type_eq_dec : forall C C' (A:type C) (B:type C'), {type_eq A B} + {~ type_eq A B}.
Proof.
  refine (fix type_eq_dec (C C' : type_context) (A : type C) (B : type C') {struct A} := _).
  destruct A ; destruct B ; try (right ; unfold not ; intros H ; inversion H ; fail).
  (* top *)
  left ; auto.
  (* var *)
  case (n === n0). intros. subst. left. auto.
  intros. right. unfold not ; intros. inversion H. congruence.
  (* arrow *)
  case (type_eq_dec L L0 A1 B1) ; case (type_eq_dec M M0 A2 B2).
  intros. left. auto.
  intros. right. unfold not. intros.
  unfold not in n. apply n.
  inversion H. dependent rewrite <- H7. dependent rewrite <- H12.
  simpl. auto.
  intros. right. unfold not. intros.
  unfold not in n. apply n.
  inversion H. dependent rewrite <- H6. dependent rewrite <- H11.
  simpl. auto.
  intros. right. unfold not. intros.
  unfold not in n. apply n.
  inversion H. dependent rewrite <- H7. dependent rewrite <- H12.
  simpl. auto.
  (* all *)
  case (type_eq_dec L L0 A B). intros. left. auto.
  intros. right. unfold not. intros. unfold not in n. apply n.
  inversion H. subst. dependent rewrite <- H5. dependent rewrite <- H8. simpl. auto.
  (* fp *)
  case (type_eq_dec L L0 A B). intros. left. auto.
  intros. right. unfold not. intros. unfold not in n. apply n.
  inversion H. subst. dependent rewrite <- H5. dependent rewrite <- H8. simpl. auto.
Defined.

Definition eq_type_dec : forall C (A:type C) (B:type C), {A = B} + {~ A = B}.
Proof.
  intros.
  case (type_eq_dec C C A B). intros.
  apply type_eq_impl_jmeq in t.
  left. apply JMeq_eq. auto.
  intros.
  right. unfold not. intros. apply n. rewrite H. auto.
  apply type_eq_refl.
Defined.

Definition remove_nat (n:nat) (l:list nat) := remove eq_nat_dec n l.
Hint Unfold remove_nat.
Notation "L // k" := (remove_nat k L) (at level 62).

Lemma cons_distr : forall a L k, (a :: L // k) = ([a] // k) ++ L // k.
Proof.
  intros. unfold remove_nat. simpl.
  case_eq (k===a). intros. rewrite e. simpl. reflexivity.
  intros. simpl. rewrite H. auto.
Defined.

Lemma append_distr : forall L M k, (L // k) ++ (M // k) = (L ++ M // k).
Proof.
  induction L. simpl. auto.
  intros.
  rewrite <- app_comm_cons.
  rewrite cons_distr. simpl.
  case_eq (k===a). intros. simpl. apply IHL.
  intros. simpl. rewrite H. simpl. f_equal. apply IHL.
Defined.

Lemma type_lower_open : forall L k, type_lower (L // (S k)) = type_lower L // k.
Proof.
  intros. induction L. simpl. auto.
  simpl. destruct a. simpl. auto.
  simpl. case_eq (k===a).
  intros. simpl. auto.
  intros. simpl. f_equal. auto.
Defined.

Definition type_open_rec (TC:type_context) (k : nat) (u : type []) (T : type TC) : type (TC//k).
Proof.
  refine
    (fix type_open_rec (TC:type_context) (k : nat) (u : type []) (T : type TC) {struct T} : type (TC//k) :=
      match T in type M return type (M//k) with
        | type_top => type_top
        | type_var i =>
          match k === i with
            | left Hl => _
            | right Hr => _
          end
        | type_arrow L M T1 T2 => _
        | type_all L T' => _
        | type_fp L T' => _
      end).
  (* var *)
  subst ; unfold remove_nat ; unfold remove ;
    case_eq (i===i) ; intros ; auto ; intros ; absurd (i=i) ; auto.
  unfold remove_nat ; unfold remove ;
    case_eq (i===k) ; intros ; auto. rewrite e. destruct (k===k). auto.
  rewrite e in Hr. cut (k=k). intros. apply Hr in H0. inversion H0. auto.
    case_eq (k===i) ; intros. auto.
    apply type_var.
  (* arrow *)
    rewrite <- append_distr.
    eapply type_arrow ; apply type_open_rec ; auto.
  (* all *)
    rewrite <- type_lower_open.
    eapply type_all. apply type_open_rec. auto. auto.
  (* fp *)
    rewrite <- type_lower_open.
    eapply type_all. apply type_open_rec. auto. auto.
Defined.
Implicit Arguments type_open_rec [TC].

Print type_open_rec.
Print eq_rec.

(*
Definition lower_roll TC : type (type_lower TC // 0) ->  type (type_lower TC).
Proof.
  intros. rewrite <- lower_zero. auto.
*)

Definition type_open : type [0] -> type [] -> type [].
Proof.
  intros A u. apply (type_open_rec 0 u A).
Defined.

Inductive typ : Type :=
| typ_base : forall L, type L -> typ.

Definition context := list (nat * typ)%type.

Fixpoint lower (c : context) : context :=
  match c with
    | [] => []
    | (n,T)::t => match n with
                    | 0 => lower t
                    | S n' => (n',T)::(lower t)
                  end
  end.

Inductive term : forall TC, context -> type TC -> Type :=
| unit : term [] [] type_top
| var : forall TC (A :type TC) n, term TC [(n,(typ_base TC A))] A
| abs : forall TC1 TC2 A B L,
  term TC2 L B ->
  term (TC1++TC2) (lower L) (type_arrow A B)
| fp : forall TC L A, term TC L A -> term TC L A
| app : forall TC1 TC2 L1 L2 A B,
  term (TC1++TC2) L1 (type_arrow A B) ->
  term TC1 L2 A ->
  term TC2 (L1++L2) B
(* type folding/unfolding isomorphism *)
| unroll : forall A L,
  term (type_lower [0]) L (type_fp A) ->
  term [] L (type_open A (type_fp A))
| roll : forall A L,
  term [] L (type_open A (type_fp A)) ->
  term (type_lower [0]) L (type_fp A)
(* type abstraction and application *)
| abst : forall TC L A,
  term (type_lower TC) L (type_all A)
| appt : forall L A,
  term (type_lower [0]) L (type_all A) ->
  forall (B : type []),
    term [] L (type_open A B).
Implicit Arguments var [TC].
Implicit Arguments abs [TC1 TC2 L B].
Implicit Arguments fp [TC L A].
Implicit Arguments app [TC1 TC2 L1 L2 A B].
Implicit Arguments unroll [A L].
Implicit Arguments roll [A L].
Implicit Arguments abst [TC L A].
Implicit Arguments appt [L A].

Notation "'T" := type_top (at level 60).
Infix "-->" := type_arrow (at level 61).
Notation "'All E" := (type_all E) (at level 62).
Notation "'Rec E" := (type_fp E) (at level 62).

Fixpoint type_in (TC : type_context) (A : type TC) (C:context) (k : nat) : Prop :=
  match C with
    | nil => False
    | ((n,typ_base TC' A')::C') => ((k=n) /\ (type_eq A' A)) \/ (type_in TC A C' k)
  end.

Definition type_in_dec (TC:type_context) (A:type TC) (C:context) (k:nat) : {type_in TC A C k} + {~ type_in TC A C k}.
Proof.
  intros TC A ; induction C.
  right. simpl. auto.
  intros. destruct a. destruct t. simpl.
  case_eq (k === n) ; case_eq (type_eq_dec L TC t A) ; case_eq (IHC k) ; intros ;
    try (left; left ; split ; auto ; fail) ;
      try (left ; right ; auto ; fail).
  right ; unfold not ; intros Hnew. inversion Hnew. inversion H1. inversion H2. auto. auto.
  right ; unfold not ; intros Hnew. inversion Hnew. inversion H2. congruence. congruence.
  right ; unfold not ; intros Hnew. inversion Hnew. inversion H1. inversion H2. auto. auto.
Defined.

Definition weaken (k:nat) (C:context) : { C' :context | forall (TC:type_context) (A:type TC), ~ type_in TC A C' k}.
Proof.
  refine
    (fix weaken (k :nat) (C : context) {struct C} : { C' :context | forall (TC:type_context) (A:type TC), ~ type_in TC A C' k} :=
      match C return { C' :context | forall (TC:type_context) (A:type TC), ~ type_in TC A C' k} with
        | nil => exist _ nil _
        | ((n,T)::t)=> match k === n with
                         | left Hl => match weaken k t with
                                        | exist l P => exist _ l _
                                      end
                         | right Hr => match weaken k t with
                                         | exist l P => exist _ ((n,T)::l) _
                                       end
                       end
      end).
  intros. simpl. auto.
  intros. apply P.
  intros. simpl. case T. intros. unfold not. intros.
  inversion H. inversion H0. congruence. eapply P. eauto.
Defined.

Fixpoint weaken_weak (k :nat) (C : context) {struct C} : context :=
  match C with
    | nil => nil
    | ((n,T)::t)=> match k === n with
                     | left H => weaken_weak k t
                     | right H => (n,T)::(weaken_weak k t)
                   end
  end.
Notation "L /// k" := (weaken_weak k L) (at level 62).

Lemma lower_open : forall L k, lower (L /// (S k)) = lower L /// k.
Proof.
  induction L. simpl. intros. auto.
  intros. simpl.
  destruct a. destruct t.
  destruct n. simpl. auto.
  intros.
  intros.
  case_eq (k === n). intros. simpl. rewrite H. auto.
  intros. simpl. rewrite H. f_equal. auto.
Defined.

Lemma type_not_in_weaken : forall TC A C k, ~ type_in TC A (C///k) k.
Proof.
  intros TC A. induction C. intros. simpl. auto.
  intros. unfold not. intros.
  destruct a. simpl in H. case_eq (k===n). intros. rewrite H0 in H.
  unfold not in IHC. eapply IHC. eauto.
  intros.
  rewrite H0 in H. simpl in H. destruct t.
  inversion H. inversion H1. congruence.
  unfold not in IHC. eapply IHC. eauto.
Defined.

Lemma type_in_one_impl_eq : forall TC A B k n, type_in TC B ((n, typ_base TC A) :: []) k -> k = n -> A = B.
Proof.
  intros. apply JMeq_eq. apply type_eq_impl_jmeq. simpl in H. inversion H. inversion H1. auto. inversion H1.
Defined.

Lemma type_in_one_not_impl_eq : forall TC A B k n, type_in TC B ((n, typ_base TC A) :: []) k -> k <> n -> A <> B.
Proof.
  intros. simpl in H. inversion H. inversion H1. unfold not. intros. congruence.
  inversion H1.
Defined.

Definition open_rec (A B:type []) (L:context) (k : nat) (H : type_in [] B L k) (u : term [] [] B) (T : term [] L A) : term [] (L///k) A.
Proof.
  refine (fix open_rec (A B:type []) (L:context) (k : nat) (H : type_in [] B L k) (u : term [] [] B) (T : term [] L A) : term [] (L///k) A := _).
  destruct T.
  (* top*)
  simpl. apply unit.
  (* var *)
  case_eq (k === n). intros.
  apply type_in_one_impl_eq in H. simpl. rewrite H0. rewrite H. auto. auto. intros.
  apply type_in_one_not_impl_eq in H. simpl. rewrite H0.
  apply var. auto.
  (* abs *)
  rewrite <- lower_open.
  apply abs.

  intros A B L. k H u T. generalize dependent k.

  ; induction T.
  (* top *)
  intros ; simpl. try (intros H) ; inversion H.
  (* var *)
  intros.
  case_eq (type_in_dec TC B ((n,typ_base TC A) :: []) k) ; case_eq (k===n) ; case_eq (type_eq_dec TC TC A B) ;
  intros ; try (simpl in * ; rewrite H0 in H2 ; rewrite H1 in H2 ; try rewrite H1).
  cut (A = B). intros. rewrite H3. auto. apply JMeq_eq. apply type_eq_impl_jmeq ; auto.
  absurd (type_eq A B). auto. inversion H. inversion H3. auto. inversion H3.
  absurd (k = n). auto. inversion t0. inversion H3. auto. inversion H3.
  absurd (k = n). auto. inversion t. inversion H3. auto. inversion H3.
  absurd (k = n /\ type_eq A B \/ False). auto.
  left. split. auto. auto.
  congruence. apply var.
  (* abs *)
  congruence.
  intros. rewrite <- lower_open. apply abs. eapply IHT.
  (* next*)
  Focus 2. intros. eapply IHT. eauto. eauto.
  (* next *)
  Focus 2. intros.

  simpl in *.
  intros.
  intros. case_eq (k=== n)

  simpl. case_eq (k === n). intros.
  case_eq (type_in_dec TC B ((n, typ_base TC A) :: []) k).
  intros. simpl in t.
  simpl in H1. rewrite H0 in H1. simpl in H1.
  case_eq (type_eq_dec TC TC A B). intros. rewrite H2 in H1.
  cut (A = B). intros. rewrite H3. exact u.
  apply JMeq_eq. apply type_eq_impl_jmeq. auto.
  intros. rewrite H2 in H1. simpl in *. inversion H1.
  intros. congruence.
  intros.
  case_eq (type_in_dec TC B ((n, typ_base TC A) :: []) k).
  intros. simpl in H1. auto.
  simpl in H1.
inversion t.
  inversion H.

Defined.

Defined.
(* replace a bvar with a term *)
Fixpoint open_rec (k : nat) (u : term []) (e : term [k]) {struct e} : term :=
  match e with
    | var i => if k === i then u else (var i)
    | abs e1 => abs (open_rec (S k) u e1)
    | fp e => fp (open_rec (S k) u e)
    | app e1 e2 => app (open_rec k u e1) (open_rec k u e2)
    | proj1 t => proj1 (open_rec k u t)
    | proj2 t => proj2 (open_rec k u t)
    | prod a b => prod (open_rec k u a) (open_rec k u b)
    | inl l => inl (open_rec k u l)
    | inr r => inr (open_rec k u r)
    | cas e e1 e2 =>
      cas (open_rec k u e)
      (open_rec (S k) u e1)
      (open_rec (S k) u e2)
    | unit => unit
  end.

Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).

(* opening that just replaces an outermost abstraction *)
Definition open e u := open_rec 0 u e.

Definition open_times n e u :=
  match n with
    | 0 => e
    | S n' => open_rec n' u e
  end.

(* local closure: well formedness wrt lambda abstraction *)
Inductive lc : term -> Prop :=
| lc_fvar : forall x, lc (fvar x)
| lc_abs : forall L e,
  (forall x:atom, x `notin` L -> lc (open e (fvar x))) ->
  lc (abs e)
| lc_app : forall e1 e2,
  lc e1 ->
  lc e2 ->
  lc (app e1 e2)
| lc_unit : lc unit
| lc_fp : forall L e,
  (forall x:atom, x `notin` L -> lc (open e (fvar x))) ->
  lc (fp e)
| lc_proj1 : forall e,
  lc e ->
  lc (proj1 e)
| lc_proj2 : forall e,
  lc e ->
  lc (proj2 e)
| lc_prod : forall e1 e2, lc e1 -> lc e2 -> lc (prod e1 e2)
| lc_inl : forall e, lc e -> lc (inl e)
| lc_inr : forall e, lc e -> lc (inr e)
| lc_cas : forall L e e1 e2,
  lc e ->
  (forall x:atom, x `notin` L -> lc (open e1 (fvar x))) ->
  (forall x:atom, x `notin` L -> lc (open e2 (fvar x))) ->
  lc (cas e e1 e2).
Hint Constructors lc.

Lemma open_lc_diff : forall e j v i u,
  i <> j ->
  {j ~> v} e = {i ~> u} ({j ~> v} e) ->
  e = {i ~> u} e.
Proof.
  induction e ; intros j v i u Hdiff ; try ( intros ; simpl in * ; f_equal ; intros ; inversion H ; eauto ; fail).
  (* bvar *)
  simpl in *. case (j === n) ; case (i === n) ; intros ; auto with arith ; try congruence. subst. simpl in H.
  case_eq (n===n). intros. rewrite H0 in H. auto. intros. congruence.
Defined.

Lemma open_lc : forall k u e, lc e -> e = {k ~> u} e.
Proof.
  intros.  generalize dependent k.
  induction H ; simpl ; try (intros ; f_equal ; intuition)
    ; pick fresh x for L ; intros ;
      apply open_lc_diff with (i := S k) (j := 0) (u := u) (v := (fvar x)) ; auto ;
        unfold open in H0 ; eauto ; firstorder.
Defined.

Lemma subst_open_rec : forall e1 e2 u x k,
  lc u ->[x ~> u] ({k ~> e2} e1) = {k ~> [x ~> u] e2} ([x ~> u] e1).
Proof.
  induction e1; intros e2 u x k Hlc; try (simpl in *; f_equal; auto ; fail).
  (* bvar *)
  simpl ; case (k === n) ; intros ; auto.
  (* fvar *)
  simpl ; case (a == x) ; intros ; eapply open_lc ; auto.
Defined.

Lemma subst_open_var : forall (x y : atom) u e,
  y <> x ->
  lc u ->
  open ([x ~> u] e) y = [x ~> u] (open e y).
Proof.
  intros x y u e Neq H.
  unfold open.
  rewrite subst_open_rec with (e2 := y).
  simpl.
  destruct (y == x).
    Case "y=x".
    destruct Neq. auto.
    Case "y<>x".
    auto.
  auto.
Qed.

Ltac pick_fresh Y :=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
    set (Y := (A `union` B)).

Lemma subst_lc : forall (x : atom) u e,
  lc e ->
  lc u ->
  lc ([x ~> u] e).
Proof.
  intros x u e He Hu.
  induction He ; try (simpl in * ; f_equal ; eauto ; intuition ; fail).
  Case "lc_var".
   simpl.
   destruct (x0 == x).
     auto.
     auto.
  Case "lc_abs".
   simpl.
    apply lc_abs with (L := L `union` singleton x).
    intros x0 Fr.
    rewrite subst_open_var. auto. auto. auto.
  Case "lc_fp".
   simpl.
    apply lc_fp with (L := L `union` singleton x).
    intros x0 Fr.
    rewrite subst_open_var. auto. auto. auto.
  Case "lc_cas".
   simpl.
    apply lc_cas with (L := L `union` singleton x) ; auto.
    (* inl *)
    intros x0 Fr.
    rewrite subst_open_var. auto. auto. auto.
    (* inr *)
    intros x0 Fr.
    rewrite subst_open_var. auto. auto. auto.
Defined.

(* single step operational semantics *)
Inductive eval : term -> term -> Prop :=
| eval_beta : forall e1 e2,
  lc (abs e1) ->
  lc e2 ->
  eval (app (abs e1) e2) (open e1 e2)
| eval_fp : forall e1,
  lc (fp e1) ->
  eval (fp e1) (open e1 (fp e1))
| eval_proj1 : forall e1 e2,
  lc e1 ->
  lc e2 ->
  eval (proj1 (prod e1 e2)) e1
| eval_proj2 : forall e1 e2,
  lc e1 ->
  lc e2 ->
  eval (proj2 (prod e1 e2)) e2
| eval_cas_1 : forall e e1 e2,
  lc (inl e) ->
  lc (abs e1) ->
  lc (abs e2) ->
  eval (cas (inl e) e1 e2) (open e1 e)
| eval_cas_2 : forall e e1 e2,
  lc (inr e) ->
  lc (abs e1) ->
  lc (abs e2) ->
  eval (cas (inr e) e1 e2) (open e2 e)
(* experiments / atomic evaluation contexts ala Felleisen *)
| eval_proj1_exp : forall e e',
  eval e e' ->
  eval (proj1 e) (proj1 e')
| eval_proj2_exp : forall e e',
  eval e e' ->
  eval (proj2 e) (proj2 e')
| eval_app_exp : forall e1 e1' e2,
  lc e2 ->
  eval e1 e1' ->
  eval (app e1 e2) (app e1' e2)
| eval_cas_exp : forall e e' e1 e2,
  lc (abs e1) ->
  lc (abs e2) ->
  eval e e' ->
  eval (cas e e1 e2) (cas e' e1 e2).

Hint Constructors eval.

Lemma subst_fresh : forall (x : atom) e u,
  x `notin` fv e -> [x ~> u] e = e.
Proof.
  intros x e u H.
  induction e ; try (simpl in * ; f_equal ; auto ; auto).
  Case "fvar".
   simpl.
   destruct (a == x).
    Case "a=x".
      subst. simpl fv in H. decideFSet.
    Case "a<>x".
      auto.
Qed.

Lemma subst_intro : forall (x : atom) u e,
  x `notin` (fv e) ->
  lc u ->
  open e u = [x ~> u](open e x).
Proof.
  intros x u e H J.
  unfold open.
  rewrite subst_open_rec; auto.
  simpl.
  destruct (x == x).
  Case "x = x".
    rewrite subst_fresh; auto.
  Case "x <> x".
    destruct n; auto.
Qed.

Lemma open_abs : forall e u,
  lc (abs e) ->
  lc u ->
  lc (open e u).
Proof with auto using subst_lc.
  intros e u H J.
  inversion H; subst.
  pick fresh y for (L `union` (fv e)).
  rewrite (subst_intro y). eauto using subst_lc. eauto. eauto.
Qed.

Lemma open_fp : forall e u,
  lc (fp e) ->
  lc u ->
  lc (open e u).
Proof with auto using subst_lc.
  intros e u H J.
  inversion H; subst.
  pick fresh y for (L `union` (fv e)).
  rewrite (subst_intro y). eauto using subst_lc. eauto. eauto.
Defined.

Lemma eval_regular : forall e1 e2,
  eval e1 e2 -> lc e1 /\ lc e2.
Proof.
  intros e1 e2 H ; induction H; intuition ; auto using open_abs, open_fp.
  (* inl *)
  apply lc_cas with (L:= (fv e1)) ; auto ;
    intros ; apply open_abs ; auto.
  apply open_abs ; auto ; inversion H ; auto.
  (* inr *)
  apply lc_cas with (L:= (fv e2)) ; auto ;
    intros ; apply open_abs ; auto.
  apply open_abs ; auto ; inversion H ; auto.
  (* cas context *)
  apply lc_cas with (L:= (fv (cas e e1 e2))) ; auto ;
  intros ; apply open_abs ; auto ; f_equal ;
    try (apply open_abs ; auto ; inversion H ; auto).
  apply lc_cas with (L:= (fv (cas e e1 e2))) ; auto ;
  intros ; apply open_abs ; auto ; f_equal ;
    try (apply open_abs ; auto ; inversion H ; auto).
Qed.

(* reduction relation *)
Inductive reduces : term -> Prop :=
| reduces_base :
  forall a, (exists b, eval a b) -> reduces a.

(* multi-step reduction relation *)
Inductive multistep : term -> term -> Prop :=
| multistep_refl : forall a, multistep a a
| multistep_eval : forall a b, eval a b -> multistep a b.

Inductive evaluates : term -> term -> Prop :=
| evaluates_base : forall a b, multistep a b -> ~(reduces b) -> evaluates a b.

Inductive converges : term -> Prop :=
| converges_base : forall a, (exists b, evaluates a b) -> converges a.

Inductive diverges : term -> Prop :=
| diverges_base : forall a, (forall b, multistep a b -> reduces b) -> diverges a.

Hint Constructors evaluates multistep converges diverges.

Lemma diverges_imp_not_converge : forall a, diverges a -> ~(converges a).
Proof.
  intros a H.
  (* -> *)
  inversion H. subst.
  unfold not. intros HC. inversion HC. subst. inversion H1. inversion H2. subst.
  unfold not in H4. apply H4. apply H0. auto.
Defined.

Lemma converges_imp_not_diverge : forall a, converges a -> ~(diverges a).
Proof.
  intros.
  inversion H. subst. inversion H0. inversion H1. subst.
  unfold not. intros Hd. apply H3. inversion Hd. subst. apply H4 in H2. auto.
Defined.

(* omega diverges, for fun *)
Lemma omega_diverges : diverges (fp 0).
Proof.
  intros. constructor. intros. inversion H. subst.
  (* ->* refl *)
  constructor. exists (open 0 (fp 0)). apply eval_fp.
  apply lc_fp with (L := {}). intros. compute. apply lc_fvar.
  subst.
  (* ->* eval *)
  constructor.
  inversion H0. subst. compute in *.
  exists (fp 0). auto.
Defined.

(* this formulation of diverges is much easier to work with *)
CoInductive diverges' : term -> Prop :=
| diverges'_base : forall x, (exists y, eval x y -> diverges' y) -> diverges' x.

Lemma omega_diverges' : diverges' (fp 0).
Proof.
  refine (cofix div : diverges' (fp 0) := _).
  constructor. exists (open 0 (fp 0)). intros. compute in *. auto.
Defined.

Inductive value : term -> Prop :=
| value_fv : forall a, value (fvar a)
| value_abs : forall t, lc (abs t) -> value (abs t)
| value_unit : value unit
| value_prod : forall t1 t2, lc (prod t1 t2) -> value (prod t1 t2)
| value_inl : forall t, lc (inl t) -> value (inl t)
| value_inr : forall t, lc (inr t) -> value (inr t).

Hint Constructors value.

Lemma value_not_reduces : forall t, value t -> ~ (reduces t).
Proof.
  induction t ; intros Hv ; inversion Hv ; unfold not ; intros Hr ; inversion Hr as [x He] ;
    subst ; inversion He as [x H] ; inversion H.
Defined.

Lemma reduces_not_value : forall t, reduces t -> ~ value t.
Proof.
  induction t ; intros Hr ; inversion Hr as [x He] ; subst ; unfold not ; intros Hv ; inversion Hv;
    subst ; inversion He as [x H] ; inversion H.
Defined.

Lemma value_or_reduces : forall t, lc t -> reduces t \/ value t.
Proof.
  intros. induction t ; try (right ; auto ; fail) ; try (left ; auto ; fail).
  inversion H. left. constructor. exists (open t (fp t)). auto.
  left. inversion H. apply IHt1 in H2. apply IHt2 in H3.
  inversion H2. constructor. inversion H4. inversion H5.
  exists (app x t2). apply eval_app_exp. inversion H ; auto. auto.
  subst. inversion H4. subst.
Defined.

Inductive active : term -> Prop :=
| active_prod : forall t1 t2, lc (prod t1 t2) -> active (prod t1 t2)
| active_inl : forall t, lc (inl t) -> active (inl t)
| active_inr : forall t, lc (inr t) -> active (inr t).

Inductive passive : term -> Prop :=
| passive_unit : passive unit
| passive_abs : forall t, lc (abs t) -> passive (abs t)
| passive_fp : forall t, lc (fp t) -> passive (fp t).

Inductive label : Set :=
| label_fvar : forall (b : atom), label
| label_fst
| label_snd
| label_inl
| label_inr
| label_fp
| label_app : forall (b : term), label.

(* we need an arbitrary divergent term of active type *)
Definition inf := inl (fp (inl 0)).

(* create a transition system for our functional programs *)
Inductive trans : term -> label -> term -> Prop :=
| trans_fvar : forall (x : atom), trans x (label_fvar x) x
| trans_fst : forall t1 t2, lc (prod t1 t2) -> trans (prod t1 t2) label_fst t1
| trans_snd : forall t1 t2, lc (prod t1 t2) -> trans (prod t1 t2) label_snd t2
| trans_inl : forall t, lc (inl t) -> trans (inl t) label_inl t
| trans_inr : forall t, lc (inr t) -> trans (inr t) label_inr t
(* | trans_fp : forall t, lc (fp t) -> trans (fp t) label_fp  (open t (fp t)) *)
| trans_app : forall t1 t2, lc (abs t1) -> lc t2 -> trans (abs t1) (label_app t2) (app (abs t1) t2)
| trans_next : forall t1 t2 t3 l, eval t1 t2 -> trans t2 l t3 -> trans t1 l t3.

Hint Constructors trans.

Ltac lc_solve :=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
    match goal with
      | |- lc (fp _) =>
        eapply lc_fp with (L:=(A `union` B)) ; intros ; compute ; try lc_solve
      | |- lc (abs _) =>
        eapply lc_abs with (L:=(A `union` B)) ; intros ; compute ; try lc_solve
      | |- lc (cas _ _ _) =>
        eapply lc_cas with (L:=(A `union` B)) ; intros ; compute ; try lc_solve
      | |- lc (fvar _) =>
        apply lc_fvar ; try lc_solve
      | |- lc (inl _) =>
        apply lc_inl ; try lc_solve
      | |- lc (inr _) =>
        apply lc_inr ; try lc_solve
      | |- lc unit =>
        apply lc_unit ; try lc_solve
      | |- lc (prod _ _) =>
        apply lc_prod ; try lc_solve
      | |- lc (app _ _) =>
            apply lc_app ; try lc_solve
      | |- lc (proj1 _) =>
        apply lc_proj1 ; try lc_solve
      | |- lc (proj2 _) =>
        apply lc_proj2 ; try lc_solve
    end.

(* terms remain locally closed by undergoing a transition *)
Lemma trans_regular : forall t1 t2 l, trans t1 l t2 -> lc t1 /\ lc t2.
Proof.
  intros t1 t2 l H. induction H ; subst ; try (split ; auto ; inversion H ; subst ; auto ; fail ).
  (* fp *)
(*  split. auto. apply open_fp. auto. auto. *)
  (* next *)
  split. intros. auto. inversion IHtrans. auto.
  apply eval_regular in H ; inversion H ; auto. inversion IHtrans. auto.
Defined.
Hint Resolve trans_regular.

CoInductive simulates : term -> term -> Prop :=
| simulates_base : forall a b,
  (forall a' l,
    trans a l a' ->
    (exists b', trans b l b' /\ simulates a' b')) ->
  simulates a b.

CoInductive bisimulates : term -> term -> Prop :=
| bisimulates_base : forall a b,
  (forall a' l,
    trans a l a' ->
    (exists b', trans b l b' /\ bisimulates a' b')) ->
  (forall b' l,
    trans b l b' ->
    (exists a', trans a l a' /\ bisimulates a' b')) ->
  bisimulates a b.

Lemma bisimulation_impl_simulation_right : forall a b, bisimulates a b -> simulates a b.
Proof.
  refine
    (cofix bisim (a b : term) (Hb : bisimulates a b) : simulates a b :=
      _).
  inversion Hb. subst. eapply simulates_base.
  intros. apply H in H1. inversion H1. inversion H2.
  exists x. split. auto. apply bisim. auto.
Defined.

Lemma bisimulation_impl_simulation_left : forall a b, bisimulates a b -> simulates b a.
Proof.
  refine
    (cofix bisim (a b : term) (Hb : bisimulates a b) : simulates b a :=
      _).
  inversion Hb. subst. eapply simulates_base.
  intros. apply H0 in H1. inversion H1. inversion H2.
  exists x. split. auto. apply bisim. auto.
Defined.

Ltac trans_prove_lc :=
  match goal with
    | H : trans ?x _ _ |- lc ?x => apply trans_regular in H ; inversion H ; auto
    | H : trans _ _ ?x |- lc ?x => apply trans_regular in H ; inversion H ; auto
  end.

Lemma bisimulation_refl : forall a, lc a -> bisimulates a a.
Proof.
  refine
    (cofix bisim (a : term) (H: lc a) : bisimulates a a := _) ;
  eapply bisimulates_base.

  intros. exists a'. split ; auto. apply bisim ; trans_prove_lc.

  intros. exists b'. split ; auto. apply bisim ; trans_prove_lc.
Defined.

Lemma bisimulation_symm : forall a b, lc a -> lc b -> bisimulates a b -> bisimulates b a.
Proof.
  refine
    (cofix bisim (a b:term) (Ha : lc a) (Hb : lc b) (Hbi : bisimulates a b) : bisimulates b a :=
      _).
  apply bisimulates_base.

  (* left *)
  intros.
  inversion Hbi. subst. cut (trans b l a') ; intros ; auto.
  apply H1 in H ; subst. inversion H. inversion H3.
  exists x. split ; auto. apply bisim ; try trans_prove_lc ; auto.

  (* right *)
  intros.
  inversion Hbi. subst. cut (trans a l b') ; intros ; auto.
  apply H0 in H ; subst. inversion H. inversion H3.
  exists x. split ; auto. apply bisim ; try trans_prove_lc ; auto.
Defined.

Lemma bisimulation_trans : forall a b c, lc a -> lc b -> lc c -> bisimulates a b -> bisimulates b c -> bisimulates a c.
Proof.
  refine
    (cofix bisim (a b c:term) (Ha : lc a) (Hb : lc b) (Hc : lc c) (Hbi_ab  : bisimulates a b) (Hbi_bc : bisimulates b c) : bisimulates a c := _)
    ; apply bisimulates_base.
  intros.
  inversion Hbi_ab ; inversion Hbi_bc ; subst.
  cut (trans a l a') ; intros ; auto.
  apply H0 in H2. inversion H2. inversion H3.
  cut (trans b l x) ; intros ; auto.
  apply H4 in H8. inversion H8. inversion H9.
  exists x0. split ; auto. eapply bisim with (b:=x) ; try trans_prove_lc ; auto.

  intros.
  inversion Hbi_ab ; inversion Hbi_bc ; subst.
  cut (trans c l b') ; intros ; auto.
  apply H5 in H2. inversion H2. inversion H3.
  cut (trans b l x) ; intros ; auto.
  apply H1 in H8. inversion H8. inversion H9.
  exists x0. split ; auto. eapply bisim with (b:=x) ; try trans_prove_lc ; auto.
Defined.

Ltac remove_trans_false :=
  match goal with
    | H : trans ?a ?l ?b, H0 : trans ?a' ?l' ?b' |- _ =>
      inversion H ; clear H ; inversion H0 ; clear H0 ; subst ; try congruence ; auto
    | H : eval (fvar ?a) ?b |- _ => inversion H ; clear H
    | H : eval (inl ?a) ?b |- _ => inversion H ; clear H
    | H : eval (inr ?a) ?b |- _ => inversion H ; clear H
    | H : eval (prod ?a ?b) ?c |- _ => inversion H ; clear H
  end.

Lemma testing : forall x y, x < y -> x <= y.
Proof.
  intros. inversion H ; subst.
  auto with arith. inversion H0. subst. auto. auto with arith.
Defined.

Lemma lc_abs_z : forall n, lc (abs (bvar n)) -> n = 0.
Proof.
  intros. destruct n. inversion H ; subst ; reflexivity.
  inversion H. compute in H1. subst.
  pick fresh x for L. apply (H1 x) in Fr. inversion Fr.
Defined.

Lemma lc_fp_z : forall n, lc (fp (bvar n)) -> n = 0.
Proof.
  intros. destruct n. inversion H. subst ; reflexivity.
  inversion H. compute in H1. subst.
  pick fresh x for L. apply (H1 x) in Fr. inversion Fr.
Defined.

Lemma eval_imp_bisimulation : forall a b, eval a b -> bisimulates a b.
Proof.
  refine (cofix bisim (a b : term) (Heval : eval a b) : bisimulates a b := _) ; apply bisimulates_base.

  intros.

  generalize dependent b. generalize dependent a.
  induction a; intros ; inversion Heval ; subst.
  induction a. apply lc_fp_z in H1. subst. compute in *. inversion Heval. subst.
  inversion H. subst.

  intros.
  inversion H. subst ; inversion Heval ; subst. subst.
  inversion Heval. subst. inversion Heval. subst.
  inversion Heval. subst. inversion Heval. subst.
  exists (app (abs b) t2). split. induction a. inversion H0. inversion Heval.
    apply IHa.
    apply lc_abs_z in H0.
  induction e1. apply lc_abs_z in H2.subst. compute in *. apply trans_app ; auto.
  inversion
  inversion H2. subst.
Defined.

Lemma simulation_pair_imp_bisimulation : forall a b, simulates a b -> simulates b a -> bisimulates a b.
Proof.
  refine
    (cofix bisim (a b : term) (Hsima : simulates a b) (Hsimb : simulates b a) : bisimulates a b := _).
  dependent inversion Hsima.

_).
  intros.
  (* left *)
  inversion Hsima. subst.

  apply H0 in H. inversion H. inversion H1.
  exists x. split ; auto.
  inversion Hsimb. subst. apply H4 in H2. inversion H2. inversion H5.

Ltac show_trans_exists :=
  match goal with
    | Heval : eval ?s ?t, Htrans : trans ?t _ ?a |- _ =>
      exists a ; split ; try (eapply trans_next ; eauto)
  end.

Definition tnil := inl unit.
Definition tcons := (fun a b => (inr (prod a b))).
(*
letrec map =
% f . % l .
  case l of
    | nil => nil
    | cons a b => (cons (@ f a) (@ (@ map f) b))
*)
Definition map := fp (abs (abs (cas 0 tnil (tcons (app 2 (proj1 0)) (app (app 3 2) (proj2 0)))))).
(*
letrec iterate =
% f . % k .
  cons k (@ (@ iterate f) (@ f k))
*)
Definition iterate := fp (abs (abs (tcons 0 (app (app 2 1) (app 1 0))))).

(* automates local closure proofs for terms *)
Lemma map_lc : lc map.
Proof.
  unfold map.
  lc_solve.
Defined.

Lemma iterate_lc : lc iterate.
Proof.
  unfold iterate.
  lc_solve.
Defined.

Lemma left_hand_iterate : forall f x, lc f -> lc x -> lc (app (app map f) (app (app iterate f) x)).
Proof.
  intros. lc_solve ; auto using map_lc, iterate_lc.
Defined.

Lemma iterate_proof : forall f x, lc f -> lc x -> bisimulates (app (app map f) (app (app iterate f) x))
                                                              (app (app iterate f) (app f x)).
Proof.
  refine (cofix bisim (f x : term) (Hlcf : lc f) (Hlcx : lc x)
    : bisimulates (app (app map f) (app (app iterate f) x)) (app (app iterate f) (app f x)) := _).
  constructor.
  (* left *)
  intros.
  exists (tcons (app f x) (app (app iterate f) (app f x))).
  split. eapply trans_next with (t2:=(tcons (app f x) (app (app iterate f) (app f x)))).
  beta
  cut
    (eval
      (fp
        (abs
          (abs (tcons 0%nat (app (app 2%nat 1%nat) (app 1%nat 0%nat))))))
      (open
        (abs
          (abs (tcons 0%nat (app (app 2%nat 1%nat) (app 1%nat 0%nat)))))
        (fp
          (abs
            (abs (tcons 0%nat (app (app 2%nat 1%nat) (app 1%nat 0%nat)))))))) ; intros.
  intros.
  inversion H0. subst.

Definition.

(*
Lemma eval_imp_bisimulates : forall a b, eval a b -> bisimulates b a.
  refine (cofix bisim (a b : term) (Heval : eval a b) : bisimulates b a := _).
  apply bisimulates_base.
  (* easy to show the left half of simulation *)
  intros ; try show_trans_exists ; try (apply bisimulation_refl ; prove_lc).
  (* right half *)
  intros.
Defined.
*)

(* behavioural equivalence relation *)
CoInductive b_eq : term -> term -> Prop :=
| b_eq_base :
  forall a b b',

(* hard to prove...
Lemma value_is_eval : forall t, value t <-> exists b, evaluates b t.
Proof.
  intros t ; split.
  (* -> *)
  intros Hv. exists t. apply evaluates_base. apply multistep_refl.
  unfold not. intros Hr. inversion Hv ; subst ; inversion Hr as [x He] ; subst ;
    inversion He as [x Hes] ;
      inversion Hes.
  (* <- *)
  intros He. inversion He. inversion H. subst.
  induction t. inversion H0. subst.
  inversion He. inversion H2. subst. inversion H3. subst.
  inversion H0. subst.
*)

Fixpoint raise (t : term) :=
  match t with
    | unit => unit
    | fp t' => fp (raise t')
    | fvar s => fvar s
    | bvar n => bvar (S n)
    | abs t' => abs (raise t')
    | app m n => app (raise m) (raise n)
    | prod e1 e2 => prod (raise e1) (raise e2)
    | proj1 e => proj1 (raise e)
    | proj2 e => proj2 (raise e)
    | inl e => inl (raise e)
    | inr e => inr (raise e)
    | cas e e1 e2 => cas (raise e) (raise e1) (raise e2)
  end.

(* case distributivity *)
Fixpoint case_dist (t : term) : term :=
  match t with
    | cas (cas e e1 e2) f1 f2 =>
      cas e
      (cas e1 (raise (case_dist f1)) (raise (case_dist f2)))
      (cas e2 (raise (case_dist f1)) (raise (case_dist f2)))
    | unit => unit
    | fp t' => fp (case_dist t')
    | fvar s => fvar s
    | bvar n => bvar (S n)
    | abs t' => abs (case_dist t')
    | app m n => app (case_dist m) (case_dist n)
    | prod e1 e2 => prod (case_dist e1) (case_dist e2)
    | proj1 e => proj1 (case_dist e)
    | proj2 e => proj2 (case_dist e)
    | inl e => inl (case_dist e)
    | inr e => inr (case_dist e)
    | cas e e1 e2 => cas (case_dist e) (case_dist e1) (case_dist e2)
  end.

(* eval_big : big step operational semantics

------
e => e

e => e' e' -> e''
-----------------
     e => e''

*)

(* eval_coind : big step coinductive operational semantics *)

CoInductive diverges : term -> Prop :=
| diverges_app_1 : forall e e', diverges e -> diverges (app e e')
| diverges_app_2 : forall e1 e2 e2', eval_big e e' -> diverges
| diverges_cas : forall e e1 e2, diverges e -> diverges (cas e e1 e2)
| diverges

Notation "`case` t `of` { A | B }" := (cas t A B).

(* nat := 1 + nat *)
Definition Zero := inl unit.
Definition Succ := (fun x => inr x).
(* bool := 1 + 1 *)
Definition T := inl unit.
Definition F := inr unit.

(* Nat = 1 + Nat *)
Definition One := Succ Zero.
Definition Two := Succ One.
Definition Three := Succ Two.
Definition add := (fp (abs (abs (abs (cas 2 (abs 2) (abs (Succ (app (app 3 0) 2)))))))).

Ltac lc_abs_run :=
  let L := fresh "L" in
    intros ; compute ; pick fresh x for L.

Ltac prove_lc :=
  match goal with
    | |- lc (fp ?x) => apply lc_fp
    | |- lc (abs ?x) => lc_abs_run ; intros ; compute
    | |- lc (cas ?x ?y ?z) => apply lc_cas
    | |- lc (inr ?x) => apply lc_inr
    | |- lc (inl ?x) => apply lc_inl
    | |- lc ?x => auto
  end.

Lemma add_lc : lc add.
Proof.
  unfold add.
  repeat prove_lc.
Defined.

Lemma eval_add : eval (app (app add One) Two) Three.
Proof.
  compute.


(** Coq coding by choukh, Oct 2020 **)

Require Import ZFC.Elements.EX6_1.
Require Import ZFC.Lib.Dominate.
Require Import ZFC.Lib.WosetMin.
Import WosetMin.SimpleVer.

(** Facts about finite / infinite subset of ω **)

(* 自然数集的非空有限子集有极大元 *)
Lemma finite_subset_of_ω_is_bounded : ∀ N, ⦿ N → N ⊆ ω →
  finite N → ∃ m, sub_maximum m N.
Proof with auto; try congruence.
  intros N Hne Hsub [n [Hn Hqn]].
  generalize dependent N.
  ω_induction n; intros N Hne Hsub Hcd. {
    apply eqnum_empty in Hcd. apply EmptyNI in Hne. exfalso...
  }
  clear Hn n. destruct Hne as [k Hk].
  destruct (classic (sub_maximum k N)). exists k...
  apply not_and_or in H as []. exfalso...
  apply set_not_all_ex_not in H as [p [Hp Hkp]].
  apply Hsub in Hk as Hkw. apply Hsub in Hp as Hpw.
  apply lt_iff_not_sub in Hkp...
  apply split_one_element in Hk as HeqN. rewrite HeqN in Hcd.
  apply finite_set_remove_one_member in Hcd...
  specialize IH with (N - {k,}) as [q [Hq Hmax]]...
  { exists p. apply SepI... apply SingNI...
    intros Heq. apply (nat_irrefl k)...
  } {
    eapply sub_trans...
  }
  apply SepE1 in Hq... apply Hsub in Hq as Hqw.
  destruct (classic (p ⊆ q)) as [Hpq|Hqp].
  - exists q. split... intros n Hn.
    destruct (classic (n = k)).
    + rewrite H. apply lt_iff_psub...
    + apply Hmax. apply SepI... apply SingNI...
  - exists p. split... intros n Hn.
    apply lt_iff_not_sub in Hqp...
    destruct (classic (n = k)).
    + rewrite H. apply lt_iff_psub...
    + eapply sub_trans.
      * apply Hmax. apply SepI... apply SingNI...
      * apply lt_iff_psub...
Qed.

(* 自然数集的没有极大元的非空子集是无限集 *)
Corollary unbound_subset_of_ω_is_infinite : ∀ N, ⦿ N → N ⊆ ω →
  nat_archimedean N → infinite N.
Proof with eauto.
  intros N Hne Hsub Harc Hfin.
  eapply nat_archimedean_iff_no_maximum...
  apply finite_subset_of_ω_is_bounded...
Qed.

(* 自然数集的有极大元的子集是非空有限集 *)
Lemma bounded_subset_of_ω_is_finite : ∀ N, N ⊆ ω →
  (∃ m, sub_maximum m N) → ⦿ N ∧ finite N.
Proof with nauto.
  intros N Hsub [n [Hn Hmax]]. split. exists n...
  apply Hsub in Hn as Hnw. generalize dependent N.
  ω_induction n; intros N Hsub Hn Hmax.
  - exists 1. split... cut (N = {∅,}). {
      intros H. rewrite H. apply eqnum_single.
    }
    ext Hx.
    + apply Hmax in Hx. apply sub_empty in Hx. subst x...
    + apply SingE in Hx. subst x...
  - pose proof (nat_neq_suc m Hm) as Hnq.
    assert (Hstar: ∀k ∈ N, k ∉ {m⁺,} → k ⊆ m). {
      intros k Hk Hk'. apply Hsub in Hk as Hkw. apply SingNE in Hk'.
      contra as Hmk.
      apply lt_iff_not_sub in Hmk; [|auto|apply Hsub]...
      apply lt_iff_suc_le in Hmk...
      apply le_iff_sub in Hmk; [|apply ω_inductive|]...
      apply Hk'. apply sub_antisym...
    }
    destruct (classic (m ∈ N)) as [HmN|HmN].
    + replace N with (N - {m⁺,} ∪ {m⁺,}).
      apply bunion_finite... apply IH.
      * eapply sub_trans...
      * apply SepI... apply SingNI...
      * intros k Hk. apply SepE in Hk as [Hk Hk']. apply Hstar...
      * apply remove_one_member_then_return...
    + replace N with (N ∪ {m,} - {m⁺,} - {m,} ∪ {m⁺,}).
      apply bunion_finite... apply comp_finite. apply IH.
      * eapply sub_trans...
        intros x Hx. apply BUnionE in Hx as [].
        apply Hsub... apply SingE in H. subst...
      * apply SepI. apply BUnionI2... apply SingNI...
      * intros k Hk. apply SepE in Hk as [Hk Hk'].
        apply BUnionE in Hk as [Hk|Hk]. apply Hstar...
        apply SingE in Hk; subst...
      * rewrite bunion_comp.
        replace ({m,} - {m⁺,}) with {m,}. {
          rewrite add_one_member_then_remove.
          - rewrite remove_one_member_then_return...
          - intros H. apply SepE1 in H...
        }
        ext Hx.
        apply SepI... apply SingE in Hx; subst. apply SingNI...
        apply SepE1 in Hx...
Qed.

(* 自然数集的无限子集没有极大元 *)
Corollary infinite_subset_of_ω_is_unbound : ∀ N, N ⊆ ω →
  infinite N → (⦿ N ∧ nat_archimedean N).
Proof with auto.
  intros N Hsub Hinf.
  apply infinite_set_nonempty in Hinf as Hne. split...
  apply nat_archimedean_iff_no_maximum...
  intros Hmax. apply Hinf.
  apply bounded_subset_of_ω_is_finite...
Qed.

(* 自然数集的子集是非空有限集当且仅当其有极大元 *)
Theorem subset_of_ω_is_finite_iff_bounded : ∀ N, N ⊆ ω →
  (⦿ N ∧ finite N) ↔ ∃ m, sub_maximum m N.
Proof with auto.
  intros N Hsub. split.
  - intros [Hne Hfin].
    apply finite_subset_of_ω_is_bounded...
  - apply bounded_subset_of_ω_is_finite...
Qed.

(* 自然数集的子集是无限集当且仅当其非空且没有极大元 *)
Theorem subset_of_ω_is_infinite_iff_unbound : ∀ N, N ⊆ ω →
  infinite N ↔ (⦿ N ∧ nat_archimedean N).
Proof with auto.
  intros N Hsub. split.
  - apply infinite_subset_of_ω_is_unbound...
  - intros []. apply unbound_subset_of_ω_is_infinite...
Qed.

(** Facts about sets dominated by ω **)

(* ω的任意无限子集与ω等势 *)
Theorem infinite_subset_of_ω_eqnum_ω : ∀ N,
  N ⊆ ω → infinite N → N ≈ ω.
Proof with neauto; try congruence.
  intros N Hsub Hinf.
  apply Schröeder_Bernstein. apply dominate_sub...
  apply infinite_subset_of_ω_is_unbound in Hinf as [Hne Harc]...
  destruct (ω_well_ordered N) as [n0 [Hn0 Hle]]...
  apply Hsub in Hn0 as Hn0w.
  assert (Hsubn: ∀n ∈ ω, {x ∊ N | n ∈ x} ⊆ N). {
    intros n Hn x Hx. apply SepE1 in Hx...
  }
  set (Func N N (Next N Lt)) as F.
  assert (HF: F: N ⇔ N). {
    apply meta_injection.
    - intros n Hn. apply Hsub in Hn as Hnw. apply (Hsubn n Hnw).
      pose proof (Harc n Hnw) as [m [Hm Hnm]]. apply ω_next...
    - intros n1 H1 n2 H2.
      apply ω_next_injective; auto; apply Harc; apply Hsub...
  }
  assert (Hn0': n0 ∈ N - ran F). {
    destruct HF as [[Hf _] [Hd Hr]].
    apply SepI... intros H.
    apply ranE in H as [x Hp]. apply domI in Hp as Hx.
    rewrite Hd in Hx. apply Hsub in Hx as Hxw.
    apply func_ap in Hp... unfold F in Hp.
    rewrite meta_func_ap in Hp; [|split|]...
    pose proof (Hle x Hx) as Hn0x. apply le_iff_sub in Hn0x...
    apply ω_next in Hx as [Hx _]...
    rewrite Hp in Hx. apply SepE in Hx as [_ Hx].
    apply Hn0x in Hx. apply (nat_irrefl x)...
  }
  exists (ω_Recursionᵢₙⱼ F N n0).
  apply ω_recursionᵢₙⱼ_spec_intro...
Qed.

(* 被ω支配的无限集与ω等势 *)
Corollary infinite_set_dominated_by_ω_eqnum_ω : ∀ A,
  A ≼ ω → infinite A → A ≈ ω.
Proof with auto.
  intros A [f [Hf [Hd Hr]]] Hinf.
  assert (A ≈ ran f). { exists f. split... }
  rewrite H. apply infinite_subset_of_ω_eqnum_ω...
  intros Hfin. apply Hinf.
  apply (dominated_by_finite_is_finite _ (ran f))...
  exists f. split...
Qed.

(* 集合被ω支配如果它被ω满射 *)
Lemma dominated_by_ω_if_mapped_onto_by_ω :
  ∀ B F, F: ω ⟹ B → B ≼ ω.
Proof with auto; try congruence.
  intros B f [Hf [Hd Hr]].
  set (λ b, {n ∊ ω | f[n] = b}) as 𝒩.
  set (Func B ω (λ x, (Min Lt)[𝒩 x])) as g.
  exists g. apply meta_injection.
  + intros x Hx. eapply ap_ran.
    apply ω_min_function. apply SepI.
    * apply PowerAx. intros n Hn. apply SepE1 in Hn...
    * rewrite <- Hr in Hx. apply ranE in Hx as [n Hp].
      apply domI in Hp as Hn. apply func_ap in Hp...
      apply SingNI. apply EmptyNI. exists n. apply SepI...
  + intros b1 Hb1 b2 Hb2 Heq.
    assert (Hsub: ∀ b, 𝒩 b ⊆ ω). {
      intros b0 x Hx. apply SepE1 in Hx...
    }
    specialize (ω_min (𝒩 b1)) as [H1 _]... {
      rewrite <- Hr in Hb1. apply ranE in Hb1 as [n1 H1].
      apply domI in H1 as Hn1. apply func_ap in H1...
      exists n1. apply SepI...
    }
    specialize (ω_min (𝒩 b2)) as [H2 _]... {
      rewrite <- Hr in Hb2. apply ranE in Hb2 as [n2 H2].
      apply domI in H2 as Hn2. apply func_ap in H2...
      exists n2. apply SepI...
    }
    apply SepE in H1 as [_ H1].
    apply SepE in H2 as [_ H2]. congruence.
Qed.

(* 非空集合被ω支配蕴含它被ω满射 *)
Lemma dominated_by_ω_impl_mapped_onto_by_ω :
  ∀ B, ⦿ B → B ≼ ω → ∃ F, F: ω ⟹ B.
Proof with auto; try congruence.
  intros B [b Hb] Hdm.
  destruct (classic (finite B)).
  - destruct H as [n [Hn [f Hf]]].
    set (Func ω B (λ x, match (ixm (x ∈ n)) with
      | inl _ => f⁻¹[x]
      | inr _ => b
    end)) as g.
    exists g. apply meta_surjection.
    + intros x Hx. destruct (ixm (x ∈ n))... apply (ap_ran n)...
      apply bijection_is_func. apply inv_bijection...
    + intros y Hy. destruct Hf as [[Hf Hs] [Hd Hr]].
      rewrite <- Hd in Hy. apply domE in Hy as [x Hp].
      apply ranI in Hp as Hx. rewrite Hr in Hx.
      exists x. split. apply (ω_trans _ n)...
      destruct (ixm (x ∈ n))... apply func_ap.
      apply inv_func_iff_sr... rewrite <- inv_op...
  - apply infinite_set_dominated_by_ω_eqnum_ω in H as [f Hf]...
    exists (f⁻¹). apply bijection_is_surjection. apply inv_bijection...
Qed.

(* 非空集合被ω支配当且仅当它被ω满射 *)
Fact dominated_by_ω_iff_mapped_onto_by_ω :
  ∀ B, ⦿ B → (∃ F, F: ω ⟹ B) ↔ B ≼ ω.
Proof with eauto.
  intros B Hne. split.
  - intros [f Hf]. eapply dominated_by_ω_if_mapped_onto_by_ω...
  - apply dominated_by_ω_impl_mapped_onto_by_ω...
Qed.