(** * Expressions.v : pWHILE Expressions *)

Set Implicit Arguments.

Require Export Operators.
Require Export Memory.

(* TODO: Move to ALEA *)

(** *** Distribution for [randomZ a b]
The distribution associated to [randomZ a b] is
 $f \mapsto \Sigma_{i=a}^b \frac{f(i)}{b-a+1}$
We cannot factorize $\frac{1}{b-a+1}$ because of possible overflow
*)

Definition randomZ (a b:Z) : M Z.
intros a b.
exists (fun f:Z -> U => sigma (fun k =>
 Unth (Zabs_nat (b - a)) * f (a + Z_of_nat k)%Z) (S (Zabs_nat (b - a)))).
red; intros; auto.
Defined.

Lemma randomZ_simpl : forall a b (f:Z -> U),
randomZ a b f =
sigma (fun k =>
 Unth (Zabs_nat (b - a)) * f (a + Z_of_nat k)%Z) (S (Zabs_nat (b - a))).
trivial.
Save.

(** *** Properties of [randomZ] *)

Lemma randomZ_stable_inv : forall a b, stable_inv (randomZ a b).
unfold randomZ, stable_inv, finv; intros; simpl.
rewrite
 (sigma_inv (fun k => f (a + Z_of_nat k)%Z) (fnth_retract (Zabs_nat (b - a))));
auto.
Save.

Lemma randomZ_stable_plus : forall a b, stable_plus (randomZ a b).
unfold stable_plus, fplus; intros.
repeat (rewrite randomZ_simpl).
unfold fplusok, finv in H.
set (n:=Zabs_nat (b - a)).
set (F:=fun k => f (a + Z_of_nat k)%Z).
set (G:=fun k => g (a + Z_of_nat k)%Z).
apply Oeq_trans with
 (sigma (fun k => ([1/]1+n * F k) + ([1/]1+n  * G k)) (S (Zabs_nat (b - a)))).
apply sigma_eq_compat; intros.
assert (F k <= [1-] (G k)); unfold F, G; auto.
apply sigma_plus with (f:=fun k : nat => Unth n * F k)
                      (g:=fun k : nat => Unth n * G k); auto.
Save.

Lemma randomZ_stable_mult : forall a b, stable_mult (randomZ a b).
unfold stable_mult, fmult; intros; repeat (rewrite randomZ_simpl).
set (n:=Zabs_nat (b - a)).
set (F:=fun k => f (a + Z_of_nat k)%Z).
apply Oeq_trans with
 (sigma (fun l : nat => k * ([1/]1+n * F l)) (S n)).
apply sigma_eq_compat; intros; auto.
apply sigma_mult with (f:=fun k : nat => Unth n * F k).
red; intros.
apply Ole_trans with ([1/]1+n); auto.
apply Ole_trans with ([1-] (sigma (fun k1 => Unth n) k0)); auto.
apply (fnth_retract n k0); auto.
Save.

Lemma randomZ_continuous : forall a b, continuous (randomZ a b).
unfold continuous; intros; rewrite randomZ_simpl.
set (n:=Zabs_nat (b - a)).
apply Ole_trans with
 (sigma (fun k => lub (UMult ([1/]1+n) @ (h <o> (a + Z_of_nat k)%Z))) (S n)).
apply sigma_le_compat; intros; simpl.
rewrite (lub_eq_mult ([1/]1+n) (h <o> (a + Z_of_nat k)%Z)); auto.
apply Ole_trans with
(sigma (lub (c:=nat-O->U)
 (ford_shift (fun k => (UMult ([1/]1+n) @ (h <o> (a + Z_of_nat k)%Z))))) (S n));
auto.
rewrite sigma_lub1; auto.
Save.

Definition RandomZ (a b:Z) : Distr Z.
intros a b; exists (randomZ a b).
apply randomZ_stable_inv.
apply randomZ_stable_plus.
apply randomZ_stable_mult.
apply randomZ_continuous.
Defined.

Lemma RandomZ_simpl : forall (a b:Z), mu (RandomZ a b) = randomZ a b.
trivial.
Save.

Lemma RandomZ_total : forall a b:Z, mu (RandomZ a b) (fone Z) == 1.
intros; simpl mu;unfold fone; rewrite randomZ_simpl.
apply Oeq_trans with  (sigma (fnth (Zabs_nat (b - a))) (S (Zabs_nat (b - a)))).
apply sigma_eq_compat.
intros; repeat Usimpl; auto.
auto.
Save.
Hint Resolve RandomZ_total.

Lemma RandomZ_inv : forall f a b,
 mu (RandomZ a b) (finv f) == [1-] (mu (RandomZ a b) f).
intros; apply mu_one_inv; auto.
Save.
Hint Resolve RandomZ_inv.

Module Type EXPR (UT:UTYPE) (T:TYPE UT) (Var:VAR UT T) (Mem:MEM UT T Var)
 (Uop:UOP UT T) (O:OP UT T Uop).

 (* Constants *)
 Inductive cexpr : T.type -> Type :=
 | Cbool :> bool -> cexpr T.Bool
 | Cnat :> nat -> cexpr T.Nat
 | CZ :> Z -> cexpr T.Zt
 | Cnil : forall t, cexpr (T.List t)
 | Cnone : forall t, cexpr (T.Option t).

 (* Expressions *)
 Inductive expr : T.type -> Type :=
 | Ecte :> forall t, cexpr t -> expr t
 | Evar :> forall t, Var.var t -> expr t
 | Eop : forall op, dlist expr (O.targs op) -> expr (O.tres op)
 | Eexists : forall t, Var.var t -> expr T.Bool -> expr (T.List t) -> expr T.Bool
 | Eforall : forall t, Var.var t -> expr T.Bool -> expr (T.List t) -> expr T.Bool
 | Efind : forall t, Var.var t -> expr T.Bool -> expr (T.List t) -> expr t.

 Definition args := dlist expr.

 (* Induction principles *)
 Parameter expr_ind2 : forall (P : forall t, expr t -> Prop)
  (Pl : forall l, args l -> Prop),
  (forall t (c:cexpr t), P _ c) ->
  (forall t (v:Var.var t), P _ v) ->
  (forall op args, Pl (O.targs op) args -> P _ (Eop op args)) ->
  (forall t (v:Var.var t) e1 e2, P _ e1 -> P _ e2 -> P _ (Eexists v e1 e2)) ->
  (forall t (v:Var.var t) e1 e2, P _ e1 -> P _ e2 -> P _ (Eforall v e1 e2)) ->
  (forall t (v:Var.var t) e1 e2, P _ e1 -> P _ e2 -> P _ (Efind v e1 e2)) ->
  (Pl nil (dnil expr)) ->
  (forall t l e le, P t e -> Pl l le -> Pl (t::l) (dcons t e le)) ->
  forall t e, P t e.

 Parameter expr_ind_and :  forall (P : forall t, expr t -> Prop)
  (Pl : forall l, args l -> Prop),
  (forall t (c:cexpr t), P _ c) ->
  (forall t (v:Var.var t), P _ v) ->
  (forall op args, Pl (O.targs op) args -> P _ (Eop op args)) ->
  (forall t (v:Var.var t) e1 e2, P _ e1 -> P _ e2 -> P _ (Eexists v e1 e2)) ->
  (forall t (v:Var.var t) e1 e2, P _ e1 -> P _ e2 -> P _ (Eforall v e1 e2)) ->
  (forall t (v:Var.var t) e1 e2, P _ e1 -> P _ e2 -> P _ (Efind v e1 e2)) ->
  (Pl nil (dnil expr)) ->
  (forall t l e le, P t e -> Pl l le -> Pl (t::l) (dcons t e le)) ->
  (forall t e, P t e) /\ (forall lt args, Pl lt args).

 Parameter ceqb : forall t1 t2, cexpr t1 -> cexpr t2 -> bool.

 Parameter ceqb_spec_dep : forall t1 (e1 : cexpr t1) t2 (e2:cexpr t2),
  if ceqb e1 e2 then eq_dep T.type cexpr t1 e1 t2 e2
  else ~eq_dep T.type cexpr t1 e1 t2 e2.

 Parameter ceqb_spec : forall t (e1 e2:cexpr t),
  if ceqb e1 e2 then e1 = e2 else e1 <> e2.

 Parameter eqb : forall t1 t2, expr t1 -> expr t2 -> bool.

 Parameter eqb_spec_dep : forall t1 (e1 : expr t1) t2 (e2:expr t2),
  if eqb e1 e2 then eq_dep T.type expr t1 e1 t2 e2
  else ~eq_dep T.type expr t1 e1 t2 e2.

 Parameter eqb_spec : forall t (e1 e2:expr t),
  if eqb e1 e2 then e1 = e2 else e1 <> e2.

 Parameter args_eqb : forall l1 l2,  args l1 -> args l2 -> bool.

 Parameter args_eqb_spec_dep : forall l1 (a1 : args l1) l2 (a2:args l2),
  if args_eqb a1 a2 then eq_dep (list T.type) args l1 a1 l2 a2
  else ~eq_dep (list T.type) args l1 a1 l2 a2.

 Parameter args_eqb_spec : forall l (a1 a2:args l),
  if args_eqb a1 a2 then a1 = a2 else a1 <> a2.

 (* Dependant Equality *)
 Parameter eq_dep_eq : forall t (P:expr t->Type) (p:expr t) (x y:P p),
  eq_dep (expr t) P p x p y -> x = y.

 Parameter UIP_refl : forall t (x:expr t) (p:x = x), p = refl_equal x.

 Parameter inj_pair2 : forall t (P:expr t -> Type) (p:expr t) (x y:P p),
  existT P p x = existT P p y -> x = y.

 Section EVAL.

  Variable k : nat.

  Definition eval_cexpr t (c:cexpr t) : T.interp k t :=
   match c in (cexpr t0) return T.interp k t0 with
   | Cbool b => b
   | Cnat n => n
   | CZ n => n
   | Cnil t => @nil (T.interp k t)
   | Cnone t => @None (T.interp k t)
   end.

  Definition ceval_cexpr t (c:cexpr t) : T.interp k t * nat :=
   match c in (cexpr t0) return T.interp k t0 * nat with
   | Cbool b => (b, S O)
   | Cnat n => (n, size_nat n)
   | CZ n => (n, size_Z n)
   | Cnil t => (@nil (T.interp k t), S O)
   | Cnone t => (@None (T.interp k t), S O)
   end.

  Fixpoint eval_expr (t:T.type) (e:expr t) (m:Mem.t k) : T.interp k t :=
   match e in expr t0 return T.interp k t0 with
   | Ecte t c => eval_cexpr c
   | Evar t v => m v
   | Eop op la =>
     O.eval_op op (dmap (T.interp k) (fun t (e:expr t) => eval_expr e m) la)
   | Eexists t x e1 e2 =>
     List.existsb
     (fun v => eval_expr e1 (Mem.upd m x v))
     (eval_expr e2 m)
   | Eforall t x e1 e2 =>
     List.forallb
     (fun v => eval_expr e1 (Mem.upd m x v))
     (eval_expr e2 m)
   | Efind t x e1 e2 =>
     find_default
     (fun v => eval_expr e1 (Mem.upd m x v))
     (eval_expr e2 m) (T.default k t)
   end.

  Fixpoint ceval_expr (t:T.type) (e:expr t) (m:Mem.t k) : T.interp k t * nat :=
   match e in expr t0 return T.interp k t0 * nat with
   | Ecte t c => ceval_cexpr c
   | Evar t v => (m v, S O)
   | Eop op la =>
     let ca := dfold_right (fun t (e:expr t) c => snd (ceval_expr e m) + c)%nat 0%nat la in
     let (r, c) := O.ceval_op op (dmap (T.interp k) (fun t (e:expr t) => eval_expr e m) la) in
     (r, c + ca)%nat
   | Eexists t x e1 e2 =>
     let (l, n) := ceval_expr e2 m in
      cexistsb
      (fun v => ceval_expr e1 (Mem.upd m x v))
      l n
   | Eforall t x e1 e2 =>
     let (l, n) := ceval_expr e2 m in
      cforallb
      (fun v => ceval_expr e1 (Mem.upd m x v))
      l n
   | Efind t x e1 e2 =>
     let (l, n) := ceval_expr e2 m in
      cfind_default
      (fun v => ceval_expr e1 (Mem.upd m x v))
      l n (T.default k t)
   end.

  Parameter ceval_expr_spec : forall t (e:expr t) m,
   eval_expr e m = fst (ceval_expr e m).

  Definition eval_args lt (a:args lt) (m:Mem.t k) :=
   dmap (T.interp k) (fun t (e:expr t) => eval_expr e m) a.

  Definition ceval_args lt (a:args lt) (m:Mem.t k) :=
   dmap (fun x => T.interp k x * nat)%type (fun t (e:expr t) => ceval_expr e m) a.

 End EVAL.

 (* Useful functions *)
 Fixpoint tapp_expr (lt:list T.type) (tr:T.type) : Type:=
  match lt with
  | nil => expr tr
  | cons t lt => expr t -> tapp_expr lt tr
  end.

 Fixpoint app_expr (lt:list T.type) (tr:T.type)
  (args:args lt) : tapp_expr lt tr -> expr tr :=
  match args in dlist _ lt0 return tapp_expr lt0 tr -> expr tr with
  | dnil => fun e => e
  | dcons t lt e l => fun op => app_expr tr l (op e)
  end.

 Definition get_uop t (e:expr t) : option (sigT (fun op => args (Uop.targs op))) :=
  match e with
  | Eop op a =>
    match op as op0
    return args (O.targs op0) -> option (sigT (fun op => args (Uop.targs op))) with
    | O.Ouser uop => fun args => Some (existT _ uop args)
    | _ => fun _ => None
    end a
  | _ => None
  end.

 Parameter get_uop_spec : forall t (e:expr t) op args,
  get_uop e = Some (existT _ op args) ->
  eq_dep T.type expr _ e _ (Eop (O.Ouser op) args).

End EXPR.

(** * User-defined random sampling *)
Module Type USUPPORT (UT:UTYPE) (T:TYPE UT) (Var:VAR UT T) (Mem:MEM UT T Var)
 (Uop:UOP UT T) (O:OP UT T Uop) (E:EXPR UT T Var Mem Uop O).

 Module VarP := MkEqBool_Leibniz_Theory Var.
 Module Vset := MkListSet VarP.Edec.

 Parameter usupport : T.type -> Type.

 Parameter eval : forall k t, usupport t -> Mem.t k -> Distr (T.interp k t).

 Parameter ceval : forall k t, usupport t -> Mem.t k -> Distr (T.interp k t) * nat.

 Parameter ceval_spec : forall k t (s:usupport t) (m:Mem.t k),
  eval s m = fst (ceval s m).

 Parameter fv_distr : forall t (s:usupport t), Vset.t.

 Let req_mem k X (m1 m2:Mem.t k) :=
  forall t (x:Var.var t), Vset.mem x X -> m1 x = m2 x.

 Let depend_only_distr (X:Vset.t) t (s:usupport t) :=
  forall k (m1 m2:Mem.t k),
   req_mem X m1 m2 -> eval s m1 = eval s m2.

 Parameter depend_only_fv_distr : forall t (s:usupport t),
  depend_only_distr (fv_distr s) s.

 Parameter lossless_support : forall k t (s:usupport t) (m:Mem.t k),
  mu (eval s m) (fun _ => 1) == 1.

 Parameter discrete_support : forall k t (s:usupport t) (m:Mem.t k),
  is_Discrete (eval s m).

 Parameter eqb : forall t1 t2, usupport t1 -> usupport t2 -> bool.

 Parameter eqb_spec_dep :  forall t1 (e1 : usupport t1) t2 (e2:usupport t2),
  if eqb e1 e2 then eq_dep T.type usupport t1 e1 t2 e2
  else ~eq_dep T.type usupport t1 e1 t2 e2.

 Parameter eqb_spec : forall t (e1 e2:usupport t),
  if eqb e1 e2 then e1 = e2 else e1 <> e2.

End USUPPORT.

Module Type DEXPR (UT:UTYPE) (T:TYPE UT) (Var:VAR UT T) (Mem:MEM UT T Var)
 (Uop:UOP UT T) (O:OP UT T Uop)
 (E:EXPR UT T Var Mem Uop O) (US:USUPPORT UT T Var Mem Uop O E).

 Inductive support : T.type -> Type :=
 | Dbool : support T.Bool
 | Dnat : E.expr T.Nat -> support T.Nat
 | DZ : E.expr T.Zt -> E.expr T.Zt -> support T.Zt
 | Duser : forall t, US.usupport t -> support t
 | Dprod : forall t1 t2, support t1 -> support t2 -> support (T.Pair t1 t2).

 Fixpoint eval_support k t (s:support t) (m:Mem.t k) : Distr (T.interp k t) :=
  match s in support t0 return Distr (T.interp k t0) with
  | Dbool => Flip
  | Dnat e => Random (E.eval_expr e m)
  | DZ e1 e2 => RandomZ (E.eval_expr e1 m) (E.eval_expr e2 m)
  | Duser t s => US.eval s m
  | Dprod t1 t2 s1 s2 => prod_distr (eval_support s1 m) (eval_support s2 m)
  end.

 Fixpoint ceval_support k t (s:support t) (m:Mem.t k) :
  Distr (T.interp k t) * nat :=
  match s in support t0 return Distr (T.interp k t0) * nat with
  | Dbool => (Flip, S 0)
  | Dnat e => let (n, m) := E.ceval_expr e m in (Random n, m)
  | DZ e1 e2 =>
    let (a, n1) := E.ceval_expr e1 m in
    let (b, n2) := E.ceval_expr e2 m in
     (RandomZ a b, plus n1 n2)
  | Duser t s => US.ceval s m
  | Dprod t1 t2 s1 s2 =>
    let (n1, m1) := ceval_support s1 m in
    let (n2, m2) := ceval_support s2 m in
     (prod_distr n1 n2, mult m1 m2)
  end.

 Parameter ceval_support_spec : forall k t (s:support t) m,
  eval_support (k:=k) s m = fst (ceval_support (k:=k) s m).

 Parameter lossless_support : forall k t (s:support t) (m:Mem.t k),
  mu (eval_support s m) (fun _ => 1) == 1.

 Parameter discrete_support : forall k t (s:support t) (m:Mem.t k),
  is_Discrete (eval_support s m).

 Parameter seqb : forall t1 t2, support t1 -> support t2 -> bool.

 Parameter seqb_spec_dep :  forall t1 (e1 : support t1) t2 (e2:support t2),
  if seqb e1 e2 then eq_dep T.type support t1 e1 t2 e2
  else ~eq_dep T.type support t1 e1 t2 e2.

 Parameter seqb_spec : forall t (e1 e2:support t),
  if seqb e1 e2 then e1 = e2 else e1 <> e2.

End DEXPR.

Module EmptySupport (UT:UTYPE) (T:TYPE UT) (Var:VAR UT T)
 (Mem:MEM UT T Var) (Uop:UOP UT T) (O:OP UT T Uop)
 (E:EXPR UT T Var Mem Uop O) <: USUPPORT UT T Var Mem Uop O E.

 Module VarP := MkEqBool_Leibniz_Theory Var.
 Module Vset := MkListSet VarP.Edec.

 Definition usupport (t:T.type) : Type := Empty_set.

 Definition eval k t (us:usupport t) (m:Mem.t k) : Distr (T.interp k t) :=
  match us return Distr (T.interp k t) with end.

 Definition ceval k t (us:usupport t) (m:Mem.t k) : Distr (T.interp k t) * nat :=
  match us return Distr (T.interp k t) * nat with end.

 Lemma ceval_spec : forall k t (s:usupport t) (m:Mem.t k),
  eval s m = fst (ceval s m).
 Proof.
  destruct s.
 Qed.

 Definition fv_distr t (s:usupport t) : Vset.t :=
  match s return Vset.t with end.

 Let req_mem k X (m1 m2:Mem.t k) :=
  forall t (x:Var.var t), Vset.mem x X -> m1 x = m2 x.

 Let depend_only_distr (X:Vset.t) t (s:usupport t) :=
  forall k (m1 m2:Mem.t k),
   req_mem X m1 m2 -> eval s m1 = eval s m2.

 Lemma depend_only_fv_distr : forall t (s:usupport t),
  depend_only_distr (fv_distr s) s.
 Proof.
  destruct s.
 Qed.

 Lemma lossless_support : forall k t (s:usupport t) (m:Mem.t k),
  mu (eval s m) (fun _ => 1) == 1.
 Proof.
  destruct s.
 Qed.

 Lemma discrete_support : forall k t (s:usupport t) (m:Mem.t k),
  is_Discrete (eval s m).
 Proof.
  destruct s.
 Qed.

 Definition eqb t1 t2 (us1:usupport t1) (us2:usupport t2) := true.

 Lemma eqb_spec_dep : forall t1 (e1:usupport t1) t2 (e2:usupport t2),
  if eqb e1 e2 then eq_dep T.type usupport t1 e1 t2 e2
  else ~eq_dep T.type usupport t1 e1 t2 e2.
 Proof.
  destruct e1.
 Qed.

 Lemma eqb_spec : forall t (e1 e2:usupport t),
  if eqb e1 e2 then e1 = e2 else e1 <> e2.
 Proof.
  destruct e1.
 Qed.

End EmptySupport.

Module MakeExpr (UT:UTYPE) (T:TYPE UT) (Var:VAR UT T) (Mem:MEM UT T Var)
 (Uop:UOP UT T) (O:OP UT T Uop) <: EXPR UT T Var Mem Uop O.

 (* Constants *)
 Inductive cexpr : T.type -> Type :=
 | Cbool :> bool -> cexpr T.Bool
 | Cnat :> nat -> cexpr T.Nat
 | CZ :> Z -> cexpr T.Zt
 | Cnil : forall t, cexpr (T.List t)
 | Cnone : forall t, cexpr (T.Option t).

 (* Expressions *)
 Inductive expr : T.type -> Type :=
 | Ecte :> forall t, cexpr t -> expr t
 | Evar :> forall t (v:Var.var t), expr t
 | Eop : forall op, dlist expr (O.targs op) -> expr (O.tres op)
 | Eexists : forall t, Var.var t -> expr T.Bool -> expr (T.List t) -> expr T.Bool
 | Eforall : forall t, Var.var t -> expr T.Bool -> expr (T.List t) -> expr T.Bool
 | Efind : forall t, Var.var t -> expr T.Bool -> expr (T.List t) -> expr t.

 Definition args := dlist expr.

 (* Induction principles *)
 Lemma expr_ind2 : forall (P : forall t, expr t -> Prop)
  (Pl : forall l, args l -> Prop),
  (forall t (c:cexpr t), P _ c) ->
  (forall t (v:Var.var t), P _ v) ->
  (forall op args, Pl (O.targs op) args -> P _ (Eop op args)) ->
  (forall t (v:Var.var t) e1 e2, P _ e1 -> P _ e2 -> P _ (Eexists v e1 e2)) ->
  (forall t (v:Var.var t) e1 e2, P _ e1 -> P _ e2 -> P _ (Eforall v e1 e2)) ->
  (forall t (v:Var.var t) e1 e2, P _ e1 -> P _ e2 -> P _ (Efind v e1 e2)) ->
  (Pl nil (dnil expr)) ->
  (forall t l e le, P t e -> Pl l le -> Pl (t::l) (dcons t e le)) ->
  forall t e, P t e.
 Proof.
  intros P Pl Hc Hv Hop Hex Hfa Hfind Hnil Hcons.
  fix expr_ind2 2.
  destruct e.
  apply Hc.
  apply Hv.
  apply Hop.
  generalize (O.targs op) d; clear d op.
  induction d.
  apply Hnil.
  apply Hcons; auto.
  apply Hex; auto.
  apply Hfa; auto.
  apply Hfind; auto.
 Qed.

 Lemma expr_ind_and :  forall (P : forall t, expr t -> Prop)
  (Pl : forall l, args l -> Prop),
  (forall t (c:cexpr t), P _ c) ->
  (forall t (v:Var.var t), P _ v) ->
  (forall op args, Pl (O.targs op) args -> P _ (Eop op args)) ->
  (forall t (v:Var.var t) e1 e2, P _ e1 -> P _ e2 -> P _ (Eexists v e1 e2)) ->
  (forall t (v:Var.var t) e1 e2, P _ e1 -> P _ e2 -> P _ (Eforall v e1 e2)) ->
  (forall t (v:Var.var t) e1 e2, P _ e1 -> P _ e2 -> P _ (Efind v e1 e2)) ->
  (Pl nil (dnil expr)) ->
  (forall t l e le, P t e -> Pl l le -> Pl (t::l) (dcons t e le)) ->
  (forall t e, P t e) /\ (forall lt args, Pl lt args).
 Proof.
  split; intros.
  eapply expr_ind2; eauto.
  induction args0; auto.
  apply H6; auto.
  eapply expr_ind2; eauto.
 Qed.

 Definition ceqb (t1 t2:T.type) (c1:cexpr t1) (c2:cexpr t2) : bool :=
  match c1, c2 with
  | Cbool b1, Cbool b2 => Bool.eqb b1 b2
  | Cnat n1, Cnat n2 => nat_eqb n1 n2
  | CZ n1, CZ n2 => Zeq_bool n1 n2
  | Cnil t1, Cnil t2 => T.eqb t1 t2
  | Cnone t1, Cnone t2 => T.eqb t1 t2
  | _, _ => false
  end.

 Lemma ceqb_spec_dep : forall t1 (e1 : cexpr t1) t2 (e2:cexpr t2),
  if ceqb e1 e2 then eq_dep T.type cexpr t1 e1 t2 e2
  else ~eq_dep T.type cexpr t1 e1 t2 e2.
 Proof.
  destruct e1; destruct e2; simpl; try (intro Heq; inversion Heq).
  case_eq (eqb b b0); intros.
  rewrite (eqb_eq b b0);[ constructor | rewrite H; simpl; trivial].
  intros Heq; inversion Heq; subst; rewrite eqb_reflx in H; discriminate.
  generalize (nat_eqb_spec n n0); destruct (nat_eqb n n0); intros; subst.
  constructor.
  intros Heq; apply H; assert (W:=T.eq_dep_eq Heq);
    inversion W; trivial.
  generalize (Zeq_bool_eq z z0); generalize (Zeq_bool_neq z z0); destruct (Zeq_bool z z0); intros.
  elim H0; trivial.
  intros Heq.
  inversion Heq.
  apply H; trivial.
  generalize (T.eqb_spec t t0); destruct (T.eqb t t0); intros; subst.
  constructor.
  intros Heq; apply H; inversion Heq; trivial.
  generalize (T.eqb_spec t t0); destruct (T.eqb t t0); intros; subst.
  constructor.
  intros Heq; apply H; inversion Heq; trivial.
 Qed.

 Lemma ceqb_spec : forall t (e1 e2:cexpr t),
  if ceqb e1 e2 then e1 = e2 else e1 <> e2.
 Proof.
  intros t e1 e2; generalize (ceqb_spec_dep e1 e2);
   destruct (ceqb e1 e2); intros.
  apply (T.eq_dep_eq H).
  intros Heq; apply H; rewrite Heq; constructor.
 Qed.

 Fixpoint eqb (t1 t2:T.type) (e1:expr t1)(e2:expr t2) {struct e1} : bool :=
  match e1, e2 with
  | Ecte t1 c1, Ecte t2 c2 => ceqb c1 c2
  | Evar t1 v1, Evar t2 v2 => Var.veqb v1 v2
  | Eop op1 args1, Eop op2 args2 =>
    if O.eqb op1 op2 then dforall2 eqb args1 args2 else false
  | Eexists t1 v1 e11 e12, Eexists t2 v2 e21 e22 =>
    if Var.veqb v1 v2 then
      if eqb e11 e21 then eqb e12 e22 else false
    else false
  | Eforall t1 v1 e11 e12, Eforall t2 v2 e21 e22 =>
    if Var.veqb v1 v2 then
     if eqb e11 e21 then eqb e12 e22 else false
    else false
  | Efind t1 v1 e11 e12, Efind t2 v2 e21 e22 =>
    if Var.veqb v1 v2 then
     if eqb e11 e21 then eqb e12 e22 else false
    else false
  | _, _ => false
  end.

 Lemma eqb_spec_dep : forall t1 (e1 : expr t1) t2 (e2:expr t2),
  if eqb e1 e2 then eq_dep T.type expr t1 e1 t2 e2
  else ~eq_dep T.type expr t1 e1 t2 e2.
 Proof.
  induction e1 using expr_ind2 with
   (P := fun t1 (e1:expr t1) => forall t2 (e2:expr t2),
    if eqb e1 e2 then eq_dep T.type expr t1 e1 t2 e2
     else ~eq_dep T.type expr t1 e1 t2 e2)
   (Pl := fun l1 (le1: dlist expr l1) =>
    forall l2 (le2:dlist expr l2),
     if dforall2 eqb le1 le2 then
      eq_dep (list T.type) (dlist expr) l1 le1 l2 le2
      else ~ eq_dep (list T.type) (dlist expr) l1 le1 l2 le2);
   match goal with
    |- forall (t2:T.type) (e2:expr t2), _ =>
     destruct e2; simpl; try (intros Heq; inversion Heq; fail)
   | _ => idtac end.
  generalize (ceqb_spec_dep c c0); destruct (ceqb c c0); intros H.
  inversion H; subst; simpl; constructor.
  intros Heq; apply H; inversion Heq; simpl; constructor.
  generalize (Var.veqb_spec_dep v v0); destruct (Var.veqb v v0); intros; subst.
  inversion H; clear H; constructor.
  intros Heq; apply H; inversion Heq; trivial.
  generalize (O.eqb_spec op op0); destruct (O.eqb op op0); intros; subst.
  generalize (IHe1 _ d); destruct (dforall2 eqb args0 d); intros.
  rewrite (T.l_eq_dep_eq H); constructor.
  intros Heq; apply H; inversion Heq.
  rewrite (O.inj_pair2 H0); constructor.
  intros Heq; apply H; inversion Heq; trivial.
  generalize (Var.veqb_spec_dep v v0); destruct (Var.veqb v v0); intros; subst.
  inversion H; clear H; subst.
  rewrite (T.inj_pair2 H3); clear H2 H3.
  generalize (IHe1_1 _ e2_1); destruct (eqb e1_1 e2_1); intros.
  generalize (IHe1_2 _ e2_2); destruct (eqb e1_2 e2_2); intros.
  rewrite (T.eq_dep_eq H).
  rewrite (T.eq_dep_eq H0); constructor.
  intros Heq; assert (W:= T.eq_dep_eq Heq); apply H0; inversion W.
  rewrite (T.inj_pair2 H3); constructor.
  intros Heq; apply H; inversion Heq; constructor.
  intros Heq; apply H; inversion Heq; trivial.
  subst; rewrite (T.inj_pair2 H2); constructor.
  generalize (Var.veqb_spec_dep v v0); destruct (Var.veqb v v0); intros; subst.
  inversion H; clear H; subst.
  rewrite (T.inj_pair2 H3); clear H2 H3.
  generalize (IHe1_1 _ e2_1); destruct (eqb e1_1 e2_1); intros.
  generalize (IHe1_2 _ e2_2); destruct (eqb e1_2 e2_2); intros.
  rewrite (T.eq_dep_eq H).
  rewrite (T.eq_dep_eq H0); constructor.
  intros Heq; assert (W:= T.eq_dep_eq Heq); apply H0; inversion W.
  rewrite (T.inj_pair2 H3); constructor.
  intros Heq; apply H; inversion Heq; constructor.
  intros Heq; apply H; inversion Heq; trivial.
  subst; rewrite (T.inj_pair2 H2); constructor.
  generalize (Var.veqb_spec_dep v v0); destruct (Var.veqb v v0); intros; subst.
  inversion H; clear H; subst.
  rewrite (T.inj_pair2 H3); clear H2 H3.
  generalize (IHe1_1 _ e2_1); destruct (eqb e1_1 e2_1); intros.
  generalize (IHe1_2 _ e2_2); destruct (eqb e1_2 e2_2); intros.
  rewrite (T.eq_dep_eq H).
  rewrite (T.eq_dep_eq H0); constructor.
  intros Heq; assert (W:= T.eq_dep_eq Heq); apply H0; inversion W.
  rewrite (T.inj_pair2 H3); constructor.
  intros Heq; apply H; inversion Heq; constructor.
  intros Heq; apply H; inversion Heq; trivial.
  subst; rewrite (T.inj_pair2 H4); constructor.
  destruct le2; simpl; try (intros Heq; inversion Heq; fail).
  constructor.
  destruct le2; simpl; try (intros Heq; inversion Heq; fail).
  generalize (IHe1 _ e); destruct (eqb e1 e); intros.
  inversion H; subst.
  rewrite (T.inj_pair2 H3); simpl.
  generalize (IHe0 _ le2); destruct (dforall2 eqb le le2); intros.
  inversion H0; subst; simpl; constructor.
  intros Heq; apply H0; inversion Heq; simpl; constructor.
  intros Heq; apply H; inversion Heq; simpl; constructor.
 Qed.

 Lemma eqb_spec : forall t (e1 e2:expr t),
  if eqb e1 e2 then e1 = e2 else e1 <> e2.
 Proof.
  intros t e1 e2; generalize (eqb_spec_dep e1 e2); destruct (eqb e1 e2);
   intros.
  apply (T.eq_dep_eq H).
  intros Heq; apply H; rewrite Heq; constructor.
 Qed.

 Definition args_eqb (l1 l2:list T.type) (a1:args l1) (a2: args l2) : bool :=
  dforall2 eqb a1 a2.

 Lemma args_eqb_spec_dep : forall l1 (a1 : args l1) l2 (a2:args l2),
  if args_eqb a1 a2 then eq_dep (list T.type) args l1 a1 l2 a2
  else ~eq_dep (list T.type) args l1 a1 l2 a2.
 Proof.
  induction a1; destruct a2; simpl; try (intro Heq; inversion Heq).
  constructor.
  generalize (eqb_spec_dep p e); destruct (eqb p e); intros.
  inversion H; subst; simpl.
  generalize (IHa1 _ a2); destruct (args_eqb a1 a2); intros.
  inversion H0; subst; simpl; constructor.
  intros Heq; apply H0; inversion Heq; subst; simpl; constructor.
  intros Heq; apply H; inversion Heq; subst; simpl; trivial.
 Qed.

 Lemma args_eqb_spec : forall l (a1 a2:args l),
  if args_eqb a1 a2 then a1 = a2 else a1 <> a2.
 Proof.
  intros t e1 e2; generalize (args_eqb_spec_dep e1 e2);
   destruct (args_eqb e1 e2); intros.
  apply (T.l_eq_dep_eq H).
  intros Heq; apply H; rewrite Heq; constructor.
 Qed.

 Section EVAL.

  Variable k : nat.

  Definition eval_cexpr t (c:cexpr t) : T.interp k t :=
   match c in (cexpr t0) return T.interp k t0 with
   | Cbool b => b
   | Cnat n => n
   | CZ n => n
   | Cnil t => @nil (T.interp k t)
   | Cnone t => @None (T.interp k t)
   end.

  Definition ceval_cexpr t (c:cexpr t) : T.interp k t * nat :=
   match c in (cexpr t0) return T.interp k t0 * nat with
   | Cbool b => (b, S O)
   | Cnat n => (n, size_nat n)
   | CZ n => (n, size_Z n)
   | Cnil t => (@nil (T.interp k t), S O)
   | Cnone t => (@None (T.interp k t), S O)
   end.

  Fixpoint eval_expr (t:T.type) (e:expr t) (m:Mem.t k) : T.interp k t :=
   match e in expr t0 return T.interp k t0 with
   | Ecte t c => eval_cexpr c
   | Evar t v => m v
   | Eop op la =>
     O.eval_op op (dmap (T.interp k) (fun t (e:expr t) => eval_expr e m) la)
   | Eexists t x e1 e2 =>
     List.existsb
     (fun v => eval_expr e1 (Mem.upd m x v))
     (eval_expr e2 m)
   | Eforall t x e1 e2 =>
     List.forallb
     (fun v => eval_expr e1 (Mem.upd m x v))
     (eval_expr e2 m)
   | Efind t x e1 e2 =>
     find_default
     (fun v => eval_expr e1 (Mem.upd m x v))
     (eval_expr e2 m) (T.default k t)
   end.

 Fixpoint ceval_expr (t:T.type) (e:expr t) (m:Mem.t k) : T.interp k t * nat :=
   match e in expr t0 return T.interp k t0 * nat with
   | Ecte t c => ceval_cexpr c
   | Evar t v => (m v, S O)
   | Eop op la =>
     let ca := dfold_right (fun t (e:expr t) c => snd (ceval_expr e m) + c)%nat 0%nat la in
     let (r, c) := O.ceval_op op (dmap (T.interp k) (fun t (e:expr t) => eval_expr e m) la) in
     (r, c + ca)%nat
   | Eexists t x e1 e2 =>
     let (l, n) := ceval_expr e2 m in
      cexistsb
      (fun v => ceval_expr e1 (Mem.upd m x v))
      l n
   | Eforall t x e1 e2 =>
     let (l, n) := ceval_expr e2 m in
      cforallb
      (fun v => ceval_expr e1 (Mem.upd m x v))
      l n
   | Efind t x e1 e2 =>
     let (l, n) := ceval_expr e2 m in
      cfind_default
      (fun v => ceval_expr e1 (Mem.upd m x v))
      l n (T.default k t)
   end.

  Lemma ceval_expr_spec : forall t (e:expr t) m,
   eval_expr e m = fst (ceval_expr e m).
  Proof.
   induction e; intros.
   case c; trivial.
   trivial.
   simpl.
  rewrite O.ceval_op_spec.
  match goal with |- fst ?x = _ => destruct x; trivial end.
   simpl; rewrite IHe2.
   case (ceval_expr e2 m); intros.
   apply existsb_cexistsb.
   intro; apply IHe1.
   simpl; rewrite IHe2.
   case (ceval_expr e2 m); intros.
   apply forallb_cforallb.
   intro; apply IHe1.
   simpl; rewrite IHe2.
   case (ceval_expr e2 m); intros.
   apply find_cfind_default.
   intro; apply IHe1.
  Qed.

  Definition eval_args lt (a:args lt) (m:Mem.t k) :=
   dmap (T.interp k) (fun t (e:expr t) => eval_expr e m) a.

  Definition ceval_args lt (a:args lt) (m:Mem.t k) :=
   dmap (fun x => T.interp k x * nat)%type (fun t (e:expr t) => ceval_expr e m) a.

 End EVAL.

 (* Dependant Equality *)
 Lemma eq_dec2 : forall t (p1 p2 : expr t), {p1 = p2} + {p1 <> p2}.
 Proof.
  intros t p1 p2; generalize (eqb_spec p1 p2); destruct (eqb p1 p2); auto.
 Qed.

 Lemma eq_dep_eq : forall t (P:expr t->Type) (p:expr t) (x y:P p),
  eq_dep (expr t) P p x p y -> x = y.
 Proof.
  intros t; apply (eq_rect_eq__eq_dep_eq (expr t) (eq_rect_eq_dec (@eq_dec2 t))).
 Qed.

 Lemma UIP_refl : forall t (x:expr t) (p:x = x), p = refl_equal x.
 Proof.
  intros t; apply (UIP__UIP_refl (expr t) (eq_dep_eq__UIP (expr t) (@eq_dep_eq t))).
 Qed.

 Lemma inj_pair2 : forall t (P:expr t -> Type) (p:expr t) (x y:P p),
  existT P p x = existT P p y -> x = y.
 Proof.
  intros t; apply (eq_dep_eq__inj_pairT2 (expr t) (@eq_dep_eq t)).
 Qed.

 (* Useful functions *)
 Fixpoint tapp_expr (lt:list T.type) (tr:T.type) : Type:=
  match lt with
  | nil => expr tr
  | cons t lt => expr t -> tapp_expr lt tr
  end.

 Fixpoint app_expr (lt:list T.type) (tr:T.type)
  (args:args lt) : tapp_expr lt tr -> expr tr :=
  match args in dlist _ lt0 return tapp_expr lt0 tr -> expr tr with
  | dnil => fun e => e
  | dcons t lt e l => fun op => app_expr tr l (op e)
  end.

 Definition get_uop t (e:expr t) : option (sigT (fun op => args (Uop.targs op))) :=
  match e with
  | Eop op a =>
    match op as op0
    return args (O.targs op0) -> option (sigT (fun op => args (Uop.targs op))) with
    | O.Ouser uop => fun args => Some (existT _ uop args)
    | _ => fun _ => None
    end a
  | _ => None
  end.

 Module UOdec <: DecidableType.

   Definition U := Uop.t.

   Lemma eq_dec : forall (t1 t2:U), sumbool (t1 = t2) (t1 <> t2).
   Proof.
    intros t1 t2.
    generalize (Uop.eqb_spec t1 t2); destruct (Uop.eqb t1 t2); auto.
   Qed.

 End UOdec.

 Module UopD := DecidableEqDepSet UOdec.

 Lemma get_uop_spec : forall t (e:expr t) op args,
  get_uop e = Some (existT _ op args) ->
  eq_dep T.type expr _ e _ (Eop (O.Ouser op) args).
 Proof.
  destruct e; simpl; try (intros; discriminate).
  destruct op; simpl; intros; try discriminate.
  injection H; clear H; intros; subst.
  rewrite (UopD.inj_pair2 (fun x => args (Uop.targs x)) op d args0 H); trivial.
 Qed.

End MakeExpr.

Module MakeDExpr (UT:UTYPE) (T:TYPE UT) (Var:VAR UT T) (Mem:MEM UT T Var)
 (Uop:UOP UT T) (O:OP UT T Uop) (E:EXPR UT T Var Mem Uop O)
 (US:USUPPORT UT T Var Mem Uop O E) <: DEXPR UT T Var Mem Uop O E US.

 Inductive support : T.type -> Type :=
 | Dbool : support T.Bool
 | Dnat : E.expr T.Nat -> support T.Nat
 | DZ : E.expr T.Zt -> E.expr T.Zt -> support T.Zt
 | Duser : forall t, US.usupport t -> support t
 | Dprod : forall t1 t2, support t1 -> support t2 -> support (T.Pair t1 t2).

 Fixpoint eval_support k t (s:support t) (m:Mem.t k) : Distr (T.interp k t) :=
  match s in support t0 return Distr (T.interp k t0) with
  | Dbool => Flip
  | Dnat e => Random (E.eval_expr e m)
  | DZ e1 e2 => RandomZ (E.eval_expr e1 m) (E.eval_expr e2 m)
  | Duser t s => US.eval s m
  | Dprod t1 t2 s1 s2 => prod_distr (eval_support s1 m) (eval_support s2 m)
  end.

 Fixpoint ceval_support k t (s:support t) (m:Mem.t k) :
  Distr (T.interp k t) * nat :=
  match s in support t0 return Distr (T.interp k t0) * nat with
  | Dbool => (Flip, S 0)
  | Dnat e => let (n, m) := E.ceval_expr e m in (Random n, m)
  | DZ e1 e2 =>
    let (a, n1) := E.ceval_expr e1 m in
    let (b, n2) := E.ceval_expr e2 m in
     (RandomZ a b, plus n1 n2)
  | Duser t s => US.ceval s m
  | Dprod t1 t2 s1 s2 =>
    let (n1, m1) := ceval_support s1 m in
    let (n2, m2) := ceval_support s2 m in
     (prod_distr n1 n2, mult m1 m2)
  end.

 Lemma ceval_support_spec : forall k t (s:support t) m,
  eval_support (k:=k) s m = fst (ceval_support (k:=k) s m).
 Proof.
  intros k t s m.
  induction s; simpl; trivial.
  rewrite (E.ceval_expr_spec e m); case (E.ceval_expr e m); trivial.
  rewrite (E.ceval_expr_spec e m); case (E.ceval_expr e m); trivial.
  rewrite (E.ceval_expr_spec e0 m); case (E.ceval_expr e0 m); trivial.
  refine (US.ceval_spec _ _).
  rewrite IHs1, IHs2.
  destruct (ceval_support s1 m).
  destruct (ceval_support s2 m).
  simpl; trivial.
 Qed.

 Fixpoint seqb (t1 t2:T.type) (s1:support t1) (s2:support t2) : bool :=
  match s1, s2 with
  | Dbool, Dbool => true
  | Dnat e1, Dnat e2 => E.eqb e1 e2
  | DZ e1a e1b, DZ e2a e2b => E.eqb e1a e2a && E.eqb e1b e2b
  | Duser t1 u1, Duser t2 u2 => US.eqb u1 u2
  | Dprod t1_1 t2_1 s1_1 s2_1, Dprod t1_2 t2_2 s1_2 s2_2 =>
    andb (seqb s1_1 s1_2) (seqb s2_1 s2_2)
  | _, _ => false
  end.

 Lemma lossless_support : forall k t (s:support t) (m:Mem.t k),
  mu (eval_support s m) (fun _ => 1) == 1.
 Proof.
  induction s; intros.
  simpl; Usimpl; auto.
  apply Random_total.
  apply RandomZ_total.
  apply US.lossless_support.
  simpl.
  rewrite <- (IHs1 m).
  refine (mu_stable_eq _ _ _ _); refine (ford_eq_intro _); intro.
  apply (IHs2 m).
 Qed.

 Lemma discrete_support : forall k t (s:support t) (m:Mem.t k),
  is_Discrete (eval_support s m).
 Proof.
  induction s; intros.

  (* Flip *)
  apply mkDiscr with (D_points:=leb 1).
  red; red; intros; simpl.
  repeat rewrite <- H; repeat Usimpl; auto.
  red; apply exc_intro with O; trivial.
  red; apply exc_intro with (S k); auto.

  (* Random *)
  apply mkDiscr with (D_points:=id).
  red; red; intros.
  simpl eval_support.
  rewrite Random_simpl, random_simpl.
  symmetry; apply sigma_zero; intros i Hlt.
  rewrite <-H; [auto | ].
  apply exc_intro with i; trivial.

  (* RandomZ *)
  apply mkDiscr with (D_points:=fun i => (E.eval_expr e m + Z_of_nat i)%Z).
  red; red; intros.
  simpl eval_support.
  rewrite RandomZ_simpl, randomZ_simpl.
  symmetry; apply sigma_zero; intros i Hlt.
  rewrite <-H; [auto | ].
  apply exc_intro with i; trivial.

  (* User *)
  apply US.discrete_support.

  (* Prod *)
  simpl.
  apply is_Discrete_Mlet; trivial; intro.
  apply is_Discrete_Mlet; trivial; intro.
  apply is_Discrete_Munit.
 Qed.

 Lemma seqb_spec_dep :  forall t1 (e1:support t1) t2 (e2:support t2),
  if seqb e1 e2 then eq_dep T.type support t1 e1 t2 e2
  else ~eq_dep T.type support t1 e1 t2 e2.
 Proof.
  induction e1; destruct e2; simpl; try (intro H; inversion H; fail).
  constructor.
  generalize (E.eqb_spec_dep e e0); destruct (E.eqb e e0); intros.
  inversion H; subst.
  rewrite (T.inj_pair2 H0); constructor.
  intro Heq; apply H; inversion Heq; constructor.
  generalize (E.eqb_spec_dep e e1); destruct (E.eqb e e1); intros;
    generalize (E.eqb_spec_dep e0 e2); destruct (E.eqb e0 e2); intros; simpl.
  inversion H; subst.
  inversion H0; subst.
  rewrite (T.inj_pair2 H1), (T.inj_pair2 H2); constructor.
  intro Heq; apply H0; inversion Heq; constructor.
  intro Heq; apply H; inversion Heq; constructor.
  intro Heq; apply H; inversion Heq; constructor.
  generalize (US.eqb_spec_dep u u0); destruct (US.eqb u u0); intros.
  inversion H; simpl; constructor.
  contradict H; inversion H; simpl; constructor.
  generalize (IHe1_1 t0 e2_1); generalize (IHe1_2 t3 e2_2).
  destruct (seqb e1_2 e2_2); destruct (seqb e1_1 e2_1); simpl; intros.
  destruct H; destruct H0; constructor.
  contradict H0; destruct H; inversion H0; constructor.
  contradict H0; destruct H; inversion H0; constructor.
  contradict H0; destruct H; inversion H0; constructor.
 Qed.

 Lemma seqb_spec : forall t (e1 e2:support t),
  if seqb e1 e2 then e1 = e2 else e1 <> e2.
 Proof.
  intros t e1 e2; generalize (seqb_spec_dep e1 e2); destruct (seqb e1 e2); intros.
  apply (T.eq_dep_eq H).
  intros Heq; apply H; rewrite Heq; constructor.
 Qed.

End MakeDExpr.


Require Import Base.
Require Import Kleene.
Require Import Monad.
Require Import ClassicalMonads.

Section Monad_Defs.

Generalizable Variables M.

Context `(M_Monad : Monad M).

(* Definition preserves_hprop (M : Monad) := forall A, is_hprop A -> is_hprop (Monad_obj_map M A).  *)

Definition lifted_projP1  : forall A (P : A -> Prop), M {x : A | P x} -> M A.
Proof.
  intros.
  apply (Monad_fun_map {x : A | P x}).
  intro.
  destruct X0.
  exact x.
  exact X.
Defined.

Definition trace_lifts_to_fiber:
  forall P : nat -> Type,
  forall R : (forall n, P n -> P (S n) -> Prop),
    M (P O) ->
    (forall n (x : P n), M {y : P (S n) | R n x y}) ->
    forall n, M (P n).
Proof.
  intros P R X f.
  apply nat_rect.
  exact X.
  intros.
  pose proof (f n).
  apply Monad_mult.
  apply (Monad_fun_map (P n)).
  intro.
  exact (lifted_projP1 _ _ (X1 X2)).
  exact X0.
Defined.

(* given a collection of sections, get the retraction. *)
Definition sections_to_fibers : forall P : nat -> Type,
    M (forall n, P n) -> (forall n, M (P n)).
Proof.
  intros P X n.
  apply (Monad_fun_map _ _ (fun f => f n) X).
Defined.

Definition lifts_lifted_trace :=
  forall P : nat -> Type,
  forall R : (forall n, P n -> P (S n) -> Prop),
  forall X : M (P O),
  forall f : (forall n (x : P n), M {y : P (S n) | R n x y}),
    {F : M {f : forall n, (P n) | forall m, R m (f m) (f (S m))} |
     sections_to_fibers _ (lifted_projP1 _ _ F) = trace_lifts_to_fiber P R X f}.

End Monad_Defs.

Lemma NPset_unit_is_mono : forall A, is_mono (Monad_unit A : A -> NPset A).
Proof.
  intros.
  intros x y H.
  apply sigma_eqP_pr1 in H.
  apply (lp _ _ (fun g => g x)) in H.
  rewrite <- H; auto.
Defined.

Lemma Nabla_unit_is_mono : forall A, is_mono (Monad_unit A : A -> Nabla A).
Proof.
  intros.
  intros x y H.
  apply sigma_eqP_pr1 in H.
  apply (lp _ _ (fun g => g x)) in H.
  rewrite <- H; auto.
Defined.

Section M_Defs.

Generalizable Variables K M.

Context `{klb : LazyBool K} `{M_Monad : Monad M} {MultivalueMonad_description : Monoid_hom M_Monad NPset_Monad}.

Definition M_description A := @Monoid_hom_nat_trans _ _ _ _ MultivalueMonad_description A.

Class MultivalueMonad :=
  {
    MultivalueMonad_base_monad_hprop_elim : forall A, is_hprop A -> is_equiv (Monad_unit A);
    MultivalueMonad_base_monad_traces_lift : lifts_lifted_trace M_Monad;
    multivalued_choice : forall x y : K, x = lazy_bool_true \/ y = lazy_bool_true -> M ({ x = lazy_bool_true } + { (y = lazy_bool_true) });

    MultivalueMonad_description_is_mono : Monoid_hom_is_mono _ _ MultivalueMonad_description;
    MultivalueMonad_description_is_equiv : forall A, is_equiv (Monad_fun_map _ _ (M_description A));

    MultivalueMonad_destruct : forall A (X : M A), M  {x : A | projP1 _ _ (M_description A X) x};
  }.

Context {M_MultivalueMonad : MultivalueMonad}.

(* Definition M : Type -> Type := M. *)
Definition M_lift : forall A B, (A -> B) -> M A -> M B := Monad_fun_map.
Definition M_functorial_comp : forall A B C (f : A -> B) (g : B -> C),
    M_lift _ _ (fun x => g (f x)) = fun x => (M_lift _ _ g) ((M_lift _ _ f) x)
  := Monad_functorial_comp.
Definition M_functorial_id : forall A, (fun x : M A => x) = M_lift A A (fun x => x)
:= Monad_functorial_id.

(* Monadic structure: *)
Definition M_unit : forall T : Type, T -> M T
  := Monad_unit.
Definition M_mult : forall T : Type, M (M T) -> M T
  := Monad_mult.
Definition M_lift_dom : forall A B, (A -> M B) -> M A -> M B :=
  fun A B f => fun x => M_mult B ((M_lift A (M B) f) x).
Definition M_unit_ntrans : forall A B (f : A -> B) x, (M_lift A B f) (M_unit A x) = M_unit B (f x)
  := Monad_unit_ntrans.
Definition M_mult_ntrans : forall A B (f : A -> B) x, M_mult B ((M_lift (M A) (M B) (M_lift A B f)) x) = (M_lift A B f) (M_mult A x)
  := Monad_mult_ntrans.

(* coherence conditions for the monadic structure: *)
Definition M_coh1 : forall A x, M_mult A (M_unit (M A) x) = x := Monad_coh1.
Definition M_coh2 : forall A x, M_mult A (M_lift A (M A) (M_unit A)  x) = x := Monad_coh2.
Definition M_coh3 : forall A x, M_mult A (M_mult (M A) x) = M_mult A (M_lift (M (M A)) (M A) (M_mult A) x) := Monad_coh3.

Definition M_hprop_elim : forall A, is_hprop A -> is_equiv (M_unit A) :=  MultivalueMonad_base_monad_hprop_elim.
(* Definition M_unit_is_mono : forall A, is_mono (M_unit A) := MultivalueMonad_base_monad_unit_is_mono _ M_structure. *)
Definition M_traces_lift := MultivalueMonad_base_monad_traces_lift.
Definition M_choice : forall x y, (lazy_bool_up _ x \/ lazy_bool_up _ y) -> M ({lazy_bool_up _ x} + {lazy_bool_up _ y}) := (multivalued_choice).

Definition M_description_is_mono : forall A, is_mono (M_description A) := MultivalueMonad_description_is_mono.
Definition M_description_is_equiv : forall A, is_equiv (Monad_fun_map _ _ (M_description A)) := MultivalueMonad_description_is_equiv.

Definition M_picture : forall {A}, M A -> NPset A.
Proof.
  intros A X.
  exact (M_description A X).
Defined.

Definition M_picture_1 : forall {A}, M A -> A -> Prop.
Proof.
  intros A X.
  exact (projP1 _ _ (M_description A X)).
Defined.

Definition M_destruct : forall {A} (X : M A), M {x : A | M_picture_1 X x} := MultivalueMonad_destruct.

Definition M_W_destruct : forall {A} (X : M A), exists x : A, M_picture_1 X x.
Proof.
  intros.
  unfold M_picture_1.
  destruct (M_description A X).
  exact e.
Defined.

Lemma M_unit_is_mono : forall A, is_mono (Monad_unit A).
Proof.
  intros A x y H.
  pose proof MultivalueMonad_description_is_mono.
  unfold Monoid_hom_is_mono in H0.
  pose proof (Monoid_hom_unit _ _ A ).
  apply (lp _ _ (fun g => g x)) in H1.
  pose proof (Monoid_hom_unit _ _ A ).
  apply (lp _ _ (fun g => g y)) in H2.
  rewrite H in H1.
  rewrite H1 in H2.
  apply NPset_unit_is_mono in H2.
  exact H2.
Defined.

Lemma M_fun_picture : forall {A B} (f : A -> B), NPset A -> NPset B.
Proof.
  intros A B f.
  exact (Monad_fun_map _ _ f).
Defined.

Lemma M_fun_cont : forall {A B} (f : A -> B) X b , M_picture_1 (Monad_fun_map _ _ f X) b = exists a, (M_picture_1 X) a /\ b = f a  .
Proof.
  intros.
  unfold M_picture_1.
  pose proof ((Monoid_hom_nat_trans_prop _ _ _ _ f)).
  apply (lp _ _ (fun g => g X)) in H.
  fold (M_description A) in H.
  fold (M_description B) in H.
  rewrite H.
  clear H.
  apply Prop_ext.
  intro.
  destruct (M_description A X).
  destruct e.
  simpl in H.
  destruct H.
  exists x2; auto.
  intro.
  destruct H.
  destruct (M_description A X).
  simpl.
  destruct e.
  exists x.
  simpl in H.
  auto.
Defined.

Lemma M_fun_cont_r : forall {A B} (f : A -> B), forall X x, M_picture_1 X x -> M_picture_1 (Monad_fun_map _ _ f X) (f x).
Proof.
  intros.
  pose proof ((Monoid_hom_nat_trans_prop _ _  A B f)).
  apply (lp _ _ (fun g => g X)) in H0.
  unfold M_picture_1.
  fold (M_description B) in H0.
  rewrite H0.
  unfold M_picture_1 in H.
  pose (j :=  (Monoid_hom_nat_trans _ _ A X)).
  fold j.
  unfold M_description in H.
  fold j in H.
  destruct j.
  simpl in H.
  simpl.
  exists x; auto.
Defined.

Lemma M_fun_cont_r_inv : forall {A B} (f : A -> B), forall X y, M_picture_1 (Monad_fun_map _ _ f X) y -> exists x, M_picture_1 X x /\ y = f x.
Proof.

  intros.
  pose proof ((Monoid_hom_nat_trans_prop _ _  A B f)).
  apply (lp _ _ (fun g => g X)) in H0.
  unfold M_picture_1, M_description in H.
  rewrite H0 in H.
  clear H0.
  unfold M_picture_1, M_description.

  pose (XP :=  (Monoid_hom_nat_trans _ _ A X)).
  fold XP.
  fold XP in H.
  destruct XP.
  simpl in H.
  destruct H.
  exists x0.
  simpl; auto.
Defined.

Definition M_hprop_elim_f : forall A, is_hprop A -> M A -> A.
Proof.
  intros.
  exact (projP1 _ _ (MultivalueMonad_base_monad_hprop_elim A H) X).
Defined.

(* M unit is singleton {Monad_unit unit tt} *)
Lemma M_preserves_singleton : forall a : M unit, a = Monad_unit _ tt.
Proof.
  intros.
  pose proof (MultivalueMonad_base_monad_hprop_elim unit).
  assert (forall x y : unit, x = y).
  intros.
  destruct x, y; auto.
  destruct (X H).
  destruct a0.
  unfold fc, id in H1.
  apply (lp _ _ (fun k => k a)) in H1.
  rewrite (H (x a) (tt)) in H1.
  auto.
Defined.

(* M unit is subsingleton, of course. *)
Lemma M_singleton_is_hprop : is_hprop (M unit).
Proof.
  intros x y; rewrite (M_preserves_singleton x), (M_preserves_singleton y); exact eq_refl.
Defined.

(* lifting of a constant function is constant. This is because unit is preserved by M. *)
Lemma Monad_fun_map_const_is_const : forall {A B} b, Monad_fun_map A B (fun _  => b) = fun _ => Monad_unit _ b.
Proof.
  intros.
  pose proof (Monad_functorial_comp A unit B (fun _ => tt) (fun _ => b)).
  rewrite H.
  assert ((Monad_fun_map A unit (fun _ : A => tt)) = (fc  (Monad_unit unit) (fun _ : M A => tt))).
  apply fun_to_subsingleton_id.
  apply M_singleton_is_hprop.
  rewrite H0.
  pose proof (Monad_unit_ntrans unit B (fun _ => b) tt).
  unfold fc.
  rewrite H1.
  auto.
Defined.

Definition M_projP1 : forall A (P : A -> Prop), M {x : A | P x} -> M A.
Proof.
  intros.
  apply (Monad_fun_map {x : A | P x}).
  intro.
  destruct X0.
  exact x.
  exact X.
Defined.

  (* := lifted_projP1 M. *)

(* Proof. *)
(*   intros. *)
(*   apply (Monad_fun_map {x : A | P x}). *)
(*   intro. *)
(*   destruct X0. *)
(*   exact x. *)
(*   exact X. *)
(* Defined.   *)

(* we can get sections from repeated M-valued procedures.
   In the simple case, intuitively, when we have x0 : T,
   and  f : nat -> T -> M T such that
   for all y \in (f n) xn, (R n) xn y holds, by repeatedly applying f,
   we can get a set of pathes {x0, x1, ...} such that R n (xn) (xn+1) holds. *)
Definition M_paths :
  forall P : nat -> Type,
  forall R : (forall n, P n -> P (S n) -> Prop),
    M (P O) ->
    (forall n (x : P n), M {y : P (S n) | R n x y}) ->
    M {f : forall n, (P n) | forall m, R m (f m) (f (S m))}.
Proof.
  intros.
  exact (projP1 _ _ (MultivalueMonad_base_monad_traces_lift P R X X0)).
Defined.

(* similarly as above, when we have when we have x0 : T, and f : nat -> T -> M T,
   we can apply primitive recursion and get a sequence of M T.
   Note that this does not contain any information of paths. *)
Definition M_sets :
  forall P : nat -> Type,
  forall R : (forall n, P n -> P (S n) -> Prop),
    M (P O) ->
    (forall n (x : P n), M {y : P (S n) | R n x y}) ->
    forall n, M (P n).
Proof.
  intros P R X f.
  apply nat_rect.
  exact X.
  intros.
  pose proof (f n).
  apply (Monad_fun_map_dom _ (P n)).
  intro.
  exact (M_projP1 _ _ (X1 X2)).
  exact X0.
Defined.

(* given a collection of sections, get the retraction. *)
Definition M_retraction : forall P : nat -> Type,
    M (forall n, P n) -> (forall n, M (P n)).
Proof.
  intros P X n.
  apply (Monad_fun_map _ _ (fun f => f n) X).
Defined.

(* the axiomatized property of pathsM. When we obtain a set of
   paths from a procedure, when we get the retraction, make the sequences of sets,
   it has to be identical to the one obtained by M_sets *)
Lemma M_paths_prop : forall P R X f, M_retraction _ (M_projP1 _ _ (M_paths P R X f)) = M_sets P R X f.
Proof.
  intros.
  unfold M_paths.
  destruct ((MultivalueMonad_base_monad_traces_lift P R X f)).
  simpl.
  exact e.
Qed.

(* A special use case of pathsM: when we have a sequence of sets f : forall n, M (P n),
   we can get the set of sections M (forall n, P n) *)
Definition M_countable_lift : forall P : nat -> Type, (forall n, M (P n)) -> M (forall n, P n).
Proof.
  intros P f.
  pose proof (M_paths P (fun _ _ _ => True) (f O)).
  simpl in X.
  assert ((forall n : nat, P n -> M {_ : P (S n) | True})).
  intros.
  pose proof (f (S n)).
  apply (Monad_fun_map (P (S n))).
  intro.
  exists X2.
  exact I.
  exact X1.
  pose proof (X X0).
  exact (M_projP1 _ _ X1).
Defined.

(* The property of countable lifting. It is the section of the retraction. *)
Lemma M_countable_lift_prop : forall P : nat -> Type, forall f,
      M_retraction P  (M_countable_lift P f) = f.
Proof.
  intros P f.
  unfold M_countable_lift.
  rewrite (M_paths_prop _ _ (f 0) (fun n _ => Monad_fun_map _ _ (fun X2 => exist _ X2 I) (f (S n)))).
  apply dfun_ext.
  intro.
  unfold M_sets.
  induction x.
  simpl.
  auto.
  simpl.
  rewrite IHx.
  simpl.
  unfold M_projP1,lifted_projP1,  Monad_fun_map_dom.

  assert (Monad_fun_map _ _  (fun X0 : {_ : P (S x) | True} => let (x0, _) := X0 in x0)
                (Monad_fun_map _ _ (fun X0 : P (S x) => exist _ X0 I) (f (S x))) = f (S x)).
  pose proof (Monad_functorial_comp _ _ _
                           (fun X0  => exist _ X0 I)
                           (fun X0 : {_ : P (S x) | True} => let (x0, _) := X0 in x0)).
  apply (lp  _ _ (fun k => k (f (S x)))) in H.
  rewrite <- H, <- Monad_functorial_id.

  exact eq_refl.

  rewrite H.
  assert ((Monad_fun_map (P x) (M (P (S x))) (fun _ : P x => f (S x)) (f x)) = Monad_unit _ (f (S x))).
  rewrite Monad_fun_map_const_is_const.
  exact eq_refl.
  rewrite H0, Monad_coh1.
  exact eq_refl.
Defined.

(* when we have two kleeneans that at least one of are True classically,
   we can nondeterministically decide which holds. *)
Definition select : forall x y : K, lazy_bool_up _ x \/ lazy_bool_up _ y -> M ({ (lazy_bool_up _ x) } + { (lazy_bool_up _ y) }).
Proof.
  apply multivalued_choice.
Defined.

(* when there is p -> T and q -> T, we can nondeterministically join them *)
Definition mjoin (p q : Prop) (T : Type) : ({p}+{q} -> T) ->  M ({p}+{q}) -> M T.
Proof.
  intros f x.
  exact (Monad_fun_map _ _ f x).
Defined.

(* semideciability so that we can work on Prop directly, without mentioning K *)
Definition semidec := fun P : Prop => {x : K | lazy_bool_up _ x <-> P}.

Definition choose : forall p q, semidec p -> semidec q -> p \/ q -> M ({p}+{q}).
Proof.
  intros.
  destruct X.
  destruct X0.
  destruct i.
  destruct i0.
  apply (Monad_fun_map ({lazy_bool_up _ x} + {lazy_bool_up _ x0})).
  intro.
  destruct H4; auto.
  apply select.
  destruct H; auto.
Defined.

Definition dec := fun P : Prop =>  {P} + {~ P}.
Lemma semidec_dec : forall P, semidec P -> semidec (~ P) -> dec P.
Proof.
  intros P p q.
  pose proof (choose _ _ p q (lem P)).
  apply M_hprop_elim_f.

  intros t1 t2.
  destruct t1, t2.
  induction (irrl _ p0 p1);
    auto.
  induction (n p0).
  induction (n p0).
  induction (irrl _ n n0); auto.
  exact X.
Defined.

Definition M_extension : forall A B, M (A -> B) -> (M A -> M B).
Proof.
  intros.
  apply (Monad_fun_map_dom _ A).
  intro.
  apply (Monad_fun_map (A ->B)).
  auto.
  auto.
  auto.
Defined.

Lemma semidec_or P Q : semidec P -> semidec Q -> semidec (P \/ Q).
Proof.
  intros.
  destruct X as [k1 e1].
  destruct X0 as [k2 e2].
  exists (lazy_bool_or k1 k2).
  split; intro p.
  unfold lazy_bool_up in p.
  rewrite lazy_bool_or_up in p.
  destruct p as [H | H].
  left; apply proj1 in e1; apply e1, H.
  right; apply proj1 in e2; apply e2, H.
  unfold lazy_bool_up.
  rewrite lazy_bool_or_up.
  destruct p as [H | H].
  left; apply proj2 in e1; apply e1, H.
  right; apply proj2 in e2; apply e2, H.
Defined.

Lemma semidec_and P Q : semidec P -> semidec Q -> semidec (P /\ Q).
Proof.
  intros.
  destruct X as [k1 e1].
  destruct X0 as [k2 e2].
  exists (lazy_bool_and k1 k2).
  split; intro p.
  unfold lazy_bool_up in p.
  rewrite lazy_bool_and_up in p.
  destruct p as [H H1].
  split.
  apply proj1 in e1; apply e1, H.
  apply proj1 in e2; apply e2, H1.
  unfold lazy_bool_up.
  rewrite lazy_bool_and_up.
  destruct p as [H H1].
  split.
  apply proj2 in e1; apply e1, H.
  apply proj2 in e2; apply e2, H1.
Defined.

Notation "[ x | P ]" := (M {x | P}) : type_scope.
Notation "[ x : T | P ]" := (M {x : T | P}) : type_scope.
Notation "[ ( a , b ) | P ]" := (M (sigT (fun a => {b | P}))) : type_scope.

(* Lemma M_unit_is_mono : forall A x y, Monad_unit A x = Monad_unit A y -> x = y. *)
(* Proof. *)
(*   intros. *)
(*   pose (f := (fun a => a = x)). *)
(*   assert (f x <> f y). *)
(*   simpl. *)
(*   unfold f. *)
(*   Check f. *)
(*   destruct f. *)
(*   f. *)

Definition Mand : M Prop -> Prop.
Proof.
  intro.
  exact (X = Monad_unit _ True).
Defined.

Definition Mor : M Prop -> Prop.
Proof.
  intro.
  exact (~ (X = Monad_unit _ False)).
Defined.

Lemma Mor_is_retract : forall P : Prop, Mor (Monad_unit _ P) = P.
Proof.
  intro P.
  destruct (lem P).
  unfold Mor.
  assert (e : P = True) by (apply Prop_ext; auto).
  rewrite e.
  apply Prop_ext.
  intro; auto.
  intro.
  intro.
  apply M_unit_is_mono in H1.
  rewrite <- H1; auto.
  apply Prop_ext.
  intro; auto.
  unfold Mor in H0.
  assert (P = False).
  apply Prop_ext; intro; auto.
  contradict H1.
  rewrite H1 in H0.
  contradict H0; auto.
  intro.
  contradict (H H0).
Defined.

Lemma Mand_is_retract : forall P : Prop, Mand (Monad_unit _ P) = P.
Proof.
  intro P.
  destruct (lem P).
  unfold Mand.
  assert (e : P = True) by (apply Prop_ext; auto).
  rewrite e.
  apply Prop_ext; intro; auto; auto.
  assert (e : P = False); apply Prop_ext; intro ; auto.
  contradict H0.
  rewrite e in H0.
  unfold Mand in H0.
  pose proof(M_unit_is_mono _ _ _ H0).
  assert False by (rewrite H1; auto).
  contradict H2.
  rewrite e in H0; contradict H0.
Defined.

Definition M_all {A} (P : A -> Prop) : M A -> Prop := fun X => Mand (Monad_fun_map _ _ P X).
Definition M_some {A} (P : A -> Prop) : M A -> Prop := fun X => Mor (Monad_fun_map _ _ P X).
Definition M_in {A} (a : A) (X : M A) : Prop := M_some (fun b => a = b) X.

Lemma sigma_eqP2_2 : forall (A : Type) (P : A -> Prop) (X Y : {a : A | P a}),  projP1 _ _ X = projP1 _ _  Y -> X = Y.
Proof.
  intros.
  destruct X, Y.
  apply (sigma_eqP A P _ _ _ _  H).
  apply irrl.
Defined.

Definition M_ext : forall A (X Y : M A), (M_picture_1 X = M_picture_1 Y) -> X = Y.
Proof.
  intros.
  apply (MultivalueMonad_description_is_mono A X Y).
  unfold M_picture_1 in H.
  apply sigma_eqP2_2.
  auto.
Defined.

Definition M_in_destruct : forall A, forall X : M A, M {x : A | M_in x X}.
  intros.
  unfold M_in.
  unfold M_some.
  unfold Mor.
  pose proof (MultivalueMonad_destruct _ X).
  fold (M_picture_1 X) in X0.
  apply (fun f => Monad_fun_map _ _ f X0).
  intro.
  destruct X1.
  exists x.
  intro.
  pose proof (M_fun_cont_r (fun b : A => x = b) X x m).
  rewrite H in H0.
  pose proof (@Monoid_hom_unit _ _ _ _ (MultivalueMonad_description) Prop).
  apply (lp _ _ (fun g => g False)) in H1.
  apply (lp _ _ (projP1 _ _ )) in H1.
  unfold M_picture_1, M_description in H0.
  rewrite H1 in H0.
  simpl in H0.
  rewrite <- H0; auto.
Defined.

Lemma M_picture_1_destruct : forall A a b, M_picture_1 (Monad_unit A a) b -> a = b.
Proof.
  intros.
  pose proof (@Monoid_hom_unit _ _ _ _ (MultivalueMonad_description) A).
  apply (lp _ _ (fun g => g a)) in H0.
  apply (lp _ _ (projP1 _ _ )) in H0.
  unfold M_picture_1, M_description in H.
  rewrite H0 in H.
  simpl in H.
  rewrite H; auto.
Defined.

Lemma M_picture_1_intro : forall A a b, a = b -> M_picture_1 (Monad_unit A a) b.
Proof.
  intros.
  rewrite H.
  pose proof (@Monoid_hom_unit _ _ _ _ (MultivalueMonad_description) A).
  apply (lp _ _ (fun g => g b)) in H0.
  apply (lp _ _ (projP1 _ _ )) in H0.
  unfold M_picture_1, M_description.
  rewrite H0.
  simpl.
  auto.
Defined.

Lemma M_in_picture_1 : forall {A} (a : A) (X : M A), M_in a X = M_picture_1 X a.
Proof.
  intros.
  apply Prop_ext; intro.
  unfold M_in, M_some, Mor in H.
  destruct (lem ( M_picture_1 X a)); auto.
  contradict H.
  apply M_ext.
  apply fun_ext; intro.
  destruct (lem x).
  assert (x = True) by (apply Prop_ext; intro; auto).
  induction (eq_sym H1).
  pose proof (M_fun_cont (fun b : A => a = b) X True).
  rewrite H2.
  apply Prop_ext; intro.
  destruct H3.
  destruct H3.
  contradict H0.
  assert (j : a = x) by (rewrite <- H4; auto); rewrite j; auto.
  apply M_picture_1_destruct in H3.
  contradict H3; intro j; rewrite j; auto.
  assert (x = False).
  (apply Prop_ext; intro; auto).
  contradict H1.
  induction (eq_sym H1).
  clear H H1.
  pose proof (M_fun_cont (fun b : A => a = b) X False).
  rewrite H.
  apply Prop_ext; intro.
  apply M_picture_1_intro; auto.
  unfold M_picture_1 in H0.
  unfold M_picture_1.
  destruct (M_description A X).
  destruct e.

  exists x0.
  split; auto.
  simpl in H0.
  assert (a <> x0).
  intro.
  induction H2.
  exact (H0 x1).
  apply Prop_ext; intro; auto.
  contradict H3.

  unfold M_in, M_some, Mor.
  intro.
  pose proof (M_fun_cont (fun b : A => a = b) X True).
  rewrite H0 in H1.
  assert ( (exists a0 : A, M_picture_1 X a0 /\ True = (a = a0))).
  exists a; split; auto.
  apply Prop_ext; intro; auto.
  rewrite <- H1 in H2.
  apply M_picture_1_destruct in H2.
  rewrite H2; auto.
Defined.

Lemma M_all_picture_1 : forall A (P : A -> Prop) (X : M A), M_all P X = forall a, M_picture_1 X a -> P a.
Proof.
  intros.
  unfold M_all, Mand.
  apply Prop_ext; intros.
  pose proof (M_fun_cont_r P X a H0).
  rewrite H in H1.
  apply M_picture_1_destruct in H1.
  rewrite<- H1; auto.

  apply M_ext.
  apply fun_ext.
  intro; apply Prop_ext; intro.
  apply M_picture_1_intro.
  pose proof (M_fun_cont P X x).
  rewrite H1 in H0.
  destruct H0.
  destruct H0.
  pose proof (H _ H0).
  assert (P x0 = True).
  apply Prop_ext; intro; auto.
  rewrite H4 in H2.
  auto.
  apply M_picture_1_destruct in H0.
  rewrite <- H0.

  pose proof (M_fun_cont P X True).
  rewrite H1.
  apply M_hprop_elim_f.
  intros y z; apply irrl.
  apply (fun j => Monad_fun_map _ _ j (MultivalueMonad_destruct _ X)).
  fold (M_picture_1 X).
  intro.
  destruct X0.
  exists x0; auto.
  split; auto.
  pose proof (H _ m).
  apply Prop_ext; intro; auto.
Defined.

Lemma classical_tautology_neg_and : forall P Q, (~(P /\ Q)) = ((~ P) \/ (~ Q)).
Proof.
  intros.
  apply Prop_ext.
  intro.
  destruct (lem P).
  destruct (lem Q).
  contradict H; auto.
  right; auto.
  left; auto.
  intro.
  destruct H.
  contradict H.
  destruct H; auto.
  contradict H.
  destruct H; auto.
Defined.

Lemma classical_tautology_neg_or : forall P Q, (~(P \/ Q)) = ((~ P) /\ (~ Q)).
Proof.
  intros.
  apply Prop_ext.
  intro.
  destruct (lem P).
  contradict H; auto.
  destruct (lem Q).
  contradict H; auto.
  auto.
  intro.
  destruct H.
  intro.
  destruct H1.
  contradiction (H H1).
  contradiction (H0 H1).
Defined.

Lemma classical_tautology_dneg : forall P : Prop, (~ ~ P) = P.
Proof.
  intros.
  apply Prop_ext.
  intro.
  destruct (lem (P)); auto.
  contradiction (H H0).
  intro.
  auto.
Defined.

Lemma classical_tautology_contra : forall P Q : Prop, (P -> Q) = ((~ Q) -> (~ P)).
Proof.
  intros.
  apply Prop_ext.
  intros.
  destruct (lem (P)); auto.
  intros.
  destruct (lem (Q)); auto.
  contradiction (H H1 H0).
Defined.

Lemma classical_tautology_neg_all : forall A (P : A -> Prop), (~ (forall x : A, P x)) = (exists x : A, ~ P x).
Proof.
  intros.
  apply Prop_ext.
  rewrite classical_tautology_contra.
  rewrite classical_tautology_dneg.
  intros.
  destruct (lem (P x)); auto.
  contradict H.
  exists x; auto.
  intros.
  destruct H.
  intro.
  contradiction (H (H0 x)).
Defined.

Lemma classical_tautology_neg_some : forall A (P : A -> Prop), (~ (exists x : A, P x)) = (forall x : A, ~ P x).
Proof.
  intros.
  apply Prop_ext.
  (* rewrite classical_tautology_contra. *)
  (* rewrite classical_tautology_dneg. *)
  intros.
  destruct (lem (P x)); auto.
  contradict H.
  exists x; auto.
  intros.
  intro.
  destruct H0.
  contradiction ((H x) H0).
Defined.

Lemma classical_tautology_False : forall P : Prop, (~ P) -> P = False.
Proof.
  intros.
  apply Prop_ext; intro; auto.
  contradiction H0.
Defined.

Lemma classical_tautology_True : forall P : Prop, P -> P = True.
Proof.
  intros.
  apply Prop_ext; intro; auto.
Defined.

Lemma M_some_picture_1 : forall A (P : A -> Prop) (X : M A), M_some P X = exists a, M_picture_1 X a /\ P a.
Proof.
  intros.
  unfold M_some, Mor.
  apply Prop_ext.
  rewrite classical_tautology_contra.
  intros.
  rewrite classical_tautology_neg_some in H.
  intro.
  contradict H0.
  apply M_ext.
  apply fun_ext; intro.
  apply Prop_ext; intro.
  rewrite (M_fun_cont P X x) in H0.
  destruct H0.
  destruct H0.
  pose proof (H x0).
  rewrite (classical_tautology_neg_and) in H2.
  destruct H2.
  contradiction (H2 H0).
  rewrite (classical_tautology_False _ H2) in H1.
  rewrite H1.
  apply  (M_picture_1_intro); auto.

  apply (M_picture_1_destruct) in H0.
  rewrite <- H0.
  rewrite (M_fun_cont P X False).
  destruct (M_W_destruct X).
  pose proof (H x0).
  exists x0.
  split; auto.
  rewrite (classical_tautology_neg_and) in H2.
  destruct H2.
  contradiction (H2 H1).
  apply eq_sym, classical_tautology_False; auto.

  intro.
  intro.
  apply (lp _ _ M_picture_1) in H0.
  pose proof (M_fun_cont P X True).
  rewrite H0 in H1.
  assert ((exists a : A, M_picture_1 X a /\ True = P a)).
  destruct H.
  exists x.
  destruct H ; split; auto.
  apply eq_sym, classical_tautology_True; auto.
  rewrite <- H1 in H2.
  apply M_picture_1_destruct in H2.
  rewrite H2; auto.
Defined.

Definition M_retraction_T : forall A (P : A -> Type),
    M (forall n, P n) -> (forall n, M (P n)).
Proof.
  intros A P X n.
  apply (Monad_fun_map _ _ (fun f => f n) X).
Defined.

Lemma M_existence_to_all : forall A (P : A -> Prop), M {x | P x} -> {x : M A | M_all P x}.
Proof.
  intros.
  exists (M_projP1 _ _  X).
  unfold M_all.
  unfold Mand.
  unfold M_projP1.
  pose proof (Monad_functorial_comp _ _ _ ((fun X0 : {x : A | P x} => let (x, _) := X0 in x)) P ).
  apply (lp _ _ (fun g => g X)) in H.
  rewrite <- H.
  assert ((fun x : {x : A | P x} => P (let (x0, _) := x in x0)) = fun _ : {x : A | P x} => True).
  apply fun_ext; intro x; destruct x;  simpl; auto.
  apply Prop_ext; intro; auto.
  rewrite H0.
  rewrite (@Monad_fun_map_const_is_const ).
  auto.
Defined.

Lemma M_all_to_existence : forall A (P : A -> Prop), {x : M A | M_all P x} ->  M {x | P x}.
Proof.
  intros.
  destruct X.
  unfold M_all in m.
  unfold Mand in m.
  pose proof (MultivalueMonad_destruct _ x).
  fold (M_picture_1 x) in X.
  apply (fun f => Monad_fun_map _ _ f X).
  intro.
  destruct X0.
  exists x0.
  pose proof (M_fun_cont_r P x _ m0).
  rewrite m in H.
  apply M_picture_1_destruct in H.
  rewrite <- H; auto.
Defined.

Definition M_all_destruct : forall {A} {P : A -> Prop} {X x}, M_all P X -> M_in x X -> P x.
Proof.
  intros.
  rewrite (M_all_picture_1 A P X) in H.
  rewrite M_in_picture_1 in H0.
  exact (H _ H0).
Defined.

Definition M_all_destruct_2 : forall {A B} {P : A -> B -> Prop} {X Y x y},
    M_all (fun a => M_all (fun b => P a b) Y) X -> M_in x X -> M_in y Y -> P x y.
Proof.
  intros.
  rewrite (M_all_picture_1 A _ X) in H.
  rewrite M_in_picture_1 in H0.
  pose proof (H _ H0).
  rewrite (M_all_picture_1 B _ Y) in H2.
  rewrite M_in_picture_1 in H1.
  pose proof (H2 _ H1).
  exact H3.
Defined.

Definition countable_selection (P : nat -> Type) (f : forall n, M (P n)) : M {s : forall n, P n | forall n, M_in (s n) (f n)}.
Proof.

  pose proof (M_paths P (fun n _ y => M_in y (f (S n))) (f 0)).
  simpl in X.
  assert ((forall n : nat, P n -> M {y : P (S n) | M_in y (f (S n))}) ).
  intros.
  pose proof (MultivalueMonad_destruct _(f (S n))).
  fold (M_picture_1 (f (S (n)))) in X1.
  apply (fun j => Monad_fun_map _ _ j X1).
  intro.
  destruct X2.
  exists x.
  rewrite M_in_picture_1.
  exact m.
  apply X in X0.

  pose proof (MultivalueMonad_destruct _ (f O)).
  fold (M_picture_1 (f 0)) in X1.
  apply (fun j => Monad_fun_map_dom _ _ _ j X0).
  intro.
  apply (fun j => Monad_fun_map _ _ j X1).
  intro.
  destruct X2, X3.

  exists (fun n => match n with O => x0 | S m => x (S m) end).
  intro.
  destruct n.
  rewrite M_in_picture_1; auto.
  exact (m n).
Defined.

End M_Defs.


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

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

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

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  zNil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Theorem plus_comm: forall (n m: natural), plus n m = plus m n.
Proof.
  induction n; induction m.
  { simpl. rewrite IHn. rewrite <- IHm. simpl. rewrite IHn. reflexivity. }
  { simpl. rewrite IHn. simpl. reflexivity. }
  { simpl. rewrite <- IHm. simpl. reflexivity. }
  { reflexivity. }
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (len (qreva x y)) (plus (len x) (len y)).
Proof.
  induction x; induction y; simpl; try reflexivity.
  +
    rewrite plus_comm. simpl.
    rewrite IHx. simpl. rewrite plus_comm.
    simpl. reflexivity.
  +
    rewrite plus_comm. simpl. rewrite IHx.
lfind.
Admitted.


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

Require Import Nat.

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

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

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

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

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

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

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

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

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

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

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

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

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


(* * Peano Arithmetic *)
(* ** Axioms of Robinson Arithmetic *)
Require Export Undecidability.FOL.Arithmetics.FA.
Import Vector.VectorNotations.
Require Import List.

Definition ax_zero_succ := ∀  (zero == σ var 0 → falsity).
Definition ax_succ_inj :=  ∀∀ (σ $1 == σ $0 → $1 == $0).

(* Robinson Arithmetic *)
Definition ax_cases := ∀ $0 == zero ∨ ∃ $1 == σ $0.
Definition Q := FA ++ (ax_zero_succ::ax_succ_inj::ax_cases::nil).
Definition Qeq :=
  EQ ++ Q.


Require Export Iron.Language.SystemF2r.TyBase.
Require Export Iron.Language.SystemF2r.TyLift.
Require Import Coq.Logic.FunctionalExtensionality.

(********************************************************************)
(* Substitution of Types in Types. *)
Fixpoint substTT (d: nat) (u: ty) (tt: ty) : ty
 := match tt with
    | TVar ix
    => match nat_compare ix d with
       | Eq => u
       | Gt => TVar (ix - 1)
       | _  => TVar  ix
       end

    |  TCon _
    => tt

    |  TForall t
    => TForall (substTT (S d) (liftTT 1 0 u) t)

    |  TApp t1 t2
    => TApp (substTT d u t1) (substTT d u t2)
  end.

(********************************************************************)
(* Substitution and type utils *)
Lemma substTT_getCtorOfType
 :  forall d t1 t2 t3
 ,  getCtorOfType t2                = Some t3
 -> getCtorOfType (substTT d t1 t2) = Some t3.
Proof.
 intros. gen d t1 t3.
 induction t2; try burn.
Qed.
Hint Resolve substTT_getCtorOfType.

Lemma substTT_makeTApps
 :  forall d t2 t1 ts
 ,  substTT d t2 (makeTApps t1 ts)
 =  makeTApps (substTT d t2 t1) (map (substTT d t2) ts).
Proof.
 intros. gen d t2 t1.
 induction ts; try burn.
Qed.
Hint Rewrite substTT_makeTApps : global.

Lemma liftTT_makeTApps
 :  forall d n t1 ts
 ,  liftTT n d (makeTApps t1 ts)
 =  makeTApps (liftTT n d t1) (map (liftTT n d) ts).
Proof.
 intros. gen d n t1.
 induction ts; burn.
Qed.
Hint Rewrite liftTT_makeTApps : global.

Lemma takeTCon_substTT
 :  forall ix t1 tc t2
 ,  takeTCon t1                 = TCon tc
 -> takeTCon (substTT ix t2 t1) = TCon tc.
Proof.
 intros. gen ix t2.
 induction t1; burn.
Qed.

(********************************************************************)
Lemma substTT_wfT
 :  forall d ix t t2
 ,  wfT d t
 -> substTT (d + ix) t2 t = t.
Proof.
 intros. gen d ix t2.
 induction t; intros; inverts H; simpl; try burn.
  Case "TVar".
   lift_cases; burn.
Qed.
Hint Resolve substTT_wfT.

Lemma substTT_closedT_id
 :  forall d t t2
 ,  closedT t
 -> substTT d t2 t = t.
Proof.
 intros.
 rw (d = d + 0). eauto.
Qed.
Hint Resolve substTT_closedT_id.

(********************************************************************)
(* If we lift at depth d, this creates an empty space and
   substituting into it doens't do anything. *)
Lemma substTT_liftTT
 :  forall d t1 t2
 ,  substTT d t2 (liftTT 1 d t1) = t1.
Proof.
 intros. gen d t2.
 induction t1; intros; simpl; try burn.

 Case "TVar".
  lift_cases; unfold substTT;
   fbreak_nat_compare; burn.
Qed.
Hint Rewrite substTT_liftTT : global.

(********************************************************************)
(* Lifting after substitution,
   with the lifting at a lower index. *)
Lemma liftTT_substTT_1
 :  forall n n' t1 t2
 ,  liftTT 1 n (substTT (n + n') t2 t1)
 =  substTT (1 + n + n') (liftTT 1 n t2) (liftTT 1 n t1).
Proof.
 intros. gen n n' t2.
 induction t1; intros; simpl; try burn.

 Case "TVar".
  repeat (simpl; fbreak_nat_compare;
          try lift_cases; try intros); burn.

 Case "TForall".
  rewrite (IHt1 (S n) n').
  rewrite (liftTT_liftTT_11 0 n).
  burn.
Qed.

Lemma liftTT_substTT
 :  forall m n n' t1 t2
 ,  liftTT m n (substTT (n + n') t2 t1)
 =  substTT (m + n + n') (liftTT m n t2) (liftTT m n t1).
Proof.
 intros. gen n n'.
 induction m; intros; simpl.
  burn.

  rw (S m = 1 + m).
  rewrite <- liftTT_plus.
  rs.
  rw (m + n + n' = n + (m + n')).
  rewrite liftTT_substTT_1.
  burn.
Qed.
Hint Rewrite <- liftTT_substTT : global.

(********************************************************************)
(* Lifting after substitution,
   with the ligting at a higher index *)
Lemma liftTT_substTT'
 :  forall n n' t1 t2
 ,  liftTT 1 (n + n') (substTT n t2 t1)
 =  substTT n (liftTT 1 (n + n') t2) (liftTT 1 (1 + n + n') t1).
Proof.
 intros. gen n n' t2.
 induction t1; intros; try burn.

 Case "TVar".
  repeat ( unfold liftTT; unfold substTT; fold liftTT; fold substTT
         ; try lift_cases
         ; try fbreak_nat_compare
         ; intros); burn.

 Case "TForall".
  simpl. rewrite (IHt1 (S n) n').
  simpl. rewrite (liftTT_liftTT_11 0 (n + n')).
  burn.
Qed.

(********************************************************************)
(* Commuting substitutions. *)
Lemma substTT_substTT
 :  forall n m t1 t2 t3
 ,  substTT (n + m) t3 (substTT n t2 t1)
 =  substTT n (substTT (n + m) t3 t2)
              (substTT (1 + n + m) (liftTT 1 n t3) t1).
Proof.
 intros. gen n m t2 t3.
 induction t1; intros; try burn.

 Case "TVar".
  repeat (simpl; fbreak_nat_compare); burn.

 Case "TForall".
  simpl.
  rewrite (IHt1 (S n) m).
  rewrite (liftTT_substTT_1 0 (n + m)).
  rewrite (liftTT_liftTT_11 0 n).
  burn.
Qed.


From mathcomp Require Import ssreflect seq ssrfun ssrbool ssrnat.
From mf Require Import all_mf.
Require Import pointwise reals pseudo_metrics.
Require Import Reals Psatz Classical ChoiceFacts Morphisms ProofIrrelevance ProofIrrelevanceFacts.

Fact eq_sub T P (a b : {x : T | P x}) : a = b <-> projT1 a = projT1 b.
Proof.
  split=> [->//|]; move: a b => [a Pa] [b Pb] /= eqab.
  case: _ / eqab in Pb *; congr (exist _ _ _).
  exact/proof_irrelevance.
Qed.

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

Local Open Scope R_scope.
Local Open Scope metric_scope.
Section metrics.
  Class is_metric (M: Type) (d: M * M -> R) :=
    {
      positive: forall x y, 0 <= d(x, y);
      symmetric: forall x y, d(x, y) = d(y, x);
      reflects_equality: forall x y, d(x, y) = 0 <-> x = y;
      triangle_inequality: forall x y z, d(x, y) <= d(x, z) + d(z, y);
    }.
  Local Notation "d \is_metric" := (is_metric d) (at level 36).
  Local Notation "d \is_metric_on M" := (@is_metric M d) (at level 36).

  Context `{is_metric}.

  Lemma dst0_eq x y: d(x, y) = 0 <-> x = y.
  Proof. by apply reflects_equality. Qed.

  Global Instance m2pm: (d \is_pseudometric)%pmetric.
    split; first by apply positive.
    - exact symmetric.
    by move => x; apply/dst0_eq.
    exact triangle_inequality.
  Defined.

  Lemma dst_pos x y: 0 <= d (x,y).
  Proof. by apply dst_pos. Qed.

  Lemma dst_sym x y: d(x,y) = d(y,x).
  Proof. by apply dst_sym. Qed.

  Lemma dst_trngl z x y: d(x,y) <= d(x,z) + d(z,y).
  Proof. by apply dst_trngl. Qed.

  Implicit Types (x y z: M) (xn yn: sequence_in M).

  Notation limit := (limit d).

  Lemma lim_sing: limit \is_singlevalued.
  Proof.
    move => xn x y lim lim'.
    by apply dst0_eq, (lim_dst lim lim').
  Qed.

  Lemma lim_tpmn xn x: limit xn x <->
    (forall n, exists N, forall m, (N <= m)%nat -> d(x,xn m) <= /2 ^ n).
  Proof. exact/lim_tpmn. Qed.

  Lemma cond_eq_tpmn x y:
    (forall n, d(x,y) <= / 2 ^ n) -> x = y.
  Proof. by move => /dst0_tpmn/dst0_eq. Qed.
End metrics.
Notation "d \is_metric_on M" := (@is_metric M d) (at level 26): metric_scope.
Notation "d \is_metric" := (is_metric d) (at level 36): metric_scope.

Notation "xn \converges_to x \wrt d" := (limit d xn x) (at level 23): metric_scope.
Section limits.
  Context `{is_metric}.
  Lemma lim_lim xnk xn x: FunctionalCountableChoice_on nat ->
    (forall n, (xnk n) \converges_to (xn n) \wrt d) -> xn \converges_to x \wrt d ->
    exists mu, (fun n => xnk n (mu n)) \converges_to x \wrt d.
  Proof. by apply lim_lim_choice. Qed.
End limits.

Notation "A \dense_subset_wrt d" := (dense_subset d A) (at level 35): metric_scope.
Notation "xn \dense_wrt d":= (dense_sequence d xn) (at level 35): metric_scope.
Notation "xn \dense_sequence_wrt d":= (dense_sequence d xn) (at level 35): metric_scope.
Notation "A \closed_wrt d":= (closure d A) (at level 35): metric_scope.
Section sets.
  Context `{m: is_metric}.

  Lemma dns_tpmn (A: subset M):
    A \dense_subset_wrt d <-> forall x n, exists y, y \from A /\ d(x, y) <= /2^n.
  Proof. exact/dns_tpmn. Qed.

  Lemma dseq_dns (r: nat -> M):
    r \dense_wrt d <-> (codom (F2MF r)) \dense_subset_wrt d.
  Proof. exact/dseq_dns. Qed.

  Lemma dseq_tpmn (r: nat -> M):
    r \dense_wrt d <-> forall x n, exists m, d(x, r m) <= /2^n.
  Proof. exact/dseq_tpmn. Qed.

  Lemma subs_clos A: A \is_subset_of A \closed_wrt d.
  Proof. by apply subs_clos. Qed.

  Hypothesis (M_choice: FunctionalCountableChoice_on M).

  Lemma clos_spec A x:
    x \from A \closed_wrt d <-> exists (xn: sequence_in A), (ptw sval xn) \converges_to x \wrt d.
  Proof.
    rewrite ->clos_spec_choice; last exact/M_choice.
    split => [[xn [Axn prp]] | [xn prp]]; first by exists (fun n => exist _ _ (Axn n)).
    by exists (ptw sval xn); split => // n; apply/(svalP (xn n)).
  Qed.

  Lemma dns_clos A: A \dense_subset_wrt d <-> A \closed_wrt d === All.
  Proof. exact/dns_clos. Qed.
End sets.

Notation "xn \Cauchy_wrt d" := (xn \from Cauchy_sequences d) (at level 45): metric_scope.
Notation "xn \Cauchy_sequence_wrt d" := (xn \from Cauchy_sequences d) (at level 45): metric_scope.
Notation "xn \is_Cauchy_wrt d" := (xn \from Cauchy_sequences d) (at level 45): metric_scope.
Notation "xn \is_Cauchy_sequence_wrt d" :=
  (xn \from Cauchy_sequences d) (at level 45): metric_scope.
Notation "d \is_complete" := (complete d) (at level 45): metric_scope.
Notation "d \is_complete_metric" := (complete d) (at level 45): metric_scope.
Notation "xn \fast_Cauchy_wrt d" :=
  (xn \from fast_Cauchy_sequences d) (at level 45): metric_scope.
Notation "xn \fast_Cauchy_sequence_wrt d" :=
  (xn \from fast_Cauchy_sequences d) (at level 45): metric_scope.
Notation "xn \is_fast_Cauchy_sequence_wrt d" :=
  (xn \from fast_Cauchy_sequences d) (at level 45): metric_scope.
Notation "x \efficient_limit_of xn \wrt d" := (efficient_limit d xn x) (at level 45): metric_scope.
Section Cauchy_sequences.
  Local Open Scope pseudometric_scope.
  Context `{m: is_metric}.
  Implicit Types (x y z: M) (xn yn: sequence_in M).

  Lemma lim_cchy: dom (limit d) \is_subset_of (Cauchy_sequences d).
  Proof. by apply lim_cchy. Qed.

  Lemma fchy_cchy: fast_Cauchy_sequences d \is_subset_of Cauchy_sequences d.
  Proof. exact/fchy_cchy. Qed.

  Lemma cchy_tpmn xn: xn \Cauchy_sequence_wrt d <->
    (forall k, exists N, forall n m,
            (N <= n <= m)%nat -> d(xn n, xn m) <= /2^k).
  Proof. by apply cchy_tpmn. Qed.

  Lemma lim_evb xn mu (x: M):
    xn \converges_to x \wrt d -> eventually_big mu -> (xn \o_f mu) \converges_to x \wrt d.
  Proof. exact/lim_evb. Qed.

  Lemma cchy_evb xn mu: xn \Cauchy_wrt d -> eventually_big mu -> (xn \o_f mu) \Cauchy_wrt d.
  Proof. exact/cchy_evb. Qed.

  Lemma lim_eff_spec: efficient_limit d =~= (limit d)|_(fast_Cauchy_sequences d).
  Proof. by apply lim_eff_spec. Qed.

  Lemma lim_eff_lim : (limit d) \extends efficient_limit d.
  Proof. by apply lim_eff_lim. Qed.

  Lemma fchy_lim_eff: d \is_complete_metric ->
    fast_Cauchy_sequences d === dom (efficient_limit d).
  Proof. by apply fchy_lim_eff. Qed.

  Lemma lim_tight_lim_eff: (limit d) \tightens (efficient_limit d).
  Proof. by apply sing_exte_tight; [apply lim_sing | apply/lim_eff_lim]. Qed.

  Lemma lim_eff_sing: (efficient_limit d) \is_singlevalued.
  Proof.
    by apply/exte_sing; first apply lim_eff_lim; last apply lim_sing.
  Qed.

  Lemma cchy_eff_suff xn:
    (forall n m, (n <= m)%nat -> d (xn n, xn m) <= /2^n + /2^m) ->
    xn \fast_Cauchy_sequence_wrt d.
  Proof. by apply cchy_eff_suff. Qed.

  Hypothesis (nat_choice: FunctionalCountableChoice_on nat).
  Lemma cchy_fchy xn: xn \Cauchy_wrt d -> exists mu, (xn \o_f mu) \fast_Cauchy_sequence_wrt d.
  Proof. by apply cchy_fchy_choice, nat_choice. Qed.
End Cauchy_sequences.

Section continuity.
  Local Open Scope pseudometric_scope.
  Context `{m: is_metric}.
  Context `{m0: is_metric}.
  Context (f: M -> M0).

  Lemma cont_tpmn:
    f \continuous_wrt d \and d0 <-> forall x n, exists m, forall x', d (x, x') <= /2^m -> d0 (f x, f x') <= /2^n.
  Proof. exact/cont_tpmn. Qed.

  Lemma cntp_scntp: continuity_points d d0 f \is_subset_of sequential_continuity_points d d0 f.
  Proof. exact/cntp_scntp. Qed.

  Lemma cont_scnt: f \continuous_wrt d \and d0 -> f \sequentially_continuous_wrt d \and d0.
  Proof. exact/cont_scnt. Qed.

  Hypothesis (M_choice: FunctionalCountableChoice_on M).
  Lemma scnt_cont: f \sequentially_continuous_wrt d \and d0 -> f \continuous_wrt d \and d0.
  Proof. exact/scnt_cont_choice/M_choice. Qed.
End continuity.

Section sub_metrics.
  Context `{is_metric}.

  Definition sub_met (A: subset M) (p: {x | x \from A} * {x | x \from A}) := d(sval p.1, sval p.2).
  Arguments sub_met: clear implicits.

  Global Instance sub_metric (A: subset M):
    (sub_met A) \is_metric_on {x | x \from A}.
    rewrite /sub_met.
    destruct (sub_pseudo_metric A); intros.
    split => // x y; split => [dst | -> ] //.
    by apply eq_sub, dst0_eq.
  Defined.
End sub_metrics.


(*************************************************************************)
(** * Transition Systems (PFPL 5.1) *)
(*************************************************************************)

(* The beginning of Ch5 introduces general terminology for reasoning about
   the evaluation of programs.  We can capture the generality of these
   definition using Coq's module system. The following module type
   defines what it means to be a transition system in abstract terms.
 *)

Module Type TransitionSystem.
  Parameter SS : Set.
  Parameter state : SS -> Prop.

  Parameter final : SS -> Prop.
  Axiom final_state : forall s, final s -> state s.

  Parameter initial : SS -> Prop.
  Axiom initial_state : forall s, initial s -> state s.

  Parameter step : SS -> SS -> Prop.
  Axiom step_states : forall s1 s2, step s1 s2 -> state s1 /\ state s2.

  Axiom final_does_not_step : forall s, final s -> not (exists s', step s s').

End TransitionSystem.

(* Once we know what a transition system is, we can define terminolody
   and prove theorems in terms of the basic definitions above. *)

Module TransitionSystemProperties (TS : TransitionSystem).
  Import TS.

  Definition stuck (s : SS) :=
    not (final s) /\ not (exists s', step s s').

  (* The multistep relation describes a sequence of transitions. *)
  Inductive multistep : SS -> SS -> Prop :=
    | ms_refl : forall s, state s -> multistep s s
    | ms_step : forall s s' s'', step s s' -> multistep s' s'' -> multistep s s''.
  Hint Constructors multistep.

  Lemma multistep_transitive : forall s s' s'',
      multistep s s' -> multistep s' s'' -> multistep s s''.
  Proof.
    intros s s' s'' MS1 MS2.
    induction MS1; eauto.
  Qed.

  Lemma multistep_states : forall s1 s2, multistep s1 s2 -> state s1 /\ state s2.
  Proof.
    intros s1 s2 MS. induction MS. auto. split.
    destruct (step_states _ _ H). auto. destruct IHMS. auto.
  Qed.

  (* We say with this is a transition sequence if the first state
     is initial. *)
  Definition transition_sequence s s' (ms : multistep s s') := initial s.

  (* It is a maximial transition sequence if the last state doesn't step. *)
  Definition maximal_transition_sequence s s' (ms : multistep s s') :=
    initial s /\ not (exists s'', step s' s'').

  (* And a complete transition sequence if the last step is final *)
  Definition complete_transition_sequence s s' (ms : multistep s s') :=
    initial s /\ final s'.

End TransitionSystemProperties.


From Undecidability.Synthetic Require Import InformativeDefinitions DecidabilityFacts.

Set Implicit Arguments.

(* ** Pre-order properties *)

Section Properties.

  Variables (X : Type) (P : X -> Prop)
            (Y : Type) (Q : Y -> Prop)
            (Z : Type) (R : Z -> Prop).

  Fact ireduces_reflexive : P ⪯ᵢ P.
  Proof. exists (fun x => x); red; tauto. Qed.

  Fact ireduces_transitive : P ⪯ᵢ Q -> Q ⪯ᵢ R -> P ⪯ᵢ R.
  Proof.
    unfold inf_reduces, reduction.
    intros (f & Hf) (g & Hg).
    exists (fun x => g (f x)).
    intro; rewrite Hf, Hg; tauto.
  Qed.

  Fact ireduces_reduces : P ⪯ᵢ Q -> P ⪯ Q.
  Proof. intros (f & ?); exists f; auto. Qed.

  Fact reduces_ireduces : P ⪯ Q -> inhabited (P ⪯ᵢ Q).
  Proof. intros (f & ?); exists; exists f; auto. Qed.

  Fact reduces_ireduces_iff : P ⪯ Q <-> inhabited (P ⪯ᵢ Q).
  Proof.
    split.
    + apply reduces_ireduces.
    + intros []; apply ireduces_reduces; auto.
  Qed.

  (* ** An equivalent dependent definition *)

  Fact ireduces_dependent :
         (P ⪯ᵢ Q -> forall x, { y | P x <-> Q y })
       * ((forall x, { y | P x <-> Q y }) -> P ⪯ᵢ Q).
  Proof.
    unfold inf_reduces, reduction.
    split.
    + intros (f & Hf).
      intros x; exists (f x); auto.
    + intros f.
      exists (fun x => proj1_sig (f x)).
      intros; apply (proj2_sig (f x)).
  Qed.

End Properties.


(*********************************************)
(* This file is part of the 'Higman' contrib *)
(* file : higman.v                           *)
(* contains : proof of higman's lemma        *)
(*  based upon a proof by M.Seisenberger     *)
(* author : W.Delobel                        *)
(*********************************************)

Set Implicit Arguments.
Require Export inductive_wqo.
Require Export tree.
Require Export higman_aux.

Section higman.

Variable A : Set.
Variable leA : A -> A -> Prop.
Hypothesis eqA_dec : forall a a' : A, {a = a'} + {a <> a'}.
Hypothesis leA_dec : forall a a', {leA a a'} + {~ leA a a'}.
Hypothesis leA_trans : forall a a' a'', leA a a' -> leA a' a'' -> leA a a''.

Definition embeds : list A -> list A -> Prop := (higman_aux.embeds leA).
Definition sublist : list (list A) -> list (list A) -> Prop := (higman_aux.sublist (A:=A)).
Definition Tree := (higman_aux.Tree A).
Definition is_forest := (higman_aux.is_forest leA leA_dec).
Definition is_insert_forest := (higman_aux.is_insert_forest leA).
Definition is_insert_tree := (higman_aux.is_insert_tree leA).

Definition sub_seq_in_lbl (ws : list (list A)) (t : Tree) : Prop :=
forall vs l ts, t = node (vs,l) ts -> sublist (merge_label vs l) ws.

Lemma sub_seq_in_forest : forall ws f,
is_forest ws f -> P_on_forest sub_seq_in_lbl ws f.
Proof.
intros ws f Hws.
apply P_on_is_forest with leA leA_dec; intros.
(* P_added_node *)
unfold sub_seq_in_lbl; simpl; intros.
inversion H1; subst.
simpl.
constructor 3; trivial.
unfold sub_seq_in_lbl in H0; apply H0 with ts0; trivial.
(* P_added_node_base *)
unfold sub_seq_in_lbl; simpl; intros.
inversion H0; subst; destruct ws0; simpl; apply sublist_refl with (A:=A).
(* P_split *)
unfold sub_seq_in_lbl; simpl; intros.
inversion H1; subst.
unfold sub_seq_in_lbl in H; apply H with (t::ts); trivial.
(* P_merge *)
unfold sub_seq_in_lbl; simpl; intros.
inversion H1; subst.
unfold sub_seq_in_lbl in H; apply H with f0; trivial.
(* P_add *)
unfold sub_seq_in_lbl in *; simpl in *.
intros ws' l ts Ht; constructor 2; apply (H ws' l ts Ht).
apply Hws.
Qed.

Definition sorted_in_label (t : Tree) : Prop :=
forall vs l ts, t = node (vs, l) ts -> sorted leA l.

Lemma sorted_in_forest : forall ws f,
is_forest ws f -> forall t, tree_in_forest t f -> sorted_in_label t.
Proof.
intros ws f Hf.
assert (H : P_on_forest (fun (_:list (list A)) => sorted_in_label) ws f).
2 : intros t Ht; apply (H t Ht); trivial.
apply P_on_is_forest with leA leA_dec; intros; trivial.
(* P_added_node *)
destruct l as [|a' l].
	(* l = nil *)
intros vs' l' ts' H'; inversion H'; subst.
constructor 2.
	(* l <> nil *)
intros vs' l' ts' H'; inversion H'; subst.
constructor 3.
apply (H a' l vs ts'); trivial.
apply (H0 vs (a'::l) ts'); trivial.
(* P_added_node_base *)
intros vs' l' ts' H'; inversion H'; subst.
constructor 2.
(* P_split *)
intros vs' l' ts' H'; inversion H'; subst.
apply (H vs' l' (t::ts')); trivial.
(* P_merge *)
intros vs' l' ts' H'; inversion H'; subst.
apply (H vs' l' f0); trivial.
Qed.

Definition bad_seq_in_lbl (t : Tree) : Prop :=
forall vs l ts, t = node (vs,l) ts -> bad embeds vs.

Lemma bad_seqs_in_forest : forall ws, bad embeds ws ->
  forall f, is_forest ws f ->  forall t, tree_in_forest t f -> bad_seq_in_lbl t.
Proof.
intros ws Hws f Hf t Ht vs l ts H.
generalize (sorted_in_forest Hf Ht H); intro H2.
assert (H' : bad embeds (merge_label vs l)).
apply (bad_sublist (leA:=leA) (sub_seq_in_forest Hf Ht H)); trivial.
intro HF; apply H'.
apply good_merge with (leA:=leA); trivial.
Qed.

Definition ltF : list Tree -> list Tree -> Prop := fun f' => fun f => exists w, exists a,
is_insert_forest f w a f'  /\ (forall t, tree_in_forest t f' -> bad_seq_in_lbl t) /\ f<>f'.

Fact acc_ltF_nil : Acc ltF nil.
constructor; intros f Hf.
elim Hf; clear Hf; intros w H; elim H; clear H; intros a H;
elim H; clear H; intros H1 H; elim H; clear H; intros H2 H3.
inversion H1; subst.
elim H3; trivial.
Qed.

Fact acc_ltF_cons : forall f t, Acc ltF f -> Acc ltF (t::nil) -> Acc ltF (t::f).
Proof.
intros f t Acc_f; generalize t; clear t; induction Acc_f as [f acc_f IHf].
assert (H : forall f', Acc ltF f' -> forall t, f' = t::nil -> Acc ltF (t::f)).
2:intros; apply (H (t::nil)); trivial.
intros f' Hf'; induction Hf' as [f' acc_f' IHf'].
intros; constructor.
intros f'' H2.
elim H2; clear H2; intros w H2; elim H2; clear H2; intros a H2.
elim H2; clear H2; intros H2 H3; elim H3; clear H3; intros H3 H4.
inversion H2; subst.
(* case ~ leA a' a *)
apply IHf; trivial.
exists w; exists a; repeat split; trivial.
intros t Ht; apply (H3 t); trivial.
inversion Ht; subst.
constructor 1 with t'; trivial; try right; trivial.
intro; subst; apply H4; trivial.
constructor; apply acc_f'; trivial.
(* case leA a' a *)
apply IHf' with (t'::nil); trivial.
exists w; exists a; repeat split; trivial.
apply (is_if4 (leA := leA) (vs:=vs) (a':= a') (ts:=ts)); trivial.
intros u Hu; inversion Hu; subst.
apply (H3 u).
elim H; clear H; intro H.
subst t'0; constructor 1 with t'; try left; trivial.
inversion H.
intro H; subst; apply H4; inversion H; trivial.
Qed.

Lemma is_forest_roots_labels : forall ws f, is_forest ws f ->
roots_labels f = Some (bad_subsequence leA leA_dec (firsts ws)).
Proof.
intros ws f Hws; induction Hws; simpl; trivial.
elim (greater_dec leA leA_dec a (bad_subsequence leA leA_dec (firsts ws))); intro case_ws.
rewrite <- IHHws.
symmetry; generalize H0; apply is_insert_forest_same_roots.
elim case_ws; trivial.
rewrite IHHws; simpl.
elim (greater_dec leA leA_dec a (bad_subsequence leA leA_dec (firsts ws))); intro case_ws.
elim H; trivial.
trivial.
Qed.

Lemma acc_ltF_single : forall ws, Acc (continues embeds) ws ->
  forall l a bs, Acc (continues leA) bs ->
  forall ts, Acc ltF ts ->
  forall t, root t = (ws,a::l) /\ subtrees t = ts /\ Some bs = roots_labels ts ->
  Acc ltF (t::nil).
Proof.
intros ws acc_ws; induction acc_ws as [ws acc_ws IHws]; intros l a.
intros bs acc_bs; induction acc_bs as [bs acc_bs IHbs].
intros ts acc_ts; induction acc_ts as [ts acc_ts IHts].
intros t Ht; elim Ht; clear Ht; intros H1 H2; elim H2; clear H2; intros H2 H3.
constructor; intros f Hf.
elim Hf; clear Hf; intros wf Hf.
elim Hf; clear Hf; intros af Hf.
elim Hf; clear Hf; intros Hf1 Hf2.
elim Hf2; clear Hf2; intros Hf2 Hf3.
destruct f as [|t' f].
(* case nil *)
inversion Hf1.
(* case t' f *)
cut (f = nil).
intro; subst f.
inversion Hf1.
(* case ~ leA a' af *)
subst f w a0 t' t f'; clear H7.
elim Hf3; trivial.
(* case leA a' af *)
subst w a0 t' t f.
inversion H8; subst.
	(* case ~ greater af rrts *)
apply IHbs with (y := af::bs) (ts := node (wf :: vs, af :: a' :: l) ts0 :: ts0); trivial.
constructor.
simpl in H3.
rewrite H10 in H3; inversion H3; trivial.
apply acc_ltF_cons; trivial.
constructor; simpl in acc_ts; trivial.
simpl in H1; inversion H1; subst.
apply (IHws (wf::ws)) with (ts:= ts0) (bs := bs) (a:=af) (l:=a::l); trivial.

constructor; trivial.
intro HF; assert (Hbil : bad_seq_in_lbl (node (wf :: ws, af :: a :: l) ts0)).
apply (Hf2 (node (wf :: ws, af :: a :: l) ts0)); simpl.
constructor 1 with (node (ws, a :: l) (node (wf :: ws, af :: a :: l) ts0 :: ts0)); try left; trivial.
constructor 2.
constructor 1 with (node (wf :: ws, af :: a :: l) ts0); constructor; trivial.
	(* Hbil prooved *)
apply (Hbil (wf::ws) (af::a::l) ts0); trivial.
constructor; trivial.
constructor; apply acc_bs.
constructor; apply acc_ts.
simpl in *; repeat split; trivial.
inversion H1; subst; trivial.
repeat split; simpl; trivial.
simpl in H3; rewrite <- H3; simpl; trivial.

	(* case greater af rrts *)
apply IHts with (y := f'); trivial.
exists wf; exists af.
repeat split; simpl; trivial.
intros u Hu; apply (Hf2 u); inversion Hu; subst.
constructor 1 with (node (vs, a' :: l0) f'); try left; trivial.
constructor 2.
constructor 1 with t'; trivial.
intro; subst; apply Hf3; trivial.
repeat split; simpl; trivial.
simpl in H3; rewrite H3.
generalize H11; apply is_insert_forest_same_roots.
(* proof f = nil *)
destruct f; trivial.
inversion Hf1; subst.
inversion H7.
Qed.

Lemma higman_aux :
  forall bs, Acc (continues leA) bs ->
  forall f, Acc ltF f ->
  forall ws, bs = bad_subsequence leA leA_dec (firsts ws) /\ is_forest ws f ->
  bad embeds ws -> Acc (continues embeds) ws.
Proof.
intros bs acc_bs; induction acc_bs as [bs acc_bs IHbs].
intros f acc_f; induction acc_f as [f acc_f IHf].
intros ws H; elim H; clear H; intros H1 H2 H3.
constructor; intros ws' Hws'.
Unset Regular Subst Tactic.
inversion Hws'; subst.
Set Regular Subst Tactic.
induction a as [| a w IHw].
(* case nil *)
constructor; intros y Hy; inversion Hy; subst.
elim H0; constructor 1.
unfold embeds; apply (nil_embeds).
(* case <> nil *)
elim (greater_dec leA leA_dec a (bad_subsequence leA leA_dec (firsts ws))); intro case_a_bs.
(* case greater a badSub (Fsts ws) *)
elim (insert_forest_get a w H2); intros f' Hf'.
apply IHf with f'; trivial.
exists w; exists a; repeat split; trivial.
apply bad_seqs_in_forest with ((a::w)::ws); trivial.
intro HF; inversion HF; subst.
apply H; trivial.
apply H3; trivial.
constructor 2 with f; trivial.
apply (is_insert_forest_neq (leA:=leA) (leA_dec:=leA_dec)) with ws a w; trivial.
simpl; elim (greater_dec leA leA_dec a (bad_subsequence leA leA_dec (firsts ws))); intro c.
split; trivial.
constructor 2 with f; trivial.
elim c; trivial.
intro HF; inversion HF; subst.
apply H; trivial.
apply H3; trivial.

(* case ~ greater a badSub (Fsts ws) *)
apply IHbs with (y := a ::(bad_subsequence leA leA_dec (firsts ws)))
		(f := (node (w::ws, a::nil) f)::f); simpl; trivial.
constructor; trivial.
apply acc_ltF_cons.
constructor; apply acc_f.
apply acc_ltF_single with (w::ws) (nil (A:=A)) a (bad_subsequence leA leA_dec (firsts ws)) f; trivial.
apply IHw; trivial.
intros HF; apply H; generalize HF; apply (greater_remove_letter (leA:=leA)).
constructor.
intros HF; apply H; generalize HF; apply (greater_remove_letter (leA:=leA)).
constructor; apply acc_bs.
constructor; apply acc_f.
repeat split; trivial.
symmetry; apply is_forest_roots_labels; trivial.
elim (greater_dec leA leA_dec a (bad_subsequence leA leA_dec (firsts ws))); intro case';
	[elim case_a_bs | idtac]; trivial.
split; trivial.
constructor 3; trivial.
intro HF; inversion HF; subst.
apply H; trivial.
apply H3; trivial.
Qed.

Theorem Higman :
  Acc (continues leA) nil -> Acc (continues embeds) nil.
Proof.
intro wqo_leA; apply (higman_aux wqo_leA) with (f:=nil (A := Tree)).
apply acc_ltF_nil.
split; simpl; trivial.
unfold is_forest; constructor 1 with (leA := leA) (leA_dec := leA_dec).
intro HF; inversion HF; trivial.
Qed.

End higman.


From Coq Require Import ssreflect.
From stdpp Require Import base numbers.
From machine_utils Require Import finz_base solve_finz.

Lemma finz_add_0 fb (a : finz fb) :
  (a + 0)%f = Some a.
Proof. solve_finz. Qed.

Lemma finz_add_0_default fb (a : finz fb) :
  (a ^+ 0)%f = a.
Proof. solve_finz. Qed.

Lemma InBounds_sub fb (b e b' e' a : finz fb) :
  SubBounds b e b' e' →
  InBounds b' e' a →
  InBounds b e a.
Proof. intros (? & ? & ?) [? ?]. unfold InBounds. solve_finz. Qed.

(* -- tests -- promote to lemmas if needed *)

Goal forall fb (a : finz fb),
  (a + 1)%f = None ->
  (a:Z) = (fb - 1)%Z.
Proof. solve_finz. Qed.

Goal forall fb (a : finz fb) (n m : Z),
  (0 <= n)%Z ->
  (0 <= m)%Z ->
  ((a ^+ n) ^+ m)%f = (a ^+ (n + m)%Z)%f.
Proof. solve_finz. Qed.

Goal forall fb (a a' : finz fb),
  (a + 1)%f = Some a' →
  (a < a')%Z.
Proof. solve_finz. Qed.

Goal forall fb (a a' : finz fb) (i : Z),
  (i > 0)%Z →
  (a + i)%f = Some a' → (a < a')%Z.
Proof. solve_finz. Qed.

Goal forall fb (a a' : finz fb) (i : Z),
  (i >= 0)%Z →
  (a + i)%f = Some a' → (a <= a')%Z.
Proof. solve_finz. Qed.

Goal forall fb (a e : finz fb),
  (a < e)%Z → ∃ a', (a + 1)%f = Some a'.
Proof. intros. zify_finz; eauto. exfalso. lia. lia. Qed.

Goal forall fb (a e : finz fb),
  (a < e)%Z -> ∃ a', (a + 1)%f = Some a'.
Proof. intros. zify_finz; eauto. exfalso. lia. lia. Qed.

Goal forall fb (a e a' : finz fb),
  (a < e)%Z → (a + 1)%f = Some a' → (e < a')%Z → False.
Proof. solve_finz. Qed.

Goal forall fb (a e a' : finz fb),
  (a < e)%Z → (a + 1)%f = Some a' → (a' ≤ e)%Z.
Proof. solve_finz. Qed.

Goal forall fb (a e a' : finz fb),
  (a + 1)%f = Some a' → (a < e)%Z → (Z.abs_nat (e - a) - 1) = (Z.abs_nat (e - a')).
Proof. solve_finz. Qed.

Goal forall fb (a1 a2 a3 : finz fb) (z1 z2 : Z),
  (a1 + z1)%f = Some a2 → (a2 + z2)%f = Some a3 →
  (a1 + (z1 + z2))%f = Some a3.
Proof. solve_finz. Qed.

Goal forall fb (a a' : finz fb) (z1 z2 : Z),
  (a + z1)%f = Some a' →
  (a + (z1 + z2))%f = (a' + z2)%f.
Proof. solve_finz. Qed.

Goal forall fb (a1 a2 a3 : finz fb) (z1 z2 : Z),
  (a1 + z1)%f = Some a2 -> (a1 + z2)%f = Some a3 -> (z1 <= z2)%Z ->
  (a2 <= a3)%Z.
Proof. solve_finz. Qed.

Goal forall fb (a : finz fb) i k,
  (k >= 0)%Z -> (i >= 0)%Z ->
  (((a ^+ i) ^+ k)%f) =
  ((a ^+ (i + k)%Z)%f).
Proof. solve_finz. Qed.

Goal forall fb (a a' : finz fb),
  (a + 1)%f = Some a' →
  (a + 1)%Z = a'.
Proof. solve_finz. Qed.

Goal forall fb (a a' : finz fb) i,
  (a + i)%f = Some a' →
  (a + i)%Z = a'.
Proof. solve_finz. Qed.

Goal forall fb (a1 a2: finz fb) (z:Z),
      (a1 + z)%f = Some a2 → (a2 + (- z))%f = Some a1.
Proof. solve_finz. Qed.


Require Import FcEtt.imports.

(* Simple auxiliary functions *)

Definition zip : `{list A → list B → list (A * B)} :=
  fix zip _ _ a b :=
    match a, b with
      | nil, _ => nil
      | _, nil => nil
      | x :: xs, y :: ys => (x, y) :: zip _ _ xs ys
    end.

Fixpoint map_r {A B C} f (l : list (A * B)) : list (A * C):=
  match l with
    | [] => []
    | (h1, h2) :: tl => (h1, f h2) :: map_r f tl
  end.


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

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma rev_append : forall (x y : lst), rev (append x y) = append (rev y) (rev x).
Proof.
   intros.
   induction x.
   - simpl. rewrite append_nil. reflexivity.
   - simpl. rewrite IHx. lfind. Admitted.