(** The contents in this file are reconstructed from the proof of Bruno Barras
 ** in the Coq standard library. It is duplicated so that the definitions
 ** can be made transparent, and therefore computable.
 ** See Coq.Logic.Eqdep_dec for complete information
 **)
Section uip_trans.
  Context {A : Type}.

  Definition uip_prop_trans (dec : forall x y : A, x = y \/ x <> y)
    {x : A} :
    forall {y : A} (pf pf' : x = y), pf = pf' :=
    let comp :=
        fun (x y y' : A) (eq1 : x = y) (eq2 : x = y') =>
          eq_ind x (fun a : A => a = y') eq2 y eq1 in
    let eq_dec := dec x in
    let nu :=
        fun (y : A) (u : x = y) =>
          match eq_dec y with
          | or_introl eqxy => eqxy
          | or_intror neqxy => False_ind (x = y) (neqxy u)
          end in
    let nu_constant :=
        fun (y : A) (u v : x = y) =>
          let o := eq_dec y in
          match
            o as o0
            return
            (match o0 with
             | or_introl eqxy => eqxy
             | or_intror neqxy => False_ind (x = y) (neqxy u)
             end =
             match o0 with
             | or_introl eqxy => eqxy
             | or_intror neqxy => False_ind (x = y) (neqxy v)
             end)
          with
          | or_introl Heq => eq_refl
          | or_intror Hneq =>
            match
              Hneq u as f
              return (False_ind (x = y) f = False_ind (x = y) (Hneq v))
            with
            end
          end in
    let nu_inv := fun (y : A) (v : x = y) => comp x x y (nu x eq_refl) v
    in
    let trans_sym_eq := fun (x y : A) (u : x = y) =>
        match u as e in (_ = y0) return (comp x y0 y0 e e = eq_refl) with
        | eq_refl => eq_refl
        end
    in
    let nu_left_inv_on := fun (y : A) (u : x = y) =>
        match u as e in (_ = y0) return (nu_inv y0 (nu y0 e) = e) with
        | eq_refl => trans_sym_eq _ _ (nu _ eq_refl)
        end in
    fun (y : A) (p1 p2 : x = y) =>
      eq_ind (nu_inv y (nu y p1)) (fun p3 : x = y => p3 = p2)
             (eq_ind (nu_inv y (nu y p2)) (fun p3 : x = y => nu_inv y (nu y p1) = p3)
                     (eq_ind (nu y p1) (fun e : x = y => nu_inv y (nu y p1) = nu_inv y e)
                             eq_refl (nu y p2) (nu_constant y p1 p2)) p2
                     (nu_left_inv_on _ p2)) p1 (nu_left_inv_on _ p1).

  Definition uip_trans (dec : forall x y : A, {x = y} + {x <> y})
  := @uip_prop_trans (fun a b => match dec a b with
                                 | left pf => or_introl pf
                                 | right pf' => or_intror pf'
                                 end).
End uip_trans.


Require CoreStats.

Instance Default_Step {a} : GHC.Err.Default (Step a) :=
  GHC.Err.Build_Default _ Done.
Instance Default_Value : GHC.Err.Default Value :=
  GHC.Err.Build_Default _ (LitVal GHC.Err.default).
Instance Default_StackElem : GHC.Err.Default StackElem :=
  GHC.Err.Build_Default _ (Update GHC.Err.default).

(* ----------- termination metric for step function --------------- *)

Require Omega.

Ltac termination_by_omega :=
  Coq.Program.Tactics.program_simpl;
  simpl;Omega.omega.

Ltac solve_step_obligations :=
  repeat split; intros; try discriminate; termination_by_omega.

Definition step_measure (conf : Conf) : nat :=
  match conf with
  | (heap , expr, stack ) => CoreStats.exprSize expr
  end.

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

(*
solve_step_obligations solves most. But for the remainder we need the following
proof script. I'm not sure how to turn this into a tactic.

Next Obligation.
  match goal with [wc : Core.Tickish _ |- _ ] => destruct wc; auto end.
Defined.
Next Obligation.
  match goal with [a : Core.Expr _ , h : Core.isTypeArg a = true |- _ ] =>
                 destruct a; simpl in h; try discriminate end;
  simpl; replace (BinPos.Pos.to_nat 1) with 1; try Omega.omega; reflexivity.
Defined.
Next Obligation.
  repeat split; intros; intro h0; inversion h0.
Defined.
Next Obligation.
  repeat split; intros; intro h0; inversion h0.
Defined.
Next Obligation.
  repeat split; intros; intro h0; inversion h0.
Defined.
Next Obligation.
  repeat split; intros; intro h0; inversion h0.
Defined.
Next Obligation.
  repeat split; intros; intro h0; inversion h0.
Defined.
Next Obligation.
  repeat split; intros; intro h0; inversion h0.
Defined.
Next Obligation.
  repeat split; intros; intro h0; inversion h0.
Defined.
*)


From isla Require Import opsem.

Definition a8017c : isla_trace :=
  Smt (DeclareConst 68%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 68%Z)) Mk_annot :t:
  Smt (DefineConst 69%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 68%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 69%Z)) Mk_annot :t:
  tnil
.


Require Import ZF ZFsum ZFfix ZFnats ZFrelations ZFord ZFcard ZFcont.
Require Import ZFstable ZFrank ZFgrothendieck ZFinaccessible.
Require Import ZFind_basic ZFind_nat.
Import ZFrepl.

Section Ord_theory.

(***************************************************************************)
(* Ordinals *)

  Definition ORDf X := sum UNIT (func NAT X).

  Lemma sum_ext_ordf : forall A, ext_fun A ORDf.
do 2 red; intros.
unfold ORDf.
rewrite H0; reflexivity.
Qed.

  Instance ORDf_mono : Proper (incl_set ==> incl_set) ORDf.
do 2 red; intros.
unfold ORDf.
apply sum_mono; trivial.
red; trivial.
apply func_mono; trivial.
reflexivity.
Qed.
Hint Resolve ORDf_mono.
  Instance ORDf_morph : Proper (eq_set ==> eq_set) ORDf.
apply Fmono_morph; trivial.
Qed.

  Definition LIM f := inr f.

  Lemma LIM_typ_gen : forall x X, x ∈ func NAT X -> LIM x ∈ sum UNIT (func NAT X).
unfold LIM; intros.
apply inr_typ; trivial.
Qed.

  Lemma ORDf_case : forall X (P:Prop) x,
    (x == ZERO -> P) ->
    (forall f, f ∈ func NAT X -> x == LIM f -> P) ->
    x ∈ ORDf X -> P.
intros.
unfold ORDf in H.
apply sum_ind with (3:=H1); intros.
 apply H.
 apply unit_elim in H2.
 rewrite H2 in H3; trivial.

 apply H0 with y; trivial.
Qed.

Lemma ORDf_stable : stable ORDf.
unfold ORDf.
apply sum_stable.
 red; red; reflexivity.
 red; red; intros.
 rewrite H; reflexivity.

 apply cst_stable.
 apply func_stable.
Qed.

Lemma ORDf_stable2 : stable2 ORDf.
Proof stable2_weaker _ ORDf_morph ORDf_stable.

Section IterationOrd.

  Definition ORDi := TI ORDf.

  Instance ORDi_morph : morph1 ORDi.
unfold ORDi; do 2 red; intros.
apply TI_morph; trivial.
Qed.

  Lemma ORDi_stable : stable_ord ORDi.
unfold ORDi.
apply TI_stable; auto.
apply ORDf_stable.
Qed.

  Lemma ORDi_stable2 : stable2_ord ORDi.
unfold ORDi.
apply TI_stable2; auto.
apply ORDf_stable2.
Qed.

  Lemma ORDfun_ext : forall x, ext_fun x (fun n => ORDf (ORDi n)).
do 2 red; intros.
apply ORDf_morph.
apply ORDi_morph; trivial.
Qed.
Hint Resolve ORDfun_ext.

  Lemma ORDfun_stable : stable_ord (fun n => ORDf (ORDi n)).
apply compose_stable with (F:=ORDf) (G:=ORDi); auto with *.
 apply ORDf_stable.
 apply ORDi_stable.
Qed.

  Lemma ORDfun_stable2 : stable2_ord (fun n => ORDf (ORDi n)).
red; red; intros.
apply ORDf_stable2 in H1.
revert H1; apply ORDf_mono.
apply ORDi_stable2; trivial.
Qed.

  Lemma ORDi_case : forall (P:set->Prop) o n,
    isOrd o ->
    (forall x x', x ∈ ORDi o -> x == x' -> P x -> P x') ->
    P ZERO ->
    (forall f o', lt o' o -> f ∈ func NAT (ORDi o') -> P (LIM f)) ->
    n ∈ ORDi o -> P n.
intros.
apply TI_elim in H3; auto.
destruct H3.
apply ORDf_case with (3:=H4); intros.
 apply H0 with ZERO; trivial.
  apply TI_intro with x; auto.
  apply ZERO_typ_gen.

  symmetry; trivial.

 apply H0 with (LIM f); eauto.
 2:symmetry; trivial.
 apply TI_intro with x; auto.
 apply LIM_typ_gen; auto.
Qed.

  Lemma ORDi_fix :
    forall (P:set->Prop) o,
    isOrd o ->
    (forall i, isOrd i -> i ⊆ o ->
     (forall i' m, lt i' i -> m ∈ ORDi i' -> P m) ->
     forall n, n ∈ ORDi i -> P n) ->
    forall n, n ∈ ORDi o -> P n.
intros P o is_ord Prec.
induction is_ord using isOrd_ind; intros; eauto.
Qed.

End IterationOrd.

Hint Resolve ORDfun_ext.

Require Import ZFind_w.
Definition ORDf_clos :=
  let A := NATf (NATf empty) in
  let B x := NATCASE empty (fun _ => NAT) x in
  W_ord A B.

Instance Bm : morph1 (fun x => NATCASE empty (fun _ => NAT) x).
do 2 red; intros.
apply NATCASE_morph; auto with *.
red; intros; auto with *.
Qed.

Lemma ordOc : isOrd ORDf_clos.
apply W_o_o; auto with *.
Qed.
Hint Resolve ordOc.

(*
  Lemma ORDf_cont0 : forall F,
    stable_ord F ->
    increasing F ->
    ORDf (sup ORDf_clos F) ⊆ sup ORDf_clos (fun A => ORDf (F A)).
unfold ORDf.
intros.
rewrite <- sum_cont; auto.
rewrite <- cst_cont; eauto.
2:admit.
apply sum_mono; auto with *.
red; intros.

apply func_cont_gen; auto. (* uses boundo *)
*)

Section OrdConvergence.

(*
  Let o := hartog_succ NAT.

Lemma boundo :
    forall F,
    ext_fun NAT F ->
    (forall n, n ∈ NAT -> lt (F n) o) ->
    lt (sup NAT F) o.
intros.
apply hartog_bound; trivial.
Qed.

Lemma zer_h : zero ∈ o.
unfold o, hartog_succ.
rewrite sup_ax.
2:admit.
exists empty.
 apply subset_intro.
  unfold rel; apply power_intro; intros.
  elim empty_ax with z; trivial.

  constructor; intros.
  red in H.
  elim empty_ax with (1:=H).

 unfold order_type.
 rewrite sup_ax.
 2:apply ot_ext; reflexivity.
 exists ZERO.
  apply ZERO_typ.

  unfold osucc; apply subset_intro; auto.
  apply power_intro; intros.
  elim empty_ax with z; trivial.
Qed.

Lemma limo : limitOrd o.
split.
 apply isOrd_hartog.
intros.
unfold o, hartog_succ in *.
rewrite sup_ax in H|-*.
2:admit.
2:admit.
destruct H as (R,woR,otR).
Require Import ZFpairs.
pose (R' :=
   union2
    (replf R (fun p => couple (SUCC (fst p)) (SUCC (snd p)))) (* shift R *)
    (replf NAT (fun n => couple (SUCC n) ZERO))). (* put 0 above all elements of R *)
assert (Rax: forall y z, rel_app R' y z <->
  exists2 y', y == SUCC y' /\ y' ∈ NAT &
  (exists2 z', z==SUCC z' & rel_app R y' z') \/ z == ZERO).
 split; intros.
  apply union2_elim in H; destruct H.
   rewrite replf_ax in H.
   2:admit.
   destruct H.
   apply couple_injection in H0; destruct H0.
   exists (fst x0).
    split; trivial.
    apply fst_typ with NAT.
    apply power_elim with R; trivial.
    apply subset_elim1 in woR; trivial.
   left.
   exists (snd x0); trivial.
   red; rewrite <- (@surj_pair x0 NAT NAT); trivial.
   apply power_elim with R; trivial.
   apply subset_elim1 in woR; trivial.

   rewrite replf_ax in H.
   2:admit.
   destruct H.
   apply couple_injection in H0; destruct H0.
   exists x0; auto.

  destruct H as (y',(?,?),[(z',?,?)|?]).
   apply union2_intro1.
   apply replf_intro with (couple y' z'); auto.
    admit.
    rewrite fst_def; rewrite snd_def.
    rewrite H; rewrite H1; reflexivity.

   apply union2_intro2.
   apply replf_intro with y'; auto.
    admit.
    rewrite H; rewrite H1; reflexivity.
assert (R' ∈ wo NAT).
 apply subset_intro.
Lemma union2_rel : forall A B r1 r2,
  r1 ∈ rel A B -> r2 ∈ rel A B -> union2 r1 r2 ∈ rel A B.
intros.
apply power_intro; intros.
apply union2_elim in H1; destruct H1.
 apply power_elim with r1; trivial.
 apply power_elim with r2; trivial.
Qed.
  (* REL *)
  apply union2_rel.
   apply power_intro; intros.
   rewrite replf_ax in H.
   2:admit.
   destruct H.
   rewrite H0.
   apply couple_intro.
    apply SUCC_typ.
    apply fst_typ with NAT.
    apply power_elim with R; trivial.
    apply subset_elim1 in woR; trivial.

    apply SUCC_typ.
    apply snd_typ with NAT.
    apply power_elim with R; trivial.
    apply subset_elim1 in woR; trivial.

   apply power_intro; intros.
   rewrite replf_ax in H.
   2:admit.
   destruct H.
   rewrite H0.
   apply couple_intro.
    apply SUCC_typ; trivial.
    apply ZERO_typ.

 (* WO *)
 red; intros.
 assert (forall n y, y == SUCC n -> Acc (rel_app R') y).
  intro n.
  induction (wo_def2 _ _ woR n).
  constructor; intros.
  rewrite Rax in H2; destruct H2 as (y',(?,?),[(z',?,?)|?]).
   apply H0 with y'; trivial.
   rewrite H1 in H4; apply SUCC_inj in H4; rewrite H4; trivial.

   rewrite H4 in H1; apply NATf_discr in H1; contradiction.
 constructor; intros.
 rewrite Rax in H0; destruct H0 as (y',(?,?),_).
 apply H with y'; trivial.

exists R'; trivial.
 apply wo_def2 in H.
 (* OT *)
 unfold order_type in otR|-*.
 rewrite sup_ax in otR|-*.
 2:admit.
 2:admit.
 exists ZERO; [apply ZERO_typ|].
 apply lt_osucc_compat.
  apply order_type_assign_ord with NAT R' ZERO.
  apply uchoice_def.
  apply order_type_assign_uchoice; trivial.

  rewrite order_type_assign_rel_inv'; trivial.
  rewrite sup_ax.
  2:admit.
  destruct otR.
  exists (SUCC x0).
   apply subset_intro.
    apply SUCC_typ; trivial.

    rewrite Rax.
    exists x0; auto with *.

   assert (forall n, n ∈ NAT -> forall x,
     order_type_assign_rel NAT R n x -> order_type_assign_rel NAT R' (SUCC n) x).
    intros.
    apply H3; intros.
     admit.

     red; intros.
     setoid_replace (sup x' (fun y => osucc (f y))) with
       (sup (subset NAT (fun y => rel_app R' y (SUCC x2)))
         (fun y => osucc (f (pred y)))).
admit.
admit.
   generalize (uchoice_def _ (order_type_assign_uchoice NAT _ x0 (wo_def2 _ _ woR))); intro.
   apply H2 in H3; trivial.
   rewrite <- (uchoice_ext _ (uchoice (order_type_assign_rel NAT R x0))
       (order_type_assign_uchoice NAT _ (SUCC x0) H)); trivial.
Qed.

  Lemma nato : lt omega o.
pose (NtoO := fun n m => exists2 n', n == nat2NAT n' &
      m == (fix F n := match n with 0 => zero | S k => osucc (F k) end) n').
assert (forall n, n ∈ NAT -> uchoice_pred (NtoO n)).
 admit.
setoid_replace omega with (sup NAT (fun n => uchoice (NtoO n))).
 apply boundo.
  admit.

  intros.
  apply nat2NAT_reflect in H0.
  destruct H0.
  revert n H0.
  induction x; simpl; intros.
   admit.
   admit.

apply sup_ext.
 admit.

 intros.
 admit.

 intros.
 unfold omega in H0.
 unfold ord_sup in H0.
 apply union_elim in H0; destruct H0.
 apply repl_elim in H1.
 2:admit.
 destruct H1.
 destruct H2.
 exists (nat2NAT x1).
  elim x1; simpl.
   apply ZERO_typ.
   intros.
   apply SUCC_typ; trivial.

  admit.
Qed.
*)

  Variable o : set.
Hypothesis zer_o : zero ∈ o.
  Hypothesis limo : limitOrd o.
(*  Hypothesis nato : lt omega o.*)
  Hypothesis boundo :
    forall F,
    ext_fun NAT F ->
    (forall n, n ∈ NAT -> lt (F n) o) ->
    lt (osup NAT F) o.

  Let oo : isOrd o.
Proof proj1 limo.

  Lemma diro : isDir o.
red; intros.
pose (P n z := n == ZERO /\ z == x \/ ~ n == ZERO /\ z == y).
assert (eP : ext_fun NAT (fun n => uchoice (P n))).
 red; red ;intros.
 apply uchoice_morph_raw.
 red ;intros.
 unfold P.
 rewrite H2; rewrite H3.
 reflexivity.
assert (forall n, n ∈ NAT -> uchoice_pred (P n)).
 split; intros.
  revert H3; unfold P; rewrite H2; trivial.

  split; intros.
   apply NATi_case with (5:=H1); auto with *.
    intros.
    destruct H4.
    exists x1.
    revert H4; unfold P; rewrite H3; trivial.

    exists x; left; auto with *.

    intros.
    exists y; right; split; auto with *.
    red; intros.
    symmetry in H4; apply NATf_discr in H4; contradiction.

   destruct H2 as [(e1,r1)|(e1,r1)];
   destruct H3 as [(e2,r2)|(e2,r2)];
   rewrite r1; rewrite r2; try reflexivity.
   elim e2; trivial.
   elim e1; trivial.

exists (osup NAT (fun n => uchoice (P n))).
 apply boundo; trivial.
  intros.
  assert (P n (uchoice (P n))).
   apply uchoice_def; auto.
  destruct H3 as [(_,e)|(_,e)]; rewrite e; trivial.

 split.
  assert (t0 := ZERO_typ).
  assert (P ZERO (uchoice (P ZERO))).
   apply uchoice_def; auto.
  destruct H2 as [(_,e)|(d,_)].
   red; intros.
   apply osup_intro with (x:=ZERO); trivial.
   rewrite e; trivial.

   elim d; reflexivity.

  red; intros.
  assert (t1 : SUCC ZERO ∈ NAT).
   apply SUCC_typ; apply ZERO_typ.
  apply osup_intro with (x:=SUCC ZERO); trivial.
  assert (P (SUCC ZERO) (uchoice (P (SUCC ZERO)))).
   apply uchoice_def; auto.
  destruct H3 as [(d,_)|(_,e)].
   symmetry in d; apply NATf_discr in d; contradiction.

   rewrite e; trivial.
Qed.
Hint Resolve diro.

  Let zer : zero ∈ VN o.
intros.
apply VN_intro; auto.
Qed.

  Let suc : forall x, x ∈ VN o -> succ x ∈ VN o.
unfold succ.
intros.
apply VN_union; trivial.
apply VNlim_pair; auto.
apply VNlim_pair; auto.
Qed.

  Let NATo : NAT ∈ VN o.
apply NAT_typ; trivial.
admit. (* this is the real hyp. *)
Qed.

  Lemma ORDf_size_gen :
    forall X, X ∈ VN o -> ORDf X ∈ VN o.
intros.
unfold ORDf.
unfold sum.
apply VN_subset; trivial.
unfold ZFpairs.prodcart.
apply VN_subset; trivial.
apply VNlim_power; trivial.
apply VNlim_power; trivial.
apply VN_union; trivial.
apply VNlim_pair; auto.
apply VN_union; trivial.
apply VNlim_pair; trivial.
 unfold UNIT; auto.
unfold func.
apply VN_subset; trivial.
unfold rel.
apply VNlim_power; trivial.
unfold ZFpairs.prodcart.
apply VN_subset; trivial.
apply VNlim_power; trivial.
apply VNlim_power; trivial.
apply VN_union; trivial.
apply VNlim_pair; trivial.
Qed.

  Lemma ORDf_size_gen_le : forall X,
    X ⊆ VN o -> ORDf X ⊆ VN o.
red; intros.
apply ORDf_case with (3:=H0); intros.
 rewrite H1.
 unfold ZERO, inl.
 unfold ZFpairs.couple.
 apply VNlim_pair; trivial.
  apply VNlim_pair; trivial.
  apply VNlim_pair; trivial.

 rewrite H2; unfold LIM.
 unfold inr.
 unfold ZFpairs.couple.
 apply VNlim_pair; trivial.
  apply VNlim_pair; auto.

Import ZFrelations.
  apply VNlim_pair; auto.
  pose (F n := inter (subset o (fun x => ZFpairs.couple  n (app f n) ∈ VN x))).
  assert (eS : ext_fun (func NAT o) (fun f0 => sup NAT (app f0))).
   red; red; intros.
   apply sup_morph; auto with *.
   red; intros.
   apply app_morph; trivial.
  assert (eF : ext_fun NAT F).
   red; red; intros.
   apply inter_morph.
   apply subset_morph; auto with *.
   red; intros.
   rewrite H4; reflexivity.
  assert (pF : forall n, n ∈ NAT -> lt (F n) o /\ ZFpairs.couple n (app f n) ∈ VN (F n)).
   intros.
   assert (app f n ∈ X).
    apply app_typ with NAT; auto.
   generalize (H _ H4); intros.
   rewrite VN_def in H5; auto.
   destruct H5.
   assert (n ∈ VN o).
    apply VN_trans with NAT; trivial.
   rewrite VN_def in H7; auto.
   destruct H7.
   destruct (diro x (osucc x0)); auto.
    apply limo; trivial.
   destruct H10.
   assert (o1 : isOrd x1).
    apply isOrd_inv with o; trivial.

   assert (ZFpairs.couple n (app f n) ∈ VN (osucc (osucc (osucc x1)))).
    assert (n ∈ VN (osucc x1)).
     apply VN_incl with (VN x0); auto.
     apply VN_mono; auto.
     apply oles_lt in H11; trivial.
      apply isOrd_trans with x1; auto.

      apply isOrd_inv with o; auto.
    apply VNsucc_pair; auto.
     apply VNsucc_pair; auto.

     apply VNsucc_pair; auto.
     apply VN_incl with (VN x); auto.
     apply VN_mono; auto.
     apply ole_lts; auto.
     apply isOrd_inv with o; trivial.
   split.
    apply isOrd_plump with (osucc (osucc (osucc x1))); trivial.
     apply isOrd_inter; intros.
     apply subset_elim1 in H13; eauto using isOrd_inv.

     red; intros.
     apply inter_elim with (1:=H13).
     apply subset_intro; auto.
     repeat apply limo; trivial.

     repeat apply limo; trivial.

     apply VN_stable; intros.
      apply subset_elim1 in H13.
      apply isOrd_inv with o; trivial.

      apply inter_intro.
       intros.
       rewrite replf_ax in H13.
       2:red; red; intros; apply VN_morph; trivial.
       destruct H13.
       rewrite H14.
       apply subset_elim2 in H13; destruct H13.
       rewrite H13; trivial.

       exists (VN (osucc(osucc(osucc x1)))); intros.
       rewrite replf_ax.
       2:red; red; intros; apply VN_morph; trivial.
       exists (osucc(osucc(osucc x1))); auto with *.
       apply subset_intro; trivial.
       repeat apply limo; trivial.
  assert (lt (osup NAT F) o).
   apply boundo; auto.
   intros; apply pF; trivial.
(*   apply isOrd_plump with (4:=bound); auto.
    apply isOrd_supf; intros; auto.
    apply isOrd_inv with o; trivial.
    apply pF; trivial.

    red; intros.
    rewrite sup_ax; trivial.
    exists (lam NAT F).
     apply lam_is_func; auto.
     intros; apply pF; auto.

     apply eq_elim with (2:=H3).
     apply sup_morph; auto with *.
     red; intros.
     rewrite beta_eq; auto.
     rewrite <- H5; trivial.*)
  specialize func_eta with (1:=H1); intros.
  rewrite H4.
  unfold lam.
  apply VN_incl with (VN (osup NAT F)); auto.
   assert (eSS : ext_fun NAT (fun x : set => singl (ZFpairs.couple x (app f x)))).
    red; red; intros.
    rewrite H6; reflexivity.
   setoid_replace (replf NAT (fun x => ZFpairs.couple x (app f x)))
     with (sup NAT (fun x => singl (ZFpairs.couple x (app f x)))).
    red; intros.
    rewrite sup_ax in H5; trivial.
    destruct H5.
    apply singl_elim in H6.
    rewrite H6.
    apply VN_mono_le with (o:=F x); auto.
     apply isOrd_inv with o; auto.
     apply pF; trivial.

     apply isOrd_osup; trivial; intros.
     apply isOrd_inv with o; auto.
     apply pF; trivial.

     apply osup_intro; trivial.

     apply pF; trivial.
    assert (ext_fun NAT (fun x : set => ZFpairs.couple x (app f x))).
     red; red; intros.
     rewrite H6; reflexivity.
    apply eq_intro; intros.
     rewrite replf_ax in H6; auto.
     rewrite sup_ax; auto.
     destruct H6.
     exists x; trivial.
     rewrite H7; apply singl_intro.

     rewrite replf_ax; auto.
     rewrite sup_ax in H6; auto.
     destruct H6.
     exists x; trivial.
     apply singl_elim in H7; trivial.

 apply VN_mono; auto.
Qed.

  Lemma ORDi_incl_o : ORDi o ⊆ VN o.
apply TI_pre_fix; auto.
apply ORDf_size_gen_le; auto with *.
Qed.

  Lemma ORDi_typ : forall mu, isOrd mu -> lt o mu -> ORDi o ∈ VN mu.
intros.
rewrite VN_def; trivial.
exists o; trivial.
apply ORDi_incl_o.
Qed.

  Lemma ORDf_cont : forall F,
    stable_ord F ->
    increasing F ->
    ORDf (sup o F) ⊆ sup o (fun A => ORDf (F A)).
unfold ORDf.
intros.
rewrite <- sum_cont; auto.
rewrite <- cst_cont.
2:exists zero; trivial.
apply sum_mono; auto with *.
apply func_cont_gen; auto. (* uses boundo *)
Qed.

(* least fixpoint reached at ordinal o *)
  Lemma ORDo_pre : ORDf (ORDi o) ⊆ ORDi o.
red; intros.
assert (ORDi o ⊆ sup o ORDi).
 red; intros.
 apply TI_elim in H0; auto.
 destruct H0.
 rewrite sup_ax; auto.
  exists (osucc x); auto.
   apply limo; trivial.

   unfold ORDi; rewrite TI_mono_succ; auto.
   apply isOrd_inv with o; auto.

  red; red; intros; apply ORDi_morph; trivial.
assert (z ∈ ORDf (sup o ORDi)).
 revert H; apply ORDf_mono; auto with *.
apply ORDf_cont in H1.
 rewrite sup_ax in H1; auto.
 destruct H1.
 apply TI_intro with x; auto.

 apply ORDi_stable.

 apply TI_mono; trivial.
Qed.

  Lemma ORDo_fix : ORDi o == ORDf (ORDi o).
apply eq_intro; intros.
 rewrite <- TI_mono_succ; auto.
 apply TI_incl with o; auto.

 apply ORDo_pre; trivial.
Qed.

  Lemma ORDi_ORD : forall x,
    isOrd x ->
    ORDi x ⊆ ORDi o.
induction 1 using isOrd_ind; intros.
unfold ORDi at 1.
rewrite TI_eq; auto.
red; intros.
rewrite sup_ax in H2; auto.
destruct H2.
rewrite ORDo_fix.
apply ORDf_mono with (ORDi x0); auto.
Qed.

End OrdConvergence.

Section OrdFixpoint.

Require Import ZFgrothendieck ZFinaccessible.

  Variable U : set.
  Hypothesis Ug : grot_univ U.
  Hypothesis Uw : omega ∈ U.

  Notation mu := (grot_ord U).

  Let mu_ord : isOrd mu.
auto.
Qed.

  Let mu_lim : limitOrd mu.
split; trivial.
apply G_limit; trivial.
Qed.

  Let mu_reg : VN_regular mu.
apply VN_regular_weaker.
apply G_regular; trivial.
Qed.

Section FirstAttempt.
(* We can already build the fixpoint (at iteration mu), but we cannot
   prove we stay within the universe U *)
(*
  Let mu_dir : isDir mu.
apply isDir_regular; trivial.
 apply G_limit; trivial.

 apply G_regular; trivial.
Qed.
*)
  Let mu_omega : lt omega mu.
apply grot_ord_inv; trivial.
Qed.

  Lemma NATf_size_mu : forall X, X ∈ VN mu -> NATf X ∈ VN mu.
apply NATf_size_gen; trivial.
Qed.

  Lemma NAT_in_mu : NAT ∈ VN mu.
apply NAT_typ; trivial.
Qed.

  Definition ORD := ORDi mu.

  Lemma ORD_eq : ORD == ORDf ORD.
apply ORDo_fix; trivial.
 apply isOrd_trans with omega; trivial.
intros.
apply VN_reg_ord; trivial.
apply NAT_in_mu.
Qed.

  Lemma ORD_weak_typ : ORD ⊆ VN mu.
apply ORDi_incl_o; trivial.
 apply isOrd_trans with omega; trivial.
intros.
apply VN_reg_ord; trivial.
apply NAT_in_mu.
Qed.
End FirstAttempt.

(*****)
(* Building a bound to the cardinal of NAT, following ZFind_w *)
Require Import ZFlist.

Definition Ndom := subset (power (List NAT)) (fun X => Nil ∈ X).

Require Import ZFcoc.

Definition Nsup x :=
   singl Nil ∪
   sup (fst x) (fun y =>
      replf (cc_app (snd x) y) (fun p => Cons y p)).

Definition N_F X := sigma (power NAT) (fun Y => cc_arr Y X).

Lemma Nsup_morph : forall X, ext_fun (N_F X) Nsup.
Admitted.
(*
do 2 red; intros.
unfold Wsup.
apply union2_morph.
 rewrite H0; reflexivity.

 apply sup_morph.
  apply Bext.
   apply fst_typ_sigma in H; trivial.
   apply fst_morph; trivial.

  red; intros.
  apply replf_morph_raw; auto.
   rewrite H0; rewrite H2; reflexivity.

   red; intros.
   rewrite H2; rewrite H3; reflexivity.
Qed.
*)
Lemma wext1 : forall i y,
  ext_fun y (fun p => Cons i p).
Admitted.

Lemma wext2 : forall X g,
  ext_fun X (fun y => replf (cc_app g y) (fun p => Cons y p)).
Admitted.
(*
do 2 red; intros.
apply replf_morph_raw; auto.
 rewrite H0; reflexivity.

 red; intros.
 rewrite H0; rewrite H1; reflexivity.
Qed.*)
Hint Resolve wext1 wext2.

Lemma Nsup_def :
  forall x p,
  (p ∈ Nsup x <->
   p == Nil \/
   exists2 i, i ∈ fst x &
   exists2 q, q ∈ cc_app (snd x) i & p == Cons i q).
intros x p; intros.
unfold Nsup.
split; intros.
 apply union2_elim in H; destruct H;[left|right].
  apply singl_elim in H; trivial.

  rewrite sup_ax in H; auto.
  destruct H as (i,?,?); exists i; trivial.
  rewrite replf_ax in H0; trivial.

 destruct H as [eqp|(i,?,(q,?,eqp))]; rewrite eqp; clear eqp.
  apply union2_intro1.
  apply singl_intro.

  apply union2_intro2.
  rewrite sup_ax; auto.
  exists i; trivial.
  rewrite replf_ax; trivial.
  exists q; auto with *.
Qed.

Lemma Nsup_hd_prop : forall x, Nil ∈ Nsup x.
intros.
unfold Nsup.
apply union2_intro1.
apply singl_intro.
Qed.

Lemma Nsup_tl_prop : forall X i l x,
  x ∈ N_F X ->
  X ⊆ Ndom ->
  (Cons i l ∈ Nsup x <-> i ∈ fst x /\ l ∈ cc_app (snd x) i).
intros X i l x H inclX.
assert (tyx : fst x ∈ power NAT).
 apply fst_typ_sigma in H; trivial.
split; intros.
 apply union2_elim in H0; destruct H0.
  apply singl_elim in H0.
  symmetry in H0.
  apply discr_mt_pair in H0; contradiction.

  rewrite sup_ax in H0; auto.
  destruct H0.
  rewrite replf_ax in H1; trivial.
  destruct H1.
  apply couple_injection in H2; destruct H2.
  rewrite H2.
  split; trivial.
  rewrite H3; trivial.

 destruct H0.
 unfold Wsup.
 apply union2_intro2.
 rewrite sup_ax; auto.
 exists i; trivial.
 rewrite replf_ax; trivial.
 exists l; auto with *.
Qed.

Lemma Nsup_inj : forall X Y x x',
  X ⊆ Ndom ->
  Y ⊆ Ndom ->
  x ∈ N_F X ->
  x' ∈ N_F Y ->
  Nsup x == Nsup x' -> x == x'.
Admitted.
(*intros X Y x x' tyf tyf' H H0 H1.
assert (fst x == fst x').
  assert (forall i l, i ∈ fst x /\ l ∈ cc_app (snd x) i <->
                      i ∈ fst x' /\ l ∈ cc_app (snd x') i).
   intros.
   rewrite <- Nsup_tl_prop with (1:=H); trivial.
   rewrite H1.
   apply Nsup_tl_prop with (1:=H0); trivial.
 generalize (Nsup_tl_prop x); intro.
 generalize (Nsup_hd_prop x'); intro.
 apply H3.
 rewrite <- H1.
 apply H2.
 reflexivity.
assert (snd x == snd x').
 specialize cc_eta_eq with (1:=tys _ _ H); intros.
 specialize cc_eta_eq with (1:=tys _ _ H0); intros.
 rewrite H3; rewrite H4.
 apply cc_lam_ext.
  apply Bext; trivial.
  apply fst_typ_sigma in H; trivial.

  red; intros.
  assert (x'0 ∈ B (fst x')).
   revert H5; apply in_set_morph; auto with *.
   apply Bext; auto with *.
   apply fst_typ_sigma in H0; trivial.
  assert (cc_app (snd x) x0 ⊆ prodcart (List (sup A B)) A).
   red; intros.
   apply power_elim with (2:=H8).
   apply tyf.
   apply cc_prod_elim with (1:=tys _ _ H); trivial.
  assert (cc_app (snd x') x'0 ⊆ prodcart (List (sup A B)) A).
   red; intros.
   apply power_elim with (2:=H9); trivial.
   apply tyf'.
   apply cc_prod_elim with (1:=tys _ _ H0); trivial.
  generalize (fun z l => Wsup_tl_prop _ x0 l z _ H tyf); intros.
  generalize (fun z l => Wsup_tl_prop _ x'0 l z _ H0 tyf'); intros.
  apply eq_intro; intros.
   generalize (surj_pair _ _ _ (H8 _ H12)); intro.
   rewrite H13.
   apply H11.
   rewrite <- H6; rewrite <- H1.
   apply <- H10.
   rewrite <- H13; auto.

   generalize (surj_pair _ _ _ (H9 _ H12)); intro.
   rewrite H13.
   apply H10.
   rewrite H1; rewrite H6.
   apply <- H11.
   rewrite <- H13; auto.
apply subset_elim1 in H.
apply subset_elim1 in H0.
rewrite (surj_pair _ _ _ H).
rewrite (surj_pair _ _ _ H0).
rewrite H2; rewrite H3; reflexivity.
Qed.
*)

Lemma nextarr1 : forall X, ext_fun (power NAT) (fun Y => cc_arr Y X).
do 2 red; intros; apply cc_arr_morph; auto with *.
Qed.
Hint Resolve nextarr1.

Lemma Nsup_typ_gen : forall X x,
  X ⊆ Ndom ->
  x ∈ N_F X ->
  Nsup x ∈ Ndom.
intros.
apply subset_intro.
2:apply Nsup_hd_prop.
apply power_intro; intros.
rewrite Nsup_def in H1; trivial.
destruct H1 as [eqz|(i,?,(q,?,eqz))]; rewrite eqz; clear z eqz.
 apply Nil_typ.

 apply Cons_typ.
  apply power_elim with (2:=H1).
  apply fst_typ_sigma in H0; trivial.

  apply power_elim with (2:=H2).
  apply snd_typ_sigma with (y:=fst x) in H0; auto with *.
  apply cc_arr_elim with (2:=H1) in H0.
  apply H in H0.
  apply subset_elim1 in H0; trivial.
Qed.

(* The type operator on the construction domain *)
Definition Nf X := replf (N_F X) Nsup.

Hint Resolve Nsup_morph.

Lemma Nf_intro : forall x X,
  x ∈ N_F X ->
  Nsup x ∈ Nf X.
intros.
unfold Nf.
rewrite replf_ax; trivial.
exists x; auto with *.
Qed.

Lemma Nf_elim : forall a X,
  a ∈ Nf X ->
  exists2 x, x ∈ N_F X &
  a == Nsup x.
intros.
unfold Nf in H.
rewrite replf_ax in H; trivial.
Qed.

Lemma Nf_mono : Proper (incl_set ==> incl_set) Nf.
do 3 red; intros.
apply Nf_elim in H0; destruct H0 as (f,?,?).
rewrite H1; apply Nf_intro; trivial.
clear H1; revert f H0.
admit.
(*apply N_F_mono; trivial.*)
Qed.
Hint Resolve Nf_mono Fmono_morph.

Lemma Nf_typ : forall X,
  X ⊆ Ndom -> Nf X ⊆ Ndom.
red; intros.
apply Nf_elim in H0; destruct H0 as (x,?,?).
rewrite H1.
apply Nsup_typ_gen with X; auto with *.
Qed.
Hint Resolve Nf_typ.

(*
Lemma Wf_stable : forall X,
  X ⊆ power Wdom ->
  inter (replf X Wf) ⊆ Wf (inter X).
red; intros X Xty z H.
unfold Wf.
assert (forall a, a ∈ X -> z ∈ Wf a).
 intros.
 apply inter_elim with (1:=H).
 rewrite replf_ax.
 2:red;red;intros;apply Fmono_morph; trivial.
 exists a; auto with *.
rewrite replf_ax; auto.
destruct inter_wit with (2:=H).
 apply Fmono_morph; trivial.
assert (z ∈ Wf x); auto.
apply Wf_elim in H2.
destruct H2.
exists x0; auto.
apply W_F_stable.
apply inter_intro.
 intros.
 rewrite replf_ax in H4.
 2:red;red;intros;apply Fmono_morph; auto.
 2:apply W_F_mono.
 destruct H4.
 rewrite H5; clear y H5.
 specialize H0 with (1:=H4).
 apply Wf_elim in H0; destruct H0.
 rewrite H3 in H5; apply Wsup_inj with (X:=x) (Y:=x1)in H5; trivial.
  rewrite H5; trivial.

  red; intros; apply power_elim with (1:=Xty _ H1); trivial.

  red; intros; apply power_elim with (1:=Xty _ H4); trivial.

 exists (W_F x).
 rewrite replf_ax.
 2:red;red;intros;apply Fmono_morph;auto.
 2:apply W_F_mono.
 exists x; auto with *.
Qed.
*)
(*Hint Resolve Wf_stable.*)

(* The fixpoint *)

Definition NF := Ffix Nf Ndom.

Lemma NFtyp : NF ⊆ Ndom.
apply Ffix_inA.
Qed.

Lemma Ni_NF : forall o, isOrd o -> TI Nf o ⊆ NF.
apply TI_Ffix; auto.
Qed.

Lemma TI_Nf_elim : forall a o,
  isOrd o ->
  a ∈ TI Nf o ->
  exists2 o', lt o' o &
  exists2 x, x ∈ N_F (TI Nf o') &
  a == Nsup x.
intros.
apply TI_elim in H0; trivial.
2:apply Fmono_morph; trivial.
destruct H0.
apply Nf_elim in H1.
eauto.
Qed.

Lemma Nsup_typ : forall o x,
  isOrd o ->
  x ∈ N_F (TI Nf o) ->
  Nsup x ∈ TI Nf (osucc o).
intros.
rewrite TI_mono_succ; auto.
apply Nf_intro; trivial.
Qed.

Lemma NF_ind : forall (P:set->Prop),
  Proper (eq_set ==> iff) P ->
  (forall o' x, isOrd o' -> x ∈ N_F (TI Nf o') ->
   (forall i, i ∈ fst x -> P (cc_app (snd x) i)) ->
   P (Nsup x)) ->
  forall a, a ∈ NF -> P a.
intros.
unfold NF in H1; rewrite Ffix_def in H1; auto.
destruct H1.
revert a H2.
apply isOrd_ind with (2:=H1); intros.
apply TI_Nf_elim in H5; trivial.
destruct H5 as (o',?,(x',?,?)).
rewrite H7; clear a H7.
apply H0 with o'; trivial.
 apply isOrd_inv with y; trivial.

 intros.
 apply H4 with o'; trivial.
 apply snd_typ_sigma with (y:=fst x') in H6; auto with *.
 apply cc_prod_elim with (1:=H6); trivial.
Qed.

(* Inverse of Nsup *)
Definition Nfst x :=
  replf (subset x (fun l => exists i, exists l', l == Cons i l')) fst.

Definition Nsnd x :=
  cc_lam (Nfst x) (fun i => replf (subset x (fun l => exists l', l == Cons i l')) snd).

Definition Nsupi x := couple (Nfst x) (Nsnd x).

Lemma Nfst_inv X x:
  X ⊆ Ndom ->
  x ∈ N_F X ->
  Nfst (Nsup x) == fst x.
intros.
unfold Nfst.
apply eq_intro; intros.
 rewrite replf_ax in H1; auto.
 2:admit.
 destruct H1 as (y,?,?).
 rewrite subset_ax in H1; destruct H1.
 destruct H3 as (y',?,(i,(l',?))).
 rewrite H4 in H3; rewrite H3 in H1,H2; rewrite H2; clear H4 H3 H2.
 unfold Cons; rewrite fst_def.
 apply Nsup_tl_prop with (1:=H0) in H1; auto.
 destruct H1; trivial.

 rewrite replf_ax.
 2:admit.
 exists (Cons z Nil).
 2:unfold Cons; rewrite fst_def; reflexivity.
 apply subset_intro.
  rewrite Nsup_tl_prop with (X:=X); trivial.
  split; trivial.
  apply snd_typ_sigma with (y:=fst x) in H0; auto with *.
  apply cc_arr_elim with (2:=H1) in H0.
  apply H in H0.
  apply subset_elim2 in H0.
  destruct H0.
  rewrite H0; trivial.

  exists z; exists Nil; reflexivity.
Qed.

Lemma Nsnd_inv X x:
  X ⊆ Ndom ->
  x ∈ N_F X ->
  Nsnd (Nsup x) == snd x.
intros.
unfold Nsnd.
assert (fx_ty := H0); apply fst_typ_sigma in fx_ty.
assert (sx_ty :=H0); apply snd_typ_sigma with (y:=fst x) in sx_ty; auto with *.
rewrite cc_eta_eq with (1:=sx_ty).
symmetry; apply cc_lam_ext.
 symmetry; apply Nfst_inv with (2:=H0); trivial.
red; intros.
apply eq_intro; intros.
 rewrite replf_ax.
 2:admit.
 exists (Cons x0 z).
 2:unfold Cons; rewrite snd_def; reflexivity.
 apply subset_intro.
 2:exists z; rewrite H2; reflexivity.
 rewrite Nsup_tl_prop with (1:=H0); auto.

 rewrite replf_ax in H3.
 2:admit.
 destruct H3.
 rewrite H4.
 rewrite subset_ax in H3; destruct H3.
 destruct H5.
 destruct H6.
 rewrite H6 in H5; rewrite H5 in H3|-*; clear H4 H5 H6.
 unfold Cons; rewrite snd_def.
 rewrite Nsup_tl_prop with (1:=H0) in H3; trivial.
 rewrite H2; destruct H3; trivial.
Qed.

Lemma Nsup_inv X x:
  X ⊆ Ndom ->
  x ∈ N_F X ->
  Nsupi (Nsup x) == x.
intros.
unfold Nsupi.
rewrite Nfst_inv with (2:=H0); trivial.
rewrite Nsnd_inv with (2:=H0); trivial.
symmetry; apply surj_pair with (1:=subset_elim1 _ _ _ H0).
Qed.

Lemma Nsupi_ty X x :
  X ⊆ Ndom ->
  x ∈ Nf X ->
  Nsupi x ∈ N_F X.
intros.
destruct Nf_elim with (1:=H0); trivial.
Admitted.

(* The closure ordinal of W *)
  Definition N_ord := Ffix_ord Nf Ndom.

(*
  Lemma N_ord_bound : bound_ord NAT N_ord.
red; intros.
unfold N_ord.
unfold Ffix_ord.
pose (G:= fun n => subset NF (fun x => Fix_rec Nf Ndom (F_a Nf Ndom) x == F n)).
pose (G' := replf (cc_prod NAT G) (fun f => Nsup (couple NAT f))).
*)

  Lemma W_o_o : isOrd N_ord.
apply Ffix_o_o; auto.
Qed.
Hint Resolve W_o_o.

(*
  Lemma NF_post : forall a,
   a ∈ NF ->
   a ∈ TI Nf N_ord.
apply Ffix_post; eauto.
intros.
apply Wf_stable.
Qed.

  Lemma W_eqn : W == Wf W.
apply Ffix_eqn; eauto.
apply Wf_stable.
Qed.
*)

End OrdFixpoint.

Section OrdUniverse.

  (* The universe where we build the inductive type *)
  Variable U : set.
  Hypothesis has_cstr : forall X, X ∈ U -> sum UNIT (func NAT X) ∈ U.
  Hypothesis has_empty : empty ∈ U.
  Variable mu : set.
  Hypothesis mu_ord : isOrd mu.
  Hypothesis mu_clos : forall x F,
    le x mu ->
    ext_fun x F ->
    (forall n, n ∈ x -> F n ∈ U) -> sup x F ∈ U.

  Lemma ORDi_pre_typ : forall n, lt n mu -> ORDi n ∈ U.
intros.
assert (isOrd n).
 apply isOrd_inv with mu; auto.
revert H.
induction H0 using isOrd_ind; intros.
unfold ORDi; rewrite TI_eq; auto.
apply mu_clos; intros; auto.
apply has_cstr; apply H1; trivial.
apply isOrd_trans with y; trivial.
Qed.

  Lemma ORD_typ : ORDi mu ∈ U.
unfold ORDi.
rewrite TI_eq; auto.
apply mu_clos; intros; auto.
apply has_cstr.
apply ORDi_pre_typ; trivial.
Qed.

End OrdUniverse.

End Ord_theory.


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** Diaconescu showed that the Axiom of Choice entails Excluded-Middle
   in topoi [Diaconescu75]. Lacas and Werner adapted the proof to show
   that the axiom of choice in equivalence classes entails
   Excluded-Middle in Type Theory [LacasWerner99].

   Three variants of Diaconescu's result in type theory are shown below.

   A. A proof that the relational form of the Axiom of Choice +
      Extensionality for Predicates entails Excluded-Middle (by Hugo
      Herbelin)

   B. A proof that the relational form of the Axiom of Choice + Proof
      Irrelevance entails Excluded-Middle for Equality Statements (by
      Benjamin Werner)

   C. A proof that extensional Hilbert epsilon's description operator
      entails excluded-middle (taken from Bell [Bell93])

   See also [Carlström] for a discussion of the connection between the
   Extensional Axiom of Choice and Excluded-Middle

   [Diaconescu75] Radu Diaconescu, Axiom of Choice and Complementation,
   in Proceedings of AMS, vol 51, pp 176-178, 1975.

   [LacasWerner99] Samuel Lacas, Benjamin Werner, Which Choices imply
   the excluded middle?, preprint, 1999.

   [Bell93] John L. Bell, Hilbert's epsilon operator and classical
   logic, Journal of Philosophical Logic, 22: 1-18, 1993

   [Carlström04] Jesper Carlström, EM + Ext_ + AC_int <-> AC_ext,
   Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004.
*)

(**********************************************************************)
(** * Pred. Ext. + Rel. Axiom of Choice -> Excluded-Middle       *)

Section PredExt_RelChoice_imp_EM.

(** The axiom of extensionality for predicates *)

Definition PredicateExtensionality :=
  forall P Q:bool -> Prop, (forall b:bool, P b <-> Q b) -> P = Q.

(** From predicate extensionality we get propositional extensionality
   hence proof-irrelevance *)

Require Import ClassicalFacts.

Variable pred_extensionality : PredicateExtensionality.

Lemma prop_ext : forall A B:Prop, (A <-> B) -> A = B.
Proof.
  intros A B H.
  change ((fun _ => A) true = (fun _ => B) true) in |- *.
  rewrite
   pred_extensionality with (P := fun _:bool => A) (Q := fun _:bool => B).
    reflexivity.
    intros _; exact H.
Qed.

Lemma proof_irrel : forall (A:Prop) (a1 a2:A), a1 = a2.
Proof.
  apply (ext_prop_dep_proof_irrel_cic prop_ext).
Qed.

(** From proof-irrelevance and relational choice, we get guarded
   relational choice *)

Require Import ChoiceFacts.

Variable rel_choice : RelationalChoice.

Lemma guarded_rel_choice : GuardedRelationalChoice.
Proof.
 apply
  (rel_choice_and_proof_irrel_imp_guarded_rel_choice rel_choice proof_irrel).
Qed.

(** The form of choice we need: there is a functional relation which chooses
    an element in any non empty subset of bool *)

Require Import Bool.

Lemma AC_bool_subset_to_bool :
  exists R : (bool -> Prop) -> bool -> Prop,
   (forall P:bool -> Prop,
      (exists b : bool, P b) ->
       exists b : bool, P b /\ R P b /\ (forall b':bool, R P b' -> b = b')).
Proof.
  destruct (guarded_rel_choice _ _
   (fun Q:bool -> Prop =>  exists y : _, Q y)
   (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)).
    exact (fun _ H => H).
  exists R; intros P HP.
  destruct (HR P HP) as (y,(Hy,Huni)).
  exists y; firstorder.
Qed.

(** The proof of the excluded middle *)
(** Remark: P could have been in Set or Type *)

Theorem pred_ext_and_rel_choice_imp_EM : forall P:Prop, P \/ ~ P.
Proof.
intro P.

(** first we exhibit the choice functional relation R *)
destruct AC_bool_subset_to_bool as [R H].

set (class_of_true := fun b => b = true \/ P).
set (class_of_false := fun b => b = false \/ P).

(** the actual "decision": is (R class_of_true) = true or false? *)
destruct (H class_of_true) as [b0 [H0 [H0' H0'']]].
exists true; left; reflexivity.
destruct H0.

(** the actual "decision": is (R class_of_false) = true or false? *)
destruct (H class_of_false) as [b1 [H1 [H1' H1'']]].
exists false; left; reflexivity.
destruct H1.

(** case where P is false: (R class_of_true)=true /\ (R class_of_false)=false *)
right.
intro HP.
assert (Hequiv : forall b:bool, class_of_true b <-> class_of_false b).
intro b; split.
unfold class_of_false in |- *; right; assumption.
unfold class_of_true in |- *; right; assumption.
assert (Heq : class_of_true = class_of_false).
apply pred_extensionality with (1 := Hequiv).
apply diff_true_false.
rewrite <- H0.
rewrite <- H1.
rewrite <- H0''. reflexivity.
rewrite Heq.
assumption.

(** cases where P is true *)
left; assumption.
left; assumption.

Qed.

End PredExt_RelChoice_imp_EM.

(**********************************************************************)
(** * B. Proof-Irrel. + Rel. Axiom of Choice -> Excl.-Middle for Equality *)

(** This is an adaptation of Diaconescu's paradox exploiting that
    proof-irrelevance is some form of extensionality *)

Section ProofIrrel_RelChoice_imp_EqEM.

Variable rel_choice : RelationalChoice.

Variable proof_irrelevance : forall P:Prop , forall x y:P, x=y.

(** Let [a1] and [a2] be two elements in some type [A] *)

Variable A :Type.
Variables a1 a2 : A.

(** We build the subset [A'] of [A] made of [a1] and [a2] *)

Definition A' := sigT (fun x => x=a1 \/ x=a2).

Definition a1':A'.
exists a1 ; auto.
Defined.

Definition a2':A'.
exists a2 ; auto.
Defined.

(** By proof-irrelevance, projection is a retraction *)

Lemma projT1_injective : a1=a2 -> a1'=a2'.
Proof.
  intro Heq ; unfold a1', a2', A'.
  rewrite Heq.
  replace (or_introl (a2=a2) (refl_equal a2))
     with (or_intror (a2=a2) (refl_equal a2)).
  reflexivity.
  apply proof_irrelevance.
Qed.

(** But from the actual proofs of being in [A'], we can assert in the
    proof-irrelevant world the existence of relevant boolean witnesses *)

Lemma decide : forall x:A', exists y:bool ,
  (projT1 x = a1 /\ y = true ) \/ (projT1 x = a2 /\ y = false).
Proof.
  intros [a [Ha1|Ha2]]; [exists true | exists false]; auto.
Qed.

(** Thanks to the axiom of choice, the boolean witnesses move from the
    propositional world to the relevant world *)

Theorem proof_irrel_rel_choice_imp_eq_dec : a1=a2 \/ ~a1=a2.
Proof.
  destruct
    (rel_choice A' bool
       (fun x y =>  projT1 x = a1 /\ y = true \/ projT1 x = a2 /\ y = false))
    as (R,(HRsub,HR)).
    apply decide.
  destruct (HR a1') as (b1,(Ha1'b1,_Huni1)).
  destruct (HRsub a1' b1 Ha1'b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)].
  destruct (HR a2') as (b2,(Ha2'b2,Huni2)).
  destruct (HRsub a2' b2 Ha2'b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)].
    left; symmetry; assumption.
    right; intro H.
    subst b1; subst b2.
    rewrite (projT1_injective H) in Ha1'b1.
    assert (false = true) by auto using Huni2.
    discriminate.
  left; assumption.
Qed.

(** An alternative more concise proof can be done by directly using
    the guarded relational choice *)

Declare Implicit Tactic auto.

Lemma proof_irrel_rel_choice_imp_eq_dec' : a1=a2 \/ ~a1=a2.
Proof.
  assert (decide: forall x:A, x=a1 \/ x=a2 ->
                exists y:bool, x=a1 /\ y=true \/ x=a2 /\ y=false).
    intros a [Ha1|Ha2]; [exists true | exists false]; auto.
  assert (guarded_rel_choice :=
          rel_choice_and_proof_irrel_imp_guarded_rel_choice
	  rel_choice
	  proof_irrelevance).
  destruct
    (guarded_rel_choice A bool
      (fun x => x=a1 \/ x=a2)
      (fun x y => x=a1 /\ y=true \/ x=a2 /\ y=false))
      as (R,(HRsub,HR)).
      apply decide.
  destruct (HR a1) as (b1,(Ha1b1,_Huni1)). left; reflexivity.
  destruct (HRsub a1 b1 Ha1b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)].
  destruct (HR a2) as (b2,(Ha2b2,Huni2)). right; reflexivity.
  destruct (HRsub a2 b2 Ha2b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)].
    left; symmetry; assumption.
    right; intro H.
    subst b1; subst b2; subst a1.
    assert (false = true) by auto using Huni2, Ha1b1.
    discriminate.
  left; assumption.
Qed.

End ProofIrrel_RelChoice_imp_EqEM.

(**********************************************************************)
(** * Extensional Hilbert's epsilon description operator -> Excluded-Middle *)

(** Proof sketch from Bell [Bell93] (with thanks to P. Castéran) *)

Notation Local inhabited A := A (only parsing).

Section ExtensionalEpsilon_imp_EM.

Variable epsilon : forall A : Type, inhabited A -> (A -> Prop) -> A.

Hypothesis epsilon_spec :
  forall (A:Type) (i:inhabited A) (P:A->Prop),
  (exists x, P x) -> P (epsilon A i P).

Hypothesis epsilon_extensionality :
  forall (A:Type) (i:inhabited A) (P Q:A->Prop),
  (forall a, P a <-> Q a) -> epsilon A i P = epsilon A i Q.

Notation Local eps := (epsilon bool true) (only parsing).

Theorem extensional_epsilon_imp_EM : forall P:Prop, P \/ ~ P.
Proof.
  intro P.
  pose (B := fun y => y=false \/ P).
  pose (C := fun y => y=true  \/ P).
  assert (B (eps B)) as [Hfalse|HP]
    by (apply epsilon_spec; exists false; left; reflexivity).
  assert (C (eps C)) as [Htrue|HP]
    by (apply epsilon_spec; exists true; left; reflexivity).
    right; intro HP.
    assert (forall y, B y <-> C y) by (intro y; split; intro; right; assumption).
    rewrite epsilon_extensionality with (1:=H) in Hfalse.
    rewrite Htrue in Hfalse.
    discriminate.
  auto.
  auto.
Qed.

End ExtensionalEpsilon_imp_EM.


Require Import A1_Plan A2_Orientation A7_Tactics.
Require Import B1_ClockwiseProp.

Section COLLINEAR_PROPERTIES.

Lemma CollinearAAB : forall A B, Collinear A A B.
Proof.
	canonize1;  elim (NotClockwiseAAB _ _ H).
Qed.

Lemma CollinearABA : forall A B, Collinear A B A.
Proof.
	canonize1.
	 elim (NotClockwiseABA _ _ H).
	 elim (NotClockwiseABB _ _ H).
Qed.

Lemma CollinearABB : forall A B, Collinear A B B.
Proof.
	canonize1.
	 elim (NotClockwiseABB _ _ H).
	 elim (NotClockwiseABA _ _ H).
Qed.

Lemma NotCollinearDistinctAB : forall A B C : Point,
	~Collinear A B C -> A <> B.
Proof.
	red in |- *; intros; subst.
	elim H; apply CollinearAAB.
Qed.

Lemma NotCollinearDistinctBC : forall A B C : Point,
	~Collinear A B C -> B <> C.
Proof.
	red in |- *; intros; subst.
	elim H; apply CollinearABB.
Qed.

Lemma NotCollinearDistinctCA : forall A B C : Point,
	~Collinear A B C -> C <> A.
Proof.
	red in |- *; intros; subst.
	elim H; apply CollinearABA.
Qed.

Lemma CollinearBCA : forall A B C,
	Collinear A B C -> Collinear B C A.
Proof.
	canonize1.
	 elim H0; apply ClockwiseCAB; trivial.
	 elim H1; apply ClockwiseBCA; trivial.
Qed.

Lemma CollinearCAB : forall A B C,
	Collinear A B C -> Collinear C A B.
Proof.
	intros; do 2 apply CollinearBCA; trivial.
Qed.

Lemma CollinearBAC : forall A B C,
	Collinear A B C -> Collinear B A C.
Proof.
	unfold Collinear in |- *; intuition.
Qed.

Lemma CollinearACB : forall A B C,
	Collinear A B C -> Collinear A C B.
Proof.
	intros; apply CollinearBAC; apply CollinearCAB; trivial.
Qed.

Lemma CollinearCBA : forall A B C,
	Collinear A B C -> Collinear C B A.
Proof.
	intros; apply CollinearBAC; apply CollinearBCA; trivial.
Qed.

Lemma CollinearNotClockwise : forall A B C,
	Collinear A B C -> ~Clockwise A B C.
Proof.
	canonize1.
Qed.

Lemma ClockwiseABCNotCollinear : forall A B C,
	Clockwise A B C -> ~Collinear A B C.
Proof.
	canonize1.
Qed.

Lemma ClockwiseBACNotCollinear : forall A B C,
	Clockwise B A C -> ~Collinear A B C.
Proof.
	canonize1.
Qed.

End COLLINEAR_PROPERTIES.


(*|

========================
Weak fairness
========================

This file proves two big results about weak fairness. First, a key rule called "wf1" allows to prove that `p ~~> q` using the weak fairness of some action. Second, `wf_combine` gives a condition under which two weak fairness assumptions are equivalent to weak fairness of the composite action; that is, `WF(a1) ∧ WF(a2) == WF(a1 ∨ a2)` (with a slight abuse of notation in `a1 ∨ a2`, which needs to be `λ s s', a1 s s' ∨ a2 s s'`).

These both require non-trivial proofs.

|*)
From TLA Require Import defs automation.
From TLA Require Import propositional_ltl modalities.
From TLA Require Import classical.
From TLA.logic Require Import preds.

Section TLA.

Context [Σ: Type].

Notation exec := (exec Σ).
Notation predicate := (predicate Σ).

Implicit Types (e: exec) (p q: predicate) (a: action Σ).

Theorem weak_fairness_alt1 a :
  weak_fairness a == □ ◇ ((! (tla_enabled a)) ∨ □ ◇ ⟨a⟩).
Proof.
  unfold weak_fairness.
  rewrite implies_to_or.
  tla_simp.
  rewrite -!eventually_or.
  rewrite !always_eventually_distrib.
  tla_simp.
Qed.

Theorem weak_fairness_alt1' a :
  weak_fairness a == □ ◇ ((! (tla_enabled a)) ∨ ⟨a⟩).
Proof.
  rewrite weak_fairness_alt1.
  rewrite !always_eventually_distrib.
  tla_simp.
Qed.

Theorem weak_fairness_alt2 a :
  weak_fairness a == (◇ □ (tla_enabled a) → □ ◇ ⟨a⟩).
Proof.
  rewrite weak_fairness_alt1.
  rewrite implies_to_or.
  tla_simp.
  rewrite always_eventually_distrib.
  tla_simp.
Qed.

Theorem weak_fairness_alt3 a :
  weak_fairness a == (□◇ ⟨a⟩ ∨ □◇ !(tla_enabled a)).
Proof.
  rewrite weak_fairness_alt2.
  rewrite implies_to_or.
  tla_simp.
  rewrite tla_or_comm //.
Qed.

(** This lemma is used to prove rule WF1. Loosely speaking it takes an
  assumption of the form [p ∧ ⟨next⟩ → later p ∨ later q] and turns it into a
  proof that either [p] always holds or eventually [q] holds. *)
Lemma until_next (p q: predicate) (next: action Σ) (e: exec) :
  (* induction-like hypothesis: p is preserved until q *)
  (∀ e, p e ∧ next (e 0) (e 1) →
        p (drop 1 e) ∨ q (drop 1 e)) →
  (* this is □⟨next⟩ e *)
  (∀ k, next (e k) (e (S k))) →
  (* we can prove always p or eventually q, but only after some shifted
  execution satisfying [p] as a base case for the induction *)
  ∀ k, p (drop k e) →
       (∀ k', p (drop (k' + k) e)) ∨
       (∃ k', q (drop (k' + k) e)).
Proof.
  intros Hind Hnext k Hp.

(*|
This proof is highly classical - we immediately appeal to a double negation
to deal with this disjunction.
|*)

  apply classical.double_negation.
  rewrite classical.not_or classical.not_forall classical.not_exists.
  intros [[k' Hnotp] Hnotq].

(*|
Classical reasoning gives a *specific* k' with `¬p` and `□ ¬q`. It turns out
we'll always derive a contradiction from the `¬p`, by induction on the k'. This
is what makes the proof so classical, this k' sort of comes out of nowhere.
|*)

  apply Hnotp; clear Hnotp. (* .unfold *)
  generalize dependent e. generalize dependent k.
  induction k'.
  - intuition auto.
  - intros.
    destruct (Hind (drop k e)); eauto; swap 1 2.
    { rewrite drop_drop in H. exfalso; eapply Hnotq; apply H.  }
    rewrite drop_drop in H.
    replace (S k' + k) with (k' + S k) by lia.
    eapply IHk'; eauto.
    intros.
    replace (x + S k) with (S x + k) by lia; eauto.
Qed.

(** WF1 exploits a weak fairness assumption to show a leads_to. This is the
general rule as presented in the paper. [wf1] below specializes it to the
situation where p and q are simple state predicates. *)
Lemma tla_wf1 (p q: predicate) (next a: action Σ) :
  ∀ (Hpuntilq: ⊢ p ∧ ⟨next⟩ → later p ∨ later q)
    (Haq: ⊢ p ∧ ⟨next⟩ ∧ ⟨a⟩ → later q)
    (Henable: ⊢ p → tla_enabled a),
  (⊢ □ ⟨next⟩ ∧ weak_fairness a → p ~~> q).
Proof.
  rewrite weak_fairness_alt1'.
  unseal.
  destruct H as [Hnext Hwf_alt].

  (* [until_next] produces three goals. The first is simply the proof of [p
  (drop k e)] which is needed as a starting point. Then it leaves two
  possibilities: either [p] always holds, or [◇ q] (loosely speaking). The
  latter case is exactly the goal so it goes through immediately. *)
  edestruct (until_next p q next e Hpuntilq Hnext);
    [ eassumption | | by auto ].

  (* in the former case we'll show that weak fairness gives us either that [a]
  is never enabled (false, because p implies it is enabled), or that [a]
  executes at some point, at which point [Haq] easily gives us [q].  *)

  destruct (Hwf_alt k) as [k' [Hnotenabled | Ha]].
  { (* impossible, we have p everywhere after k *)
    contradiction Hnotenabled.
    apply Henable; eauto. }

  exists (S k').
  change (S k' + k) with (1 + (k' + k)). rewrite -drop_drop.
  apply Haq; eauto.
Qed.

(*|
**WF1**. This is an important rule that uses a weak fairness assumption to show
that [p ~~> q].

This has the advantage of stating all assumptions
as simple quantified statements, without temporal logic.

Intuitively [wf1] is used to prove [p ~~> q] from the weak fairness of some
action [a]. The second premise establishes the intuition that [a] which has
"precondition" [p] and "postcondition" [q]: if [a] runs in a state satisfying
[p], then [q] holds. The first premise says that [p] is preserved by [⟨next⟩],
or [q] just magically becomes true, in which case [a] need not run and [p ~~> q]
can still be true. (This is important because [q] might actually disable the
action from running again.) The third premise says that [p] enables [a], so
preserving it also preserves that the action is enabled.

[p] is separate from [enabled a] in order to accomplish two things. First, it
allows to strengthen the inductive hypothesis to show [Hpuntilq]. Second, it
gives a stronger premise for [Haq], allowing to use some state-specific fact to
establish a more specific postcondition [q] than [a] might have in general.
|*)

Lemma wf1 (a: action Σ) (next: action Σ) (p q: Σ → Prop)  :
  ∀ (Hpuntilq: ∀ s s', p s → next s s' → p s' ∨ q s')
    (Haq: ∀ s s', p s → next s s' → a s s' → q s')
    (Henable: ∀ s, p s → enabled a s),
  (⊢ □ ⟨next⟩ ∧ weak_fairness a → ⌜p⌝ ~~> ⌜q⌝).
Proof.
  intros.
  apply tla_wf1; unseal.
  rewrite /tla_enabled; tla_simp.
  eauto.
Qed.

Theorem enabled_or a1 a2 :
  ∀ s, enabled (λ s s', a1 s s' ∨ a2 s s') s ↔ (enabled a1 s ∨ enabled a2 s).
Proof.
  unfold enabled.
  intuition (repeat deex; eauto).
  intuition eauto.
Qed.

Theorem tla_enabled_or a1 a2 :
  tla_enabled (λ s s', a1 s s' ∨ a2 s s')%type ==
  (tla_enabled a1 ∨ tla_enabled a2).
Proof.
  apply predicate_ext => e.
  rewrite /tla_enabled; tla_simp.
  rewrite enabled_or; tla_simp.
Qed.

Lemma not_wf (a: action Σ) :
  ! weak_fairness a == (◇ (□ tla_enabled a ∧ ! ◇ ⟨a⟩)).
Proof.
  rewrite /weak_fairness; tla_simp.
Qed.

Lemma not_wf' (a: action Σ) :
  ! weak_fairness a == (◇ (□ (tla_enabled a ∧ !⟨a⟩))).
Proof.
  rewrite /weak_fairness; tla_simp.
  rewrite always_and //.
Qed.

Lemma always_eventually_impl p q :
  (p ⊢ q) →
  (□◇ p ⊢ □◇ q).
Proof.
  intros H.
  apply always_impl_proper.
  apply eventually_impl_proper.
  auto.
Qed.

Lemma eventually_always_impl p q :
  (p ⊢ q) →
  (◇□ p ⊢ ◇□ q).
Proof.
  intros H.
  apply eventually_impl_proper.
  apply always_impl_proper.
  auto.
Qed.

Lemma eventually_always_weaken p :
  (◇□ p ⊢ □◇ p).
Proof.
  unseal.
  repeat deex.
  exists k0; eauto.
  replace (k0 + k) with (k + k0) by lia.
  auto.
Qed.

Lemma action_to_enabled a :
  ⟨a⟩ ⊢ tla_enabled a.
Proof.
  rewrite /tla_enabled /enabled.
  unseal.
Qed.

Lemma not_enabled_to_action a :
  !tla_enabled a ⊢ !⟨a⟩.
Proof.
  apply not_impl. tla_simp.
  apply action_to_enabled.
Qed.

Lemma or_apply_not r q p :
  (p ⊢ □ r ∨ ◇q) →
  p ∧ □ !q ⊢ □ r.
Proof.
  intros Hdr.
  rewrite -> Hdr; clear Hdr.
  intros e H.
  unseal.
  destruct H as [Hp Hnota].
  destruct Hp as [Hp | Ha].
  - pose proof (Hp 0) as Hp0; rewrite drop_0 in Hp0; auto.
  - destruct Ha as [k' Ha].
    exfalso; eapply Hnota; eauto.
Qed.

Lemma or_apply_not' r q p :
  (p ⊢ □ r ∨ ◇q) →
  □ p ∧ □ !q ⊢ □ r.
Proof.
  intros Hdr.
  rewrite -> (always_weaken p).
  apply or_apply_not; auto.
Qed.

Lemma or_implies_split p q r :
  (p ⊢ r) →
  (q ⊢ r) →
  (p ∨ q ⊢ r).
Proof.
  unseal.
Qed.

Lemma wf_combine_impl' f (a b: action Σ) :
  (□f ⊢ tla_enabled a → □ !tla_enabled b ∨ ◇ ⟨a⟩) →
  (□f ⊢ tla_enabled b → □ !tla_enabled a ∨ ◇ ⟨b⟩) →
  □f ∧ (◇ □ (tla_enabled a ∧ ! ⟨a⟩) ∨ ◇ □ (tla_enabled b ∧ ! ⟨b⟩)) ⊢
  ◇ □ ((tla_enabled a ∨ tla_enabled b) ∧ ! ⟨a⟩ ∧ ! ⟨b⟩).
Proof.
  intros Hdr1 Hdr2.
  apply impl_intro'_iff in Hdr1.
  apply impl_intro'_iff in Hdr2.
  rewrite tla_and_distr_l.
  rewrite -(always_idem f).
  rewrite !always_and_eventually.
  rewrite always_and.
  apply or_implies_split; apply eventually_impl_proper.
  + apply or_apply_not' in Hdr1.
    rewrite always_and in Hdr1.
    autorewrite with tla in Hdr1.
    tla_pose Hdr1.
    rewrite -> not_enabled_to_action.
    unseal.
  + apply or_apply_not' in Hdr2.
    rewrite always_and in Hdr2.
    autorewrite with tla in Hdr2.
    rewrite always_and.
    tla_pose Hdr2.
    rewrite -> not_enabled_to_action.
    unseal.
Qed.

Lemma wf_combine_impl (a b: action Σ) :
  (tla_enabled a ⊢ □ !tla_enabled b ∨ ◇ ⟨a⟩) →
  (tla_enabled b ⊢ □ !tla_enabled a ∨ ◇ ⟨b⟩) →
  ◇ □ (tla_enabled a ∧ ! ⟨a⟩) ∨ ◇ □ (tla_enabled b ∧ ! ⟨b⟩) ⊢
  ◇ □ ((tla_enabled a ∨ tla_enabled b) ∧ ! ⟨a⟩ ∧ ! ⟨b⟩).
Proof.
  intros Hdr1 Hdr2.
  apply or_implies_split; apply eventually_impl_proper; rewrite always_and.
  + tla_pose (or_apply_not' _ _ _ Hdr1).
    rewrite not_enabled_to_action.

    (* TODO: why does tla_prop not work here? *)
    unseal.
  + tla_pose (or_apply_not' _ _ _ Hdr2).
    rewrite not_enabled_to_action.

    unseal.
Qed.

(* for some reason this direction of [wf_combine] seems more difficult and
unstructured *)
Lemma wf_split_impl (a b: action Σ) :
  (tla_enabled a ⊢ □ !tla_enabled b ∨ ◇ ⟨a⟩) →
  (tla_enabled b ⊢ □ !tla_enabled a ∨ ◇ ⟨b⟩) →
  ◇ □ ((tla_enabled a ∨ tla_enabled b) ∧ ! ⟨a⟩ ∧ ! ⟨b⟩) ⊢
  ◇ □ (tla_enabled a ∧ ! ⟨a⟩) ∨ ◇ □ (tla_enabled b ∧ ! ⟨b⟩).
Proof.
  intros Hdr1 Hdr2.
  intros e H.
  destruct H as [k H'].
  rewrite !always_and in H'. destruct H' as (Hab & Hnota & Hnotb).
  pose proof (Hab 0) as Hab0;
    rewrite drop_0 in Hab0;
    destruct Hab0 as [Ha | Hb].
  + pose proof (or_apply_not _ _ _ Hdr1 (drop k e) ltac:(unseal)).
    left.
    exists k.
    rewrite always_and.
    split; eauto.
    intros k'; setoid_rewrite drop_drop.
    destruct (Hab k') as [Ha'|Hb']; eauto.
    { exfalso; eapply H; eauto. }
  + pose proof (or_apply_not _ _ _ Hdr2 (drop k e) ltac:(unseal)).
    right.
    exists k.
    rewrite always_and.
    split; eauto.
    intros k'; setoid_rewrite drop_drop.
    destruct (Hab k') as [Ha'|Hb']; eauto.
    { exfalso; eapply H; eauto. }
Qed.

(** This theorem comes from the book "Specifying Systems", theorem 8.20. It has
a surprisingly complicated proof! *)
Theorem wf_combine (a b: action Σ) :
  (tla_enabled a ⊢ □ !tla_enabled b ∨ ◇ ⟨a⟩) →
  (tla_enabled b ⊢ □ !tla_enabled a ∨ ◇ ⟨b⟩) →
  (weak_fairness a ∧ weak_fairness b) ==
  weak_fairness (λ s s', a s s' ∨ b s s')%type.
Proof.
  intros Hdr1 Hdr2.
  apply not_inj.

  rewrite not_and.
  rewrite !not_wf'.
  rewrite -!combine_or_actions.
  rewrite tla_enabled_or.
  rewrite not_or.
  tla_split.
  - apply wf_combine_impl; auto.
  - apply wf_split_impl; auto.
Qed.

Lemma always_drop_ge (p: predicate) k e :
  (□p)%L (drop k e) →
  (∀ k', k ≤ k' → p (drop k' e)).
Proof.
  intros Hp k' Hle.
  replace k' with ((k' - k) + k) by lia.
  rewrite -drop_drop.
  apply Hp.
Qed.

Theorem tla_wf2 (n m a b: action Σ) (p f: predicate) :
  (⟨n⟩ ∧ ⟨b⟩ ⊢ ⟨m⟩) →
  (p ∧ later p ∧ ⟨n⟩ ∧ ⟨a⟩ ∧ tla_enabled m ⊢ ⟨b⟩) →
  (p ∧ tla_enabled m ⊢ tla_enabled a) →
  (□⟨λ s s', n s s' ∧ ¬b s s'⟩ ∧
     weak_fairness a ∧ □f ∧
     ◇□ (tla_enabled m) ⊢ ◇□p) →
  (□⟨n⟩ ∧ weak_fairness a ∧ □f ⊢ weak_fairness m).
Proof.
  intros Hn_to_m Ha_to_b Hm_to_a_enabled Hp_while_not_b.
  apply tla_contra.
  rewrite (weak_fairness_alt3 m). tla_simp.
  do 2 rewrite -tla_and_assoc.
  rewrite -eventually_always_distrib.
  rewrite always_and.
  tla_simp.
  intros e (Hn & Hwf & Hf & Heventually).
  rewrite /tla_false /=.
  destruct Heventually as [k [Hnot_m Henabled_m]].
  assert ((□⟨λ s s', n s s' ∧ ¬ b s s'⟩)%L (drop k e)).
  { unseal. split.
    - apply Hn.
    - intros Hb.
      contradiction (Hnot_m k0).
      apply Hn_to_m.
      rewrite drop_drop.
      split; eauto.
  }
  assert ((◇□ p)%L (drop k e)) as [k' Hp].
  { apply Hp_while_not_b.
    split; eauto.
    split.
    { rewrite /weak_fairness. rewrite {1}/always; intros.
      rewrite drop_drop.
      apply Hwf. }
    split.
    { rewrite /always => k'. rewrite drop_drop. apply Hf. }
    exists 0. rewrite drop_0.
    apply Henabled_m. }
  rewrite drop_drop in Hp.
  assert ((□◇⟨a⟩)%L (drop (k' + k) e)) as Heventually_a.
  { intros k''. rewrite drop_drop.
    apply Hwf.
    intros k'''.
    apply Hm_to_a_enabled.
    rewrite drop_drop.
    split.
    - eapply always_drop_ge; [ eassumption | lia ].
    - eapply always_drop_ge; [ eassumption | lia ]. }
  rewrite always_and in H; destruct H as [_ Hnotb].
  destruct (Heventually_a 0) as [k'' Ha].
  rewrite ?drop_0 !drop_drop in Ha.
  apply (Hnotb (k'' + k')).
  rewrite !drop_drop.
  apply Ha_to_b.
  repeat split; eauto.
  - eapply always_drop_ge; [ apply Hp | lia ].
  - rewrite /later drop_drop.
    eapply always_drop_ge; [ apply Hp | lia ].
  - replace (k'' + k' + k) with (k'' + (k' + k)) by lia;
      assumption.
Qed.

End TLA.


(** * Definition of Context Free Grammars *)
Require Import Coq.Strings.String Coq.Lists.List Coq.Program.Program.
Require Export Parsers.StringLike.

Set Implicit Arguments.
Local Set Boolean Equality Schemes.
Local Set Decidable Equality Schemes.

Delimit Scope string_like_scope with string_like.

Section cfg.
  Variable CharType : Type.

  Section definitions.
    (** An [item] is the basic building block of a context-free
        grammar; it is either a terminal ([CharType]-literal) or a
        nonterminal of a given name. *)
    Inductive item :=
    | Terminal (_ : CharType)
    | NonTerminal (name : string).

    (** A [productions] is a list of possible [production]s; a
        [production] is a list of [item]s.  A string matches a
        [production] if it can be broken up into components that match
        the relevant element of the [production]. *)
    Definition production := list item.
    Definition productions := list production.

    Definition production_dec (CharType_eq_dec : forall x y : CharType, {x = y} + {x <> y})
               (x y : production) : {x = y} + {x <> y}.
    Proof.
      repeat (apply list_eq_dec; intros);
      decide equality.
      apply string_dec.
    Defined.

    Definition productions_dec (CharType_eq_dec : forall x y : CharType, {x = y} + {x <> y})
               (x y : productions) : {x = y} + {x <> y}.
    Proof.
      apply list_eq_dec; intros; apply production_dec; assumption.
    Defined.

    (** A [grammar] consists of [productions] to match a string
        against, and a function mapping names to [productions]. *)
    (** TODO(jgross): also include list of valid starting non-terminals, for convenience and notation *)
    (** TODO(jgross): look up notations for specifying these nicely *)
    Record grammar :=
      {
        Start_symbol :> string;
        Lookup :> string -> productions;
        Start_production :> productions := Lookup Start_symbol;
        Valid_nonterminal_symbols : list string;
        Valid_nonterminals : list productions := map Lookup Valid_nonterminal_symbols
      }.
  End definitions.

  Section parse.
    Variable String : string_like CharType.
    Variable G : grammar.
    (** A parse of a string into [productions] is a [production] in
        that list, together with a list of substrings which cover the
        original string, each of which is a parse of the relevant
        component of the [production]. *)
    Inductive parse_of : String -> productions -> Type :=
    | ParseHead : forall str pat pats, parse_of_production str pat
                                       -> parse_of str (pat::pats)
    | ParseTail : forall str pat pats, parse_of str pats
                                       -> parse_of str (pat::pats)
    with parse_of_production : String -> production -> Type :=
    | ParseProductionNil : parse_of_production (Empty _) nil
    | ParseProductionCons : forall str pat strs pats,
                           parse_of_item str pat
                           -> parse_of_production strs pats
                           -> parse_of_production (str ++ strs) (pat::pats)
    with parse_of_item : String -> item -> Type :=
    | ParseTerminal : forall x, parse_of_item [[ x ]]%string_like (Terminal x)
    | ParseNonTerminal : forall name str, parse_of str (Lookup G name)
                                          -> parse_of_item str (NonTerminal name).

    Definition ParseProductionSingleton str it (p : parse_of_item str it) : parse_of_production str [ it ].
    Proof.
      rewrite <- (RightId _ str).
      constructor; assumption || constructor.
    Defined.

    Definition ParseProductionApp str1 str2 p1 p2 (pop1 : parse_of_production str1 p1) (pop2 : parse_of_production str2 p2)
    : parse_of_production (str1 ++ str2) (p1 ++ p2)%list.
    Proof.
      induction pop1; simpl.
      { rewrite LeftId; assumption. }
      { rewrite Associativity.
        constructor; assumption. }
    Defined.

    Definition ParseApp str1 str2 p1 p2 (po1 : parse_of str1 [ p1 ]) (po2 : parse_of str2 [ p2 ])
    : parse_of (str1 ++ str2) [ (p1 ++ p2)%list ].
    Proof.
      inversion_clear po1; inversion_clear po2;
      try match goal with
            | [ H : parse_of _ [] |- _ ] => exfalso; revert H; clear; intro H; abstract inversion H
          end.
      { constructor. apply ParseProductionApp; assumption. }
    Defined.
  End parse.

  Definition parse_of_grammar (String : string_like CharType) (str : String) (G : grammar) :=
    parse_of String G str G.
End cfg.

Arguments parse_of _%type_scope _ _ _%string_like _.
Arguments parse_of_item _%type_scope _ _ _%string_like _.
Arguments parse_of_production _%type_scope _ _ _%string_like _.
Arguments parse_of_grammar _%type_scope _ _%string_like _.

Local Hint Extern 0 => match goal with H : S _ = 0 |- _ => destruct (NPeano.Nat.neq_succ_0 _ H) end.

Section examples.
  Section generic.
    Variable CharType : Type.
    Variable String : string_like CharType.

    Definition trivial_grammar : grammar CharType :=
      {| Start_symbol := "";
         Lookup := fun _ => nil::nil;
         Valid_nonterminal_symbols := ""%string::nil |}.

    Definition trivial_grammar_parses_empty_string : parse_of_grammar _ (Empty String) trivial_grammar.
    Proof.
      hnf.
      simpl.
      apply ParseHead.
      constructor.
    Qed.
  End generic.
End examples.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import Reals.
Require Import trajectory_const.

Definition rho (h : TypeSpeed) : R := (g * (tan MaxBank / h))%R.
Definition r (h : TypeSpeed) : R := (h / rho h)%R.
Definition rho_ub (h : TypeSpeed) : R := (g * (tan_ub_MaxBank / h))%R.
Definition rho_lb (h : TypeSpeed) : R := (g * (tan_lb_MaxBank / h))%R.

(**********)
Lemma TypeSpeed_pos : forall h : TypeSpeed, (0 < h)%R.
intro; assert (H := v_cond1 h).
apply Rlt_le_trans with MinSpeed.
unfold MinSpeed in |- *; prove_sup.
assumption.
Qed.

(**********)
Lemma g_pos : (0 < g)%R.
unfold g in |- *; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 10%R.
prove_sup.
rewrite Rmult_0_r; rewrite <- Rmult_comm; rewrite Rmult_assoc;
 rewrite <- Rinv_l_sym; [ prove_sup | discrR ].
Qed.

(**********)
Lemma rho_ub_0 : forall h : TypeSpeed, (rho h < rho_ub h)%R.
intros; unfold rho, rho_ub in |- *; apply Rmult_lt_compat_l;
 [ apply g_pos
 | generalize TypeSpeed_pos; intros; generalize (H h); clear H; intro H;
    generalize (Rinv_0_lt_compat h H); intro H1; generalize tan_MaxBank_ub;
    intro H2;
    generalize (Rmult_lt_compat_l (/ h) (tan MaxBank) tan_ub_MaxBank H1 H2);
    rewrite Rmult_comm; rewrite <- (Rmult_comm tan_ub_MaxBank);
    intro H3; assumption ].
Qed.

(**********)
Lemma rho_lb_0 : forall h : TypeSpeed, (rho_lb h < rho h)%R.
intros; unfold rho, rho_lb in |- *; apply Rmult_lt_compat_l;
 [ apply g_pos
 | generalize TypeSpeed_pos; intros; generalize (H h); clear H; intro H;
    generalize (Rinv_0_lt_compat h H); intro H1; generalize tan_MaxBank_lb;
    intro H2;
    generalize (Rmult_lt_compat_l (/ h) tan_lb_MaxBank (tan MaxBank) H1 H2);
    rewrite <- (Rmult_comm (tan MaxBank));
    rewrite <- (Rmult_comm tan_lb_MaxBank); intro H3;
    assumption ].
Qed.

Definition r_ub (h : TypeSpeed) : R := (h / rho_lb h)%R.
Definition r_lb (h : TypeSpeed) : R := (h / rho_ub h)%R.

(**********)
Lemma tan_lb_MaxBank_pos : (0 < tan_lb_MaxBank)%R.
unfold tan_lb_MaxBank in |- *; unfold Rdiv in |- *;
 apply Rmult_lt_reg_l with 10%R.
prove_sup.
rewrite Rmult_0_r; rewrite <- Rmult_comm; rewrite Rmult_assoc;
 rewrite <- Rinv_l_sym; [ prove_sup | discrR ].
Qed.

(**********)
Lemma tan_ub_MaxBank_pos : (0 < tan_ub_MaxBank)%R.
apply Rlt_trans with tan_lb_MaxBank;
 [ apply tan_lb_MaxBank_pos
 | apply Rlt_trans with (tan MaxBank);
    [ apply tan_MaxBank_lb | apply tan_MaxBank_ub ] ].
Qed.

(**********)
Lemma rho_lb_pos : forall h : TypeSpeed, (0 < rho_lb h)%R.
intros; unfold rho_lb in |- *; apply Rmult_lt_0_compat;
 [ apply g_pos
 | replace (tan_lb_MaxBank / h)%R with (tan_lb_MaxBank * / h)%R;
    [ rewrite Rmult_comm; generalize TypeSpeed_pos; intro H; generalize (H h);
       clear H; intro H; generalize (Rinv_0_lt_compat h H);
       intro H0; apply Rmult_lt_0_compat;
       [ assumption | apply tan_lb_MaxBank_pos ]
    | auto ] ].
Qed.

(**********)
Lemma rho_pos : forall h : TypeSpeed, (0 < rho h)%R.
intro; apply Rlt_trans with (rho_lb h); [ apply rho_lb_pos | apply rho_lb_0 ].
Qed.

(**********)
Lemma rho_ub_pos : forall h : TypeSpeed, (0 < rho_ub h)%R.
intro; apply Rlt_trans with (rho h); [ apply rho_pos | apply rho_ub_0 ].
Qed.

(**********)
Lemma r_ub_0 : forall h : TypeSpeed, (r h < r_ub h)%R.
intros; unfold r, r_ub in |- *; generalize (rho_lb_0 h); intro H;
 generalize (Rmult_lt_0_compat (rho_lb h) (rho h) (rho_lb_pos h) (rho_pos h));
 intro H0; generalize (Rinv_lt_contravar (rho_lb h) (rho h) H0 H);
 intro H1;
 generalize (Rmult_lt_compat_l h (/ rho h) (/ rho_lb h) (TypeSpeed_pos h) H1);
 intro H2; assumption.
Qed.

(**********)
Lemma r_lb_0 : forall h : TypeSpeed, (r_lb h < r h)%R.
intros; unfold r, r_lb in |- *; generalize (rho_ub_0 h); intro H;
 generalize (Rmult_lt_0_compat (rho h) (rho_ub h) (rho_pos h) (rho_ub_pos h));
 intro H0; generalize (Rinv_lt_contravar (rho h) (rho_ub h) H0 H);
 intro H1;
 generalize (Rmult_lt_compat_l h (/ rho_ub h) (/ rho h) (TypeSpeed_pos h) H1);
 intro H2; assumption.
Qed.

(**********)
Lemma rho_PI2 : forall h : TypeSpeed, (rho h <= PI / 2)%R.
intro h; unfold rho in |- *; unfold Rdiv in |- *.
cut (g < 33)%R.
cut (tan MaxBank < 1)%R.
cut (/ h < / 200)%R.
intros; generalize g_pos; intro H2; generalize tan_MaxBank_pos; intro H3;
 generalize (Rinv_0_lt_compat h (TypeSpeed_pos h));
 intro H4.
generalize
 (Rmult_le_0_lt_compat g 33 (tan MaxBank) 1 (Rlt_le 0 g H2)
    (Rlt_le 0 (tan MaxBank) H3) H1 H0); intro H5;
 generalize (Rmult_lt_0_compat g (tan MaxBank) H2 H3);
 intro H6.
rewrite Rmult_1_r in H5.
generalize
 (Rmult_le_0_lt_compat (g * tan MaxBank) 33 (/ h) (/ 200)
    (Rlt_le 0 (g * tan MaxBank) H6) (Rlt_le 0 (/ h) H4) H5 H).
intro H7; left.
apply Rlt_trans with (33 / 200)%R.
unfold Rdiv in |- *; rewrite <- Rmult_assoc; assumption.
apply Rlt_le_trans with (PI_lb / 2)%R.
apply Rlt_trans with 1%R.
unfold Rdiv in |- *; apply Rmult_lt_reg_l with 200%R.
prove_sup.
rewrite Rmult_1_r; rewrite <- Rmult_comm; rewrite Rmult_assoc;
 rewrite <- Rinv_l_sym; [ prove_sup | discrR ].
apply Rmult_lt_reg_l with 2%R.
prove_sup.
unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
 rewrite <- Rinv_r_sym.
rewrite Rmult_1_r; rewrite Rmult_1_l; unfold PI_lb in |- *.
prove_sup.
discrR.
unfold Rdiv in |- *; left; repeat rewrite <- (Rmult_comm (/ 2));
 apply Rmult_lt_compat_l.
apply Rinv_0_lt_compat; prove_sup.
elim PI_approx; intros; assumption.
apply Rinv_lt_contravar.
apply Rmult_lt_0_compat.
prove_sup.
apply TypeSpeed_pos.
apply Rlt_le_trans with MinSpeed.
unfold MinSpeed in |- *; prove_sup.
apply (v_cond1 h).
apply Rlt_trans with tan_ub_MaxBank.
apply tan_MaxBank_ub.
unfold tan_ub_MaxBank in |- *; unfold Rdiv in |- *;
 apply Rmult_lt_reg_l with 10%R.
prove_sup.
rewrite <- Rmult_comm; rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
 [ prove_sup | discrR ].
unfold g in |- *; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 10%R.
prove_sup.
rewrite <- Rmult_comm; rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
 [ prove_sup | discrR ].
Qed.

(**********)
Lemma rho_strict_decreasing :
 forall h1 h2 : TypeSpeed, (h1 < h2)%R -> (rho h2 < rho h1)%R.
intros; unfold rho in |- *; apply Rmult_lt_compat_l;
 [ apply g_pos
 | unfold Rdiv in |- *; apply Rmult_lt_compat_l;
    [ apply tan_MaxBank_pos
    | apply
       (Rinv_lt_contravar h1 h2
          (Rmult_lt_0_compat h1 h2 (TypeSpeed_pos h1) (TypeSpeed_pos h2)) H) ] ].
Qed.

(**********)
Lemma r_stric_increasing :
 forall h1 h2 : TypeSpeed, (h1 < h2)%R -> (r h1 < r h2)%R.
intros; unfold r in |- *; generalize (rho_strict_decreasing h1 h2 H);
 intro H0;
 generalize
  (Rinv_lt_contravar (rho h2) (rho h1)
     (Rmult_lt_0_compat (rho h2) (rho h1) (rho_pos h2) (rho_pos h1)) H0);
 intro;
 apply
  (Rmult_le_0_lt_compat h1 h2 (/ rho h1) (/ rho h2)
     (Rlt_le 0 h1 (TypeSpeed_pos h1))
     (Rlt_le 0 (/ rho h1) (Rinv_0_lt_compat (rho h1) (rho_pos h1))) H H1).
Qed.


Require Import list.
Require Import In.

Theorem In10 : In 10 [1,2,3,4,5,6,7,8,9,10,11,12].
Proof. repeat (try (left; reflexivity); right). Qed.

Tactic Notation "simpl_and_try" tactic(c) :=
    simpl;
    try c.


Universe X Y Z.
Notation X := Type@{X}.
Notation Y := Type@{Y}.
Notation Z := Type@{Z}.
Axiom a: (fun (x:Type) => x)(X:Y).

Check a.
(* a : X *)

Check a : Y.
(* a : Y
     : Y
(*  |= X <= Y
        *) *)

Check a : X.
(* a : X : X *)

(* This means that the term a is in Types X, Y *)

Inductive W : X -> Z :=.
Inductive F : Y -> Z :=.

Check W a.

Fail Definition b : W a := Z.

Axiom b : (fun (x:Type) => x)((W (a)):Z). Check b.

Check b : W a.

Fail Check b : Z.


Require Import VST.floyd.proofauto.
Require Import fac6.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Require Import VST.floyd.library.
Require Import fac_facts.

Definition M: Z := 1000000000.

Lemma M_eq: M = 1000000000.
Proof. reflexivity. Qed.
Hint Rewrite M_eq : rep_lia.
Opaque M.

Fixpoint digits_eval (al: list Z) (i: Z) : Z :=
  match al with
  | nil => 0
  | a::al' => a*i + digits_eval al' (M*i)
  end.

Definition bignum_rep (sh: share) (L L': Z) (n: Z) (p: val) : mpred :=
  EX al: list Z,
   !! (L <= L' /\
       Forall (fun x => 0 <= x < M) al /\
       Zlength al = L /\
       digits_eval al 1 = n) &&
   data_at sh (tarray tuint L') (map Vint (map Int.repr al) ++ list_repeat (Z.to_nat (L'-L)) Vundef) p.

Lemma bignum_rep_local_facts:
  forall sh L L' n p,
   bignum_rep sh L L' n p |--
   !! (is_pointer_or_null p /\ 0 <= L <= L' /\ 0 <= n < Z.pow M L).
Proof.
intros.
unfold bignum_rep.
Intros al.
subst n L.
entailer!.
clear - H0.
autorewrite with sublist in *.
assert
  (forall i, 0 < i ->
    (i | digits_eval al i) /\
    0 <= digits_eval al i < i*(M^Zlength al)).
2: specialize (H 1); rewrite Z.mul_1_l in H; apply H; lia.
induction al; intros;
simpl.
split.
apply Z.divide_0_r.
lia.
inv H0.
specialize (IHal H4 (M*i)%Z).
spec IHal.
apply Z.mul_pos_pos; lia.
assert (0 <= a*i < M*i). {
  split.
  apply Z.mul_nonneg_nonneg; lia.
  apply Z.mul_lt_mono_pos_r; lia.
}
rewrite Zlength_cons.
rewrite Z.pow_succ_r by rep_lia.
rewrite Z.mul_assoc.
rewrite (Z.mul_comm i M).
destruct IHal.
split.
apply Z.divide_add_r.
apply Z.divide_mul_r.
apply Z.divide_refl.
destruct H1 as [x ?].
exists (x*M)%Z.
rewrite H1.
rewrite Z.mul_assoc.
auto.
split. lia.
forget (digits_eval al (M*i)) as b.
forget (M * i)%Z as m.
assert (0 < M ^ Zlength al).
apply Z.pow_pos_nonneg; rep_lia.
forget (M ^ Zlength al) as c.
forget (a * i)%Z as d.
clear - H1 H2 H0 H5.
destruct H1 as [e ?].
subst b.
destruct H2.
rewrite (Z.mul_comm m c) in *.
apply Zmult_lt_reg_r in H1; try lia.
assert (e + 1 <= c) by lia.
apply Zmult_le_0_reg_r in H; try lia.
assert ((e + 1) * m <= c * m).
apply Z.mul_le_mono_nonneg; try lia.
rewrite Z.mul_add_distr_r, Z.mul_1_l in H3.
lia.
Qed.

Hint Resolve bignum_rep_local_facts : saturate_local.

Lemma bignum_rep_valid_pointer:
  forall sh L L' n p,
   sepalg.nonidentity sh ->
   L' > 0 ->
   bignum_rep sh L L' n p |-- valid_pointer p.
Proof.
 unfold bignum_rep.
 intros; normalize.
 apply data_at_valid_ptr; auto.
 simpl. rewrite Z.max_r by lia.
 lia.
Qed.

Hint Resolve bignum_rep_valid_pointer : valid_pointer.

Definition calc_fac_spec :=
 DECLARE _calc_fac
  WITH sh: share, a: val, L': Z, n: Z
  PRE  [ (tptr tuint), tint, tulong ]
     PROP(writable_share sh; 0 < L' <= Int.max_signed;
              0 <= n < M;
              fac n < M^L')
     PARAMS (a; Vint (Int.repr L'); Vlong (Int64.repr n)) GLOBALS()
     SEP (bignum_rep sh 0 L' 0 a)
  POST [ tint ]
    EX L:Z,
     PROP(0 <= L <= L' /\ fac n < M ^ L)
     LOCAL (temp ret_temp (Vint (Int.repr L)))
     SEP(bignum_rep sh L L' (fac n) a).

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog tt gv
  POST [ tint ]
     PROP()
     LOCAL (temp ret_temp (Vint (Int.repr 0)))
     SEP(TT).

Definition Gprog := [calc_fac_spec].

Lemma digits_eval_nonneg:
  forall al c, 0 < c -> Forall (fun x : Z => 0 <= x < M) al -> 0 <= digits_eval al c.
Proof.
induction al; simpl; intros. lia.
inv H0.
specialize (IHal (M*c)%Z).
spec IHal.
apply Z.mul_pos_pos; lia.
specialize (IHal H4).
assert (0 <= a*c).
apply Z.mul_nonneg_nonneg; lia.
lia.
Qed.

Lemma digits_eval_mult:
 forall al b c, (digits_eval al (b*c) = b * digits_eval al c)%Z.
Proof.
induction al; intros.
simpl. lia.
simpl.
rewrite !IHal.
rewrite Z.mul_add_distr_l.
f_equal.
rewrite Z.mul_comm. rewrite <- Z.mul_assoc. rewrite (Z.mul_comm c); auto.
rewrite !Z.mul_assoc.
rewrite (Z.mul_comm b). auto.
Qed.

Lemma digits_eval_bound:
 forall al,
   Forall (fun x => 0 <= x < M) al ->
   digits_eval al 1 < M ^ Zlength al.
Proof.
intros al Hal.
induction Hal as [ | a al ].
simpl. lia.
unfold digits_eval; fold digits_eval.
rewrite digits_eval_mult.
rewrite Zlength_cons.
rewrite Z.pow_succ_r by rep_lia.
rewrite Z.mul_1_r.
pose proof (digits_eval_nonneg al 1).
spec H0; [lia|].
specialize (H0 Hal).
clear Hal.
forget (digits_eval al 1) as e.
forget (M ^ Zlength al) as N.
assert (0 <= e < N) by auto.
clear - H H1.
replace N with (1 + (N-1)) by lia.
rewrite Z.mul_add_distr_l.
apply Z.add_lt_le_mono.
lia.
apply Z.mul_le_mono_nonneg_l.
lia.
lia.
Qed.

Lemma digits_eval_app:
   forall al bl b,
   digits_eval (al++bl) b = digits_eval al b + digits_eval bl ((M ^ Zlength al)*b).
Proof.
 induction al; simpl; intros.
  rewrite Z.mul_1_l, Z.add_0_l; auto.
  rewrite IHal.
  rewrite Zlength_cons. rewrite Z.pow_succ_r by rep_lia.
  rewrite Z.add_assoc. f_equal. f_equal.
  rewrite Z.mul_comm. rewrite <- !Z.mul_assoc.
  f_equal. apply Z.mul_comm.
Qed.

Lemma divu64_repr: forall i j,
   0 <= i <= Int64.max_unsigned ->
   0 <= j <= Int64.max_unsigned ->
   Int64.divu (Int64.repr i) (Int64.repr j) = Int64.repr (i / j).
Proof.
intros.
unfold Int64.divu.
normalize.
Qed.
Hint Rewrite divu64_repr using rep_lia : norm.

Lemma typed_false_tulong_e:
  forall v, typed_false tulong v -> v = Vlong Int64.zero.
Proof.
clear; intros.
destruct v; inv H.
pose proof (Int64.eq_spec i Int64.zero).
destruct (Int64.eq i Int64.zero); inv H1; auto.
Qed.

Lemma repr64_inj_signed:
  forall i j,
    Int64.min_signed <= i <= Int64.max_signed ->
    Int64.min_signed <= j <= Int64.max_signed ->
    Int64.repr i = Int64.repr j -> i=j.
Proof.
intros.
rewrite <- (Int64.signed_repr i) by rep_lia.
rewrite <- (Int64.signed_repr j) by rep_lia.
congruence.
Qed.

Lemma repr64_inj_unsigned:
  forall i j,
    0 <= i <= Int64.max_unsigned ->
    0 <= j <= Int64.max_unsigned ->
    Int64.repr i = Int64.repr j -> i=j.
Proof.
intros.
rewrite <- (Int64.unsigned_repr i) by rep_lia.
rewrite <- (Int64.unsigned_repr j) by rep_lia.
congruence.
Qed.

Lemma body_calc_fac: semax_body Vprog Gprog f_calc_fac calc_fac_spec.
Proof.
start_function.
rename H1 into HL'.
unfold bignum_rep.
Intros al.
forward.
forward_for_simple_bound L'
   (EX i:Z,
      PROP ()
      LOCAL (temp _a a; temp _L (Vint (Int.repr L')); temp _n (Vlong (Int64.repr n)))
      SEP (data_at sh (tarray tuint L')
               (map Vint (map Int.repr (1 :: list_repeat (Z.to_nat (i-1)) 0)) ++
                list_repeat (Z.to_nat (L'-i)) Vundef) a)).
  {entailer!.
   destruct al.
   2: elimtype False; clear - H3; rewrite Zlength_cons in H3; rep_lia.
   simpl.
   replace L' with (1 + (L'-1)) at 2 by lia.
   rewrite <- list_repeat_app' by lia.
   simpl list_repeat.
   autorewrite with sublist.
   rewrite upd_Znth0.
   autorewrite with sublist.
   simpl.  cancel.
  }
  forward. {
   entailer!.
   replace (L'-i) with (1 + (L'-i-1)) by lia.
   rewrite <- list_repeat_app' by lia.
   autorewrite with sublist.
   simpl list_repeat.
   replace (i - Z.succ (i-1)) with 0 by lia.
   rewrite upd_Znth0.
   autorewrite with sublist.
   rewrite <- app_comm_cons.
   rewrite <- app_ass.
   change ([Vint (Int.repr 0)]) with (list_repeat (Z.to_nat 1) (Vint (Int.repr 0))).
   rewrite list_repeat_app' by lia.
   replace (L' - (i+1)) with (L' - i - 1) by lia.
   replace (i - 1 + 1) with i by lia.
   cancel.
   }
  forward.
  autorewrite with sublist.
  rename n into n0.
  clear al H3 H4 H2.
  forward_while
    (EX al:list Z, EX n:Z,
   PROP (0 <= n <= n0; (digits_eval al 1 * fac n = fac n0)%Z;
            Forall (fun x => 0 <= x < M) al;
            Zlength al <= L')
   LOCAL (temp _l (Vint (Int.repr (Zlength al)));
   temp _a a; temp _L (Vint (Int.repr L')); temp _n (Vlong (Int64.repr n)))
   SEP (data_at sh (tarray tuint L')
          (map Vint (map Int.repr (al ++ list_repeat (Z.to_nat (L'-Zlength al)) 0))) a)).
-
  Exists [1] n0.
  entailer!. split. repeat constructor; computable. change (Zlength [1]) with 1. lia.
-
   entailer!.
-
  rename H4 into Hal. rename H5 into Hal'.
  forward.
  forward.
  assert (0 < n <= n0). { clear - H2 HRE. destruct (zeq n 0); try lia. subst. inv HRE. }
  clear HRE H2 H1.
  set (alx := al ++  list_repeat (Z.to_nat (L' - Zlength al)) 0).
  assert (digits_eval al 1 = digits_eval alx 1). {
     subst alx.
     clear.
     forget 1 as c.
     forget (Z.to_nat (L' - Zlength al)) as n.
     rewrite digits_eval_app. forget (M ^ Zlength al * c)%Z as d.
     replace (digits_eval (list_repeat n 0) d) with 0%Z; [lia|].
     revert d; induction n; simpl; intros; auto.  rewrite <- IHn. lia.
  }
  rewrite H1 in H3.
  assert_PROP (Zlength alx = L')
    by (entailer!;   autorewrite with sublist in H5; auto).
  assert (Forall (eq 0) (sublist (Zlength al) (Zlength alx) alx)). {
   subst alx.
   clear. autorewrite with sublist. apply Forall_list_repeat. auto.
  }
  assert (0 <= Zlength al <= L'). {
     split. rep_lia.
     clear - H2.
     subst alx.
     destruct (zlt L' (Zlength al)); [ | lia].
     rewrite Z_to_nat_neg in H2 by lia. autorewrite with sublist in H2. lia.
  }
  forget (Zlength al) as L.
  assert (Halx: Forall (fun x : Z => 0 <= x < M) alx). {
    subst alx. apply Forall_app. split. auto. apply Forall_list_repeat. rep_lia.
 }
  clearbody alx; clear al H1 Hal. rename alx into al. rename Halx into Hal. subst L'.
  forward_loop (EX al': list Z, EX c:Z, EX L:Z,
   PROP (((digits_eval al' 1 + c * (M ^ Zlength al') +
             n * digits_eval (sublist (Zlength al') (Zlength al) al) (M ^ Zlength al')) =
             n * digits_eval al 1)%Z;
            (digits_eval al 1 * fac n)%Z = fac n0;
            Zlength al' <= Zlength al;
            0 <= L <= Zlength al;
            Forall (eq 0) (sublist L (Zlength al) al);
            0 <= c < M;
            Forall (fun x : Z => 0 <= x < M) al')
   LOCAL (temp _i (Vint (Int.repr (Zlength al')));
   temp _c (Vlong (Int64.repr c));
   temp _l (Vint (Int.repr L)); temp _a a;
   temp _L (Vint (Int.repr (Zlength al))); temp _n (Vlong (Int64.repr n)))
   SEP (data_at sh (tarray tuint (Zlength al))
          (map Vint (
             (map Int.repr (al' ++ sublist (Zlength al') (Zlength al) al)))) a))
  break: (EX al': list Z, EX c:Z, EX L:Z,
   PROP (((digits_eval al' 1 + c * (M ^ Zlength al') +
             n * digits_eval (sublist (Zlength al') (Zlength al) al) (M ^ Zlength al')) =
             n * digits_eval al 1)%Z;
            (digits_eval al 1 * fac n)%Z = fac n0;
            Zlength al' <= Zlength al;
            0 <= L <= Zlength al;
            Zlength al' >= L;
            Forall (fun x : Z => 0 <= x < M) al';
            c = 0;
            Forall (eq 0) (sublist L (Zlength al) al))
   LOCAL (temp _i (Vint (Int.repr (Zlength al')));
   temp _c (Vlong (Int64.repr c));
   temp _l (Vint (Int.repr L)); temp _a a;
   temp _L (Vint (Int.repr (Zlength al))); temp _n (Vlong (Int64.repr n)))
   SEP (data_at sh (tarray tuint (Zlength al))
          (map Vint (
             (map Int.repr (al' ++ sublist (Zlength al') (Zlength al) al)))) a)).
 +
   Exists (@nil Z) 0 L.
   entailer!.
   split.
   autorewrite with sublist. rewrite Z.pow_0_r. auto.
   list_solve.
   autorewrite with sublist. auto.
 +
   clear L H6 H5 Hal'.
   Intros al' c L. rename H8 into Hal'.
   forward_if (temp _t'1 (Vint (Int.repr
                               (if zlt (Zlength al') L then 1
                                    else if (zeq c 0) then 0 else 1)))).
   {forward. entailer!. rewrite if_true; auto.
   }
   {forward. entailer!. rewrite if_false by auto. if_tac. subst. reflexivity.
     rewrite Int64.eq_false; auto.
     clear - H12 H7. contradict H12.
     rewrite <- (Int64.unsigned_repr c) by rep_lia. rewrite H12; reflexivity.
   }
   forward_if (Zlength al' < L \/ 0<c).
    {forward. entailer!. if_tac in H8'; auto. if_tac in H8; subst; auto. contradiction. right; lia.
    }
    {forward.
     Exists al' c L. entailer!.
     if_tac in H8. inv H8. if_tac in H8; [ | inv H8]. split; auto.
    }
    drop_LOCALs [_t'1].
    Intros.
    assert (Zlength al' < Zlength al). {
       destruct H8. lia.
       destruct (zeq (Zlength al') (Zlength al)); [ | lia].
       rewrite e in H1. autorewrite with sublist in H1.
       simpl in H1.
       elimtype False.
       rewrite Z.mul_0_r, Z.add_0_r in H1.
       rewrite <- H3 in HL'.
       assert (0 < c < M) by lia.
       clear - HL' H4 H1 H5 H6 e H9 Hal'.
       rewrite fac_equation in HL'. rewrite if_true in HL' by lia.
       rewrite Z.mul_assoc in HL'. rewrite (Z.mul_comm n) in H1; rewrite <- H1 in HL'.
       clear - HL' H4 Hal' H9.
       pose proof (digits_eval_nonneg al' 1).
       spec H; [lia|].
       specialize (H Hal').
       pose proof (fac_mono 0 (n-1)). spec H0;[lia|].
       change (fac 0) with 1 in H0.
       forget (digits_eval al' 1) as e. forget (fac (n-1)) as f.
       assert (0 < M ^ Zlength al).
       apply Z.pow_pos_nonneg; rep_lia.
       forget (M ^ Zlength al) as d.
       destruct H9 as [? _].
       clear - HL' H2 H H0 H1.
       rewrite Z.mul_add_distr_r in HL'.
      assert (0 <= e*f).
      apply Z.mul_nonneg_nonneg; lia.
      assert (c * d * f < d); try lia.
      clear dependent e.
      rewrite Z.mul_comm in H4.
      rewrite Z.mul_assoc in H4.
      assert (1 <= f*c). change 1 with (1*1)%Z.
      apply Z.mul_le_mono_nonneg; lia.
      revert H4.
      assert (f*c*d >= 1*d); [|rewrite Z.mul_1_l in *; auto].
      apply Zmult_ge_compat_r; lia.
 }
 forward.
 entailer!.
 forward.
 drop_LOCALs [_t'2].
 forward.
 forward.
 entailer!.
 forward.
 rewrite <- M_eq in *.
 normalize.
 rewrite Int.unsigned_repr.
2:{ autorewrite with sublist.
    clear - H6 Hal H9.
    pattern (Znth (Zlength al') al).
    apply Forall_Znth; try rep_lia.
    eapply Forall_impl; try eassumption.
    intros. simpl in H. rep_lia.
}
 rewrite app_Znth2 by lia. rewrite Z.sub_diag.
 autorewrite with sublist.
 rewrite !map_app.
 rewrite upd_Znth_app2 by (autorewrite with sublist; lia).
 assert (0 <= Znth (Zlength al') al < M). {
   pattern ( Znth (Zlength al') al). apply Forall_Znth; try rep_lia. auto.
 }
 assert (0 <= n * Znth (Zlength al') al + c < M*M). {
  clear - H10 H7 H4 H0.
  assert (0 <= n * Znth (Zlength al') al).
  apply Z.mul_nonneg_nonneg; lia.
  split. lia.
  change (M*M)%Z with ((M-1)*M + M)%Z.
  assert (n * Znth (Zlength al') al <= (M-1)*M); [ | lia].
  apply Z.mul_le_mono_nonneg; rep_lia.
 }
 autorewrite with sublist norm.
 rewrite <- Zmod_eq by lia.
 rewrite Int64.unsigned_repr.
2:{ pose proof (Z.mod_pos_bound(n * Znth (Zlength al') al + c) M).
    spec H12; [rep_lia|]. rep_lia.
 }
 rewrite !upd_Znth_map.
 Exists (al' ++ [(n * Znth (Zlength al') al + c) mod M]).
 Exists ((n * Znth (Zlength al') al + c) / M).
 Exists L.
 entailer!.
 split3; [ | | split3]; autorewrite with sublist; auto; try lia.
 *
  change (Z.succ 0) with 1.
  clear - H11 H10 H9 H8 Hal' H7 H6 H5 H2 H1 Hal H4 H3 H0 H.
  rewrite <- H1; clear H1.
  rewrite (sublist_split (Zlength al') (Zlength al' + 1) (Zlength al)) by rep_lia.
  rewrite (sublist_len_1 (Zlength al')) by rep_lia.
  simpl.
  rewrite Z.mul_add_distr_l.
  rewrite !Z.add_assoc.
  rewrite <- Z.pow_succ_r by rep_lia. unfold Z.succ.
  f_equal.
  rewrite digits_eval_app.
  rewrite <- !Z.add_assoc. f_equal.
  simpl. rewrite Z.add_0_r. rewrite Z.mul_1_r.
  set (d := Znth (Zlength al') al).
  rewrite Zmod_eq by rep_lia.
  rewrite Z.mul_sub_distr_r.
  fold (Z.succ (Zlength al')).
  rewrite Z.pow_succ_r by rep_lia.
  rewrite Z.mul_assoc.
  rewrite Z.sub_add.
  rewrite Z.mul_add_distr_r.
  rewrite Z.mul_assoc. lia.
 *
  clear - H11.
  split. apply Z.div_pos; rep_lia.
  forget (n * Znth (Zlength al') al + c) as d.
  apply Z.div_lt_upper_bound; try rep_lia.
 *
  apply Forall_app; split; auto. constructor; [ | constructor].
  pose proof (Z.mod_pos_bound(n * Znth (Zlength al') al + c) M).
  spec H15; [rep_lia|]. rep_lia.
 *
  rewrite <- !map_app. apply derives_refl'. f_equal. f_equal. f_equal.
  rewrite app_ass. f_equal.
  autorewrite with sublist.
  rewrite (sublist_split (Zlength al') (Zlength al' + 1) (Zlength al)) by rep_lia.
  autorewrite with sublist. f_equal.
  rewrite sublist_len_1 by rep_lia.   rewrite upd_Znth0.
   autorewrite with sublist. auto.
+
 Intros al' c L0.
 forward_if (temp _l (Vint (Int.repr (Z.max  (Zlength al') L0)))).
 forward.
 entailer!. rewrite Z.max_l by lia. auto.
 forward.
 entailer!. rewrite Z.max_r by lia. auto.
 forward.
 subst c.
 autorewrite with norm.
 rewrite Z.mul_0_l, Z.add_0_r in H1.
 Exists (al' ++ sublist (Zlength al') (Z.max (Zlength al') L0) al, n-1).
 simpl fst. simpl snd. autorewrite with sublist.
 entailer!.
 *
 rewrite (fac_equation n) in H3.
 rewrite if_true in H3 by lia.
 rewrite Z.mul_assoc in H3.
 rewrite <- (Z.mul_comm n) in H3.
 rewrite <- H3. clear H3.
 f_equal.
 rewrite <- H1. clear H1.
 rewrite (sublist_split L0 (Zlength al')) in H11 by rep_lia.
 apply Forall_app in H11. destruct H11 as [_ H11].
 clear - H11 H2.
 forget (sublist (Zlength al') (Zlength al) al) as dl.
 forget (M ^ Zlength al') as N.
 replace (digits_eval dl N) with 0. lia.
 clear - H11. revert N; induction H11; intros; simpl. auto.
 rewrite <- IHForall. subst. lia.
 *
 replace (list_repeat (Z.to_nat (Zlength al - Zlength al')) 0)
   with (sublist (Zlength al') (Zlength al) al); auto.
 clear - H8 H11 H7 H2.
 forget (Zlength al') as i.
 rewrite (sublist_split L0 i) in H11 by rep_lia.
 apply Forall_app in H11. destruct H11 as [_ ?].
 assert (0 <= i <= Zlength al) by lia.
 clear - H H0.
 assert (Zlength (sublist i (Zlength al) al) = Zlength al - i).
  autorewrite with sublist. auto.
 rewrite <- H1.
 clear - H.
 forget (sublist i (Zlength al) al) as bl.
 induction H; intros. simpl; auto. rewrite Zlength_cons.
 unfold Z.succ. rewrite Z.add_comm.
 rewrite <- list_repeat_app' by rep_lia.
 simpl. f_equal; auto.
-
 assert (n=0). {clear - H2 HRE H0.
apply typed_false_tulong_e in HRE.
assert (Int64.repr n = Int64.zero) by congruence.
apply repr64_inj_unsigned in H; rep_lia.
}
  subst n.
  change (fac 0) with 1 in H3. rewrite Z.mul_1_r in H3.
  clear HRE H1.
  forward.
  Exists (Zlength al).
  unfold bignum_rep. Exists al.
  autorewrite with sublist in H5.
  entailer!.
  rewrite <- H3.
 apply digits_eval_bound; auto.
 rewrite !map_app.
 autorewrite with sublist.
 rewrite !(split2_data_at_Tarray_app (Zlength al) L') by list_solve.
 cancel.
Qed.


From RecordUpdate Require Import RecordUpdate Lens.

Record X := mkX { A: nat; B: nat; C: bool; }.
Instance etaX : Settable _ := settable! mkX <A; B; C>.

(* lenses require much more boilerplate than setters (if you want them to look
like Haskell lenses) *)
Definition _A := field_lens A.
Definition _B := field_lens B.
Definition _C := field_lens C.

Definition set_A_to_3 (x:X) := over _A (fun _ => 3) x.