Require Export BuildTac.

Set Implicit Arguments.

Unset Strict Implicit.

Lemma iU_eq_inv: forall x y : R,
 (0 <= x <= 1)%R ->
 (0 <= y <= 1)%R ->
 iU x == iU y ->
 x = y.
Proof.
 intros x y Hx Hy (H1,H2).
 apply Rle_antisym; apply iU_le_inv; trivial.
Qed.

Lemma iU_div_distr: forall x y,
 (0 <= x <= y)%R ->
 (0 < y <= 1)%R ->
 iU x / iU y <= iU (x / y).
Proof.
 intros x y [H1 H2] [H3 H4].
 assert (~0 == iU y).
 rewrite <-iU_0; intro Heq; apply iU_eq_inv in Heq.
 fourier.
 split; fourier.
 split; fourier.

 apply Umult_le_simpl_left with (1:=H).
 rewrite Umult_div; auto.
 rewrite <-iU_mult, Rmult_comm, Rdiv_mult; trivial.
 split; fourier.
 split; [apply Rdiv_pos | apply Rdiv_le_1]; fourier.
Qed.

Opaque sigma.

Lemma lub_Udiv: forall f x,
 (lub (c:=U) (sigma f)) / x  == lub (c:=U) (sigma (fdiv x f)).
Proof.
 intros.
 eapply Oeq_trans;
  [ apply (@lub_comp_eq _ _ (UDiv x) (sigma f) (Udiv_continuous _)) | ].
 apply lub_eq_compat; refine (ford_eq_intro _); intro n.
 simpl; induction n.
 rewrite sigma_0; auto.
 rewrite 2 sigma_S, Udiv_plus;
 apply Uplus_eq_compat; trivial.
Qed.

Transparent sigma.

Parameter Lsize : forall (k:nat), nat.

Parameter NChunks : forall (k:nat), nat.

Parameter Eps : forall (k:nat), R.

Variable eps_pos : forall k, (0 < Eps k)%R.

Hypothesis Lsize_pos : forall k, (0 < Lsize k)%nat.

Inductive uop : Type :=
 | N
 | Q
 | ODrop
 | OTake
 | OMapPlus.

Inductive usupport_ (T_type:Type)
 (T_Z:T_type) (T_List_Z:T_type) (E_expr:T_type ->Type) : T_type -> Type :=
 | Lap    : forall (i:E_expr T_Z), @usupport_ _ T_Z T_List_Z E_expr T_Z
 | MapLap : forall (l:E_expr T_List_Z), @usupport_ _ T_Z T_List_Z E_expr T_List_Z.

Fixpoint ListLaplace (eps:R) (l:list Z) {struct l} : Distr (list Z) :=
 match l with
  | nil => Munit nil
  | x::xs => Mlet (ListLaplace eps xs)
              (fun zs => Mlet (Laplace eps x) (fun z => Munit (z::zs)))
 end.

Lemma Laplace_lossless : forall (eps:R) (a:Z),
 mu (Laplace eps a) (fone _) == 1.
Proof.
  apply Laplace_lossless.
Qed.

Lemma ListLaplace_lossless : forall (eps:R),
 forall (l:list Z),
 mu (ListLaplace eps l) (fone _) == 1.
Proof.
 intros eps.
 induction l.
 trivial.
 rewrite <-IHl.
 simpl ListLaplace; rewrite Mlet_simpl.
 refine (mu_stable_eq _ _ _ _); refine (ford_eq_intro _); intro l'.
 rewrite Mlet_simpl.
 apply Laplace_lossless.
Qed.

Lemma Laplace_Discrete: forall (eps:R) (a:Z),
 is_Discrete (Laplace eps a).
Proof.
 apply Laplace_is_Discrete.
Qed.

Lemma ListLaplace_Discrete: forall (eps:R) (l: list Z),
 is_Discrete (ListLaplace eps l).
Proof.
 induction l; simpl.
 apply is_Discrete_Munit.
 apply (is_Discrete_Mlet _ IHl).
 intro; apply (is_Discrete_Mlet _ (Laplace_Discrete _ _)).
 intro; apply is_Discrete_Munit.
Qed.

Module Sem <: SEM.

(** * User-defined type module *)
Module UT <: UTYPE.

 Definition t := Empty_set.

 Definition eqb (x y:t) := true.

 Lemma eqb_spec : forall x y, if eqb x y then x = y else x <> y.
 Proof.
  intros x; case x.
 Qed.

 Definition eq_dec (x y:t) : {x = y} + {True}.
  intros; case x; case y.
 Defined.

 Lemma eq_dec_r : forall x y i, eq_dec x y = right _ i -> x <> y.
 Proof.
  intros x; case x.
 Qed.

 Definition interp (k:nat) (t0:t) : Type := Datatypes.unit.

 Definition size k (t0:t) (_:interp k t0) := S O.

 Definition default k (t0:t) : interp k t0 := tt.

 Definition default_poly (t0:t) := pcst 1.

 Lemma size_positive : forall k t0 (x:interp k t0), (0 < size x)%nat.
 Proof.
  intros; unfold size; auto with arith.
 Qed.

 Lemma default_poly_spec : forall k (t0:t),
  (size (default k t0) <= peval (default_poly t0) k)%nat.
 Proof.
  intros; unfold size, default, default_poly.
  rewrite pcst_spec; trivial.
 Qed.

 Definition i_eqb k t (_:interp k t) (_:interp k t) := true.

 Lemma i_eqb_spec : forall k t (x y:interp k t),
  if i_eqb x y then x = y else x <> y.
 Proof.
  intros; unfold i_eqb; case x; case y; trivial.
 Qed.

End UT.

Module T := MakeType UT.

(** * Module for user-defined operators *)
Module Uop <: UOP UT T.

 Definition t := uop.

 Definition eqb (o1 o2:t) : bool :=
  match o1, o2 with
   | N, N => true
   | Q, Q => true
   | ODrop, ODrop => true
   | OTake, OTake => true
   | OMapPlus, OMapPlus => true
   | _, _ => false
   end.

 Lemma eqb_spec :  forall x y, if eqb x y then x = y else x <> y.
 Proof.
  destruct x; destruct y; simpl; (trivial || discriminate).
 Qed.

 Definition targs (op : t) : list T.type :=
  match op with
   | N => nil
   | Q => nil
   | ODrop => (T.List T.Zt) :: nil
   | OTake => (T.List T.Zt) :: nil
   | OMapPlus => T.Zt :: (T.List T.Zt) :: nil
  end.

 Definition tres (op: t) : T.type :=
  match op with
   | N => T.Nat
   | Q => T.Nat
   | ODrop => T.List T.Zt
   | OTake => T.List T.Zt
   | OMapPlus => T.List T.Zt
  end.

 Definition interp_op (k:nat) (op:t) : T.type_op k (targs op) (tres op) :=
  match op as op0 return T.type_op k (targs op0) (tres op0) with
   | N => Lsize k
   | Q => NChunks k
   | ODrop => @skipn Z (Lsize k)
   | OTake => @firstn Z (Lsize k)
   | OMapPlus => (fun n l => map (Zplus n) l)
 end.

 Implicit Arguments interp_op [k].

 Definition cinterp_op (k:nat) (op:t) : T.ctype_op k (targs op) (tres op) :=
  match op as op0 return T.ctype_op k (targs op0) (tres op0) with
   | N => (Lsize k, S O)
   | Q => (NChunks k, S O)
   | ODrop => fun l => (@skipn Z (Lsize k) l,
                        T.size k (T.List T.Zt) (firstn (Lsize k) l))
   | OTake => fun l => (@firstn Z (Lsize k) l,
                        T.size k (T.List T.Zt) (firstn (Lsize k) l))
   | OMapPlus => fun n l => (map (Zplus n) l, T.size k (T.List T.Zt) l)
 end.

 Implicit Arguments cinterp_op [k].

 Definition eval_op k
  (op:t) (args:dlist (T.interp k) (targs op)) : T.interp k (tres op) :=
  @T.app_op k (targs op) (tres op) (interp_op op) args.

 Definition ceval_op k
  (op:t) (args:dlist (T.interp k) (targs op)) : T.interp k (tres op) * nat :=
  @T.capp_op k (targs op) (tres op) (cinterp_op op) args.

 Lemma ceval_op_spec : forall k op args,
  @eval_op k op args = fst (@ceval_op k op args).
 Proof.
  intros k o args; destruct o; simpl in args;
   T.dlist_inversion args; subst; simpl; trivial.
 Qed.

End Uop.

Module Var := MakeVar UT T.

Module Proc := MakeProc UT T.

Module O := MakeOp UT T Uop.

Module Mem := MakeMem UT T Var.

Module E := MakeExpr UT T Var Mem Uop O.

Module US <: USUPPORT UT T Var Mem Uop O E.

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

 Definition usupport := usupport_ T.Zt (T.List T.Zt) E.expr .

 Definition eval k t (s:usupport t) (m:Mem.t k) : Distr (T.interp k t) :=
  match s with
   | Lap a => Laplace (Eps k) (E.eval_expr a m)
   | MapLap l => ListLaplace (Eps k) (E.eval_expr l m)
  end.

 Definition ceval k t (s:usupport t) (m:Mem.t k) : Distr (T.interp k t) * nat :=
  match s with
   | Lap a => (Laplace (Eps k) (E.eval_expr a m), T.size k T.Zt (E.eval_expr a m))
   | MapLap l => (ListLaplace (Eps k) (E.eval_expr l m),
                  T.size k (T.List T.Zt) (E.eval_expr l m))
  end.

 Lemma ceval_spec : forall k t (s:usupport t) (m:Mem.t k),
  eval s m = fst (ceval s m).
 Proof.
  intros; case s; intros; simpl; trivial.
 Qed.

 (** TODO: add to EXPR *)
 Fixpoint fv_expr_rec (t:T.type) (res:Vset.t) (e:E.expr t) {struct e} : Vset.t :=
  match e with
   | E.Ecte _ _ => res
   | E.Evar t x => Vset.add x res
   | E.Eop op args => dfold_left fv_expr_rec args res
   | E.Eexists t x e1 e2 =>
     Vset.union
     (Vset.remove x (fv_expr_rec Vset.empty e1))
     (fv_expr_rec res e2)
   | E.Eforall t x e1 e2 =>
     Vset.union
     (Vset.remove x (fv_expr_rec Vset.empty e1))
     (fv_expr_rec res e2)
   | E.Efind t x e1 e2 =>
     Vset.union
     (Vset.remove x (fv_expr_rec Vset.empty e1))
     (fv_expr_rec res e2)
  end.

 Definition fv_expr t := @fv_expr_rec t Vset.empty.

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

 Lemma req_mem_weaken : forall k X X',
  Vset.subset X X' -> forall (m m':Mem.t k), req_mem X' m m' -> req_mem X m m'.
 Proof.
  unfold req_mem; intros; eauto using Vset.subset_correct.
 Qed.

 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.

 Let depend_only (X:Vset.t) t (e:E.expr t) :=
  forall k (m1 m2:Mem.t k), req_mem X m1 m2 -> E.eval_expr e m1 = E.eval_expr e m2.

 Axiom depend_only_fv_expr : forall t (e:E.expr t), depend_only (fv_expr e) e.

 Definition fv_distr t (s:usupport t) : Vset.t :=
  match s with
   | Lap a => (fv_expr a)
   | MapLap l => (fv_expr l)
  end.

 Lemma depend_only_fv_distr : forall t (s:usupport t),
  depend_only_distr (fv_distr s) s.
 Proof.
  intros t s k m1 m2 Hm.
  destruct t; destruct s; simpl in *;
   ((rewrite (depend_only_fv_expr Hm); trivial) || trivial).
 Qed.

 Lemma lossless_support : forall k t (s:usupport t) (m:Mem.t k),
  mu (eval s m) (fun _ => 1)%U == 1%U.
 Proof.
  intros; destruct s.
  apply Laplace_lossless.
  apply ListLaplace_lossless.
 Qed.

 Lemma discrete_support : forall k t (s:usupport t) (m:Mem.t k),
  is_Discrete (eval s m).
 Proof.
  intros; destruct s; simpl.
  apply Laplace_Discrete.
  apply ListLaplace_Discrete.
 Qed.

 Definition eqb (t1 t2:T.type) (s1:usupport t1) (s2:usupport t2) : bool :=
  match s1, s2 with
  | Lap a, Lap a' => E.eqb a a'
  | MapLap l, MapLap l' => E.eqb l l'
  | _, _ => false
  end.

 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.
  intros t1 u1 t2 u2; destruct u1; destruct u2; simpl.
  generalize (E.eqb_spec i i0); destruct (E.eqb i i0); intros; simpl;
   intros; subst; trivial; intro W; inversion W; tauto.
  intro W; inversion W; tauto.
  intro W; inversion W; tauto.
  generalize (E.eqb_spec l l0); destruct (E.eqb l l0); intros;
   simpl; intros; subst; trivial; intro W; inversion W; tauto.
 Qed.

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

End US.

Module DE := MakeDExpr UT T Var Mem Uop O E US.

Module I := MakeInstr UT T Var Proc Uop O Mem E US DE.

Module SemI := SemInstr.Make UT T Var Proc Uop O Mem E US DE I.

Export SemI.

 Notation "{ x , .. , y }" :=
  (@dcons T.type E.expr _ _ x ..
   (@dcons T.type E.expr _ _ y (@dnil T.type E.expr)) ..).

 (* Boolean expressions *)
 Notation "'!' x"   := (E.Eop O.Onot { x }) (at level 60).
 Notation "x && y"  := (E.Eop O.Oand {x,  y}).
 Notation "x || y"  := (E.Eop O.Oor {x, y}).
 Notation "x ==> y" := (E.Eop O.Oimp {x, y}).
 Notation "b '?' x '?:' y" := (E.Eop (O.Oif _) {b, x, y}) (at level 60).

 (* pair expressions *)
 Notation "'Efst' p" := (E.Eop (O.Ofst _ _) { p }) (at level 0).
 Notation "'Esnd' p" := (E.Eop (O.Osnd _ _) { p }) (at level 0).
 Notation "'(' x '|' y ')'" := (E.Eop (O.Opair _ _) {x,  y} ).

 (* sum expressions *)
 Notation "'Inl' x" := (E.Eop (O.Oinl _ _) { x }) (at level 60).
 Notation "'Inr' x" := (E.Eop (O.Oinr _ _) { x }) (at level 60).
 Notation "'Isl' x" := (E.Eop (O.Oisl _ _) { x }) (at level 60).
 Notation "'Projl' x" := (E.Eop (O.Oprojl _ _) { x }) (at level 60).
 Notation "'Projr' x" := (E.Eop (O.Oprojr _ _) { x }) (at level 60).

 (* option expressions *)
 Notation "'none' t" := (E.Ecte (E.Cnone t)) (at level 0).
 Notation "'some' x" := (E.Eop (O.Osome _) { x }) (at level 60).
 Notation "'IsSome' x" := (E.Eop (O.Oissome _) { x }) (at level 60).
 Notation "'Proj' x" := (E.Eop (O.Oprojo _) { x }) (at level 60).

 (* list expressions *)
 Notation "'Nil' t" := (E.Ecte (E.Cnil t)) (at level 0).
 Notation "x '|::|' y" :=
  (E.Eop (O.Ocons _) {x, y}) (at level 60, right associativity).
 Notation "'Etail' p" := (E.Eop (O.Otl _) {p}) (at level 40).
 Notation "'Ehead' p" := (E.Eop (O.Ohd _) {p}) (at level 40).
 Notation "'Elen' p" := (E.Eop (O.Olength _) {p}) (at level 40).
 Notation "x |++| l" :=
  (E.Eop (O.Oappend _) {x,l}) (at level 60, right associativity).

 (* association lists *)
 Notation "x 'in_dom' y" := (E.Eop (O.Oin_dom _ _) {x, y}) (at level 60).
 Notation "x 'in_range' y" := (E.Eop (O.Oin_range _ _) {x, y}) (at level 60).
 Notation "y '[{' x '}]'" := (E.Eop (O.Oimg _ _) {x, y}) (at level 59).
 Notation "l '.[{' x '<<-' v '}]'" :=
   (E.Eop (O.Oupd _ _) {x,v,l}) (at level 50).

 (* nat expressions *)
 Notation "x '+!' y"  := (E.Eop O.Oadd {x, y}) (at level 50, left associativity).
 Notation "x '*!' y"  := (E.Eop O.Omul {x, y}) (at level 40, left associativity).
 Notation "x '-!' y"  := (E.Eop O.Osub {x, y}) (at level 50, left associativity).
 Notation "x '<=!' y" := (E.Eop O.Ole {x, y}) (at level 50).
 Notation "x '<!' y"  := (E.Eop O.Olt {x, y}) (at level 50).

 (* Z expressions *)
 Notation "x '+Z' y"   := (E.Eop O.OZadd {x, y}) (at level 50, left associativity).
 Notation "x '*Z' y"   := (E.Eop O.OZmul {x, y}) (at level 40, left associativity).
 Notation "x '-Z' y"   := (E.Eop O.OZsub {x, y}) (at level 50, left associativity).
 Notation "x '<=Z' y"  := (E.Eop O.OZle {x, y}) (at level 50).
 Notation "x '<Z' y"   := (E.Eop O.OZlt {x, y}) (at level 50).
 Notation "x '>=Z' y"  := (E.Eop O.OZge {x, y}) (at level 50).
 Notation "x '>Z' y"   := (E.Eop O.OZgt {x, y}) (at level 50).
 Notation "'oppZ' x"   := (E.Eop O.OZopp {x}) (at level 40).
 Notation "x '/Z' y"   := (E.Eop O.OZdiv {x, y}) (at level 50).
 Notation "x 'modZ' y" := (E.Eop O.OZmod {x, y}) (at level 50).
 Notation "x 'powZ' y" := (E.Eop O.OZpow {x, y}) (at level 50).

 (* equality *)
 Notation "x '=?=' y" := (E.Eop (O.Oeq_ _) {x, y}) (at level 70, no associativity).

 (* distribution expressions *)
 Notation "'{0,1}'" := DE.Dbool.
 Notation "'[0..' e ']'" := (DE.Dnat e)%nat.
 Notation "'[' e1 ',,' e2 ']'" := (DE.DZ e1 e2)%nat.
 Notation "'Lap' a" := (DE.Duser (@Lap _ _ _ E.expr a)) (at level 60).
 Notation "'MapLap' 'eps'" :=
  (fun l => DE.Duser (@MapLap T.type T.Zt (T.List T.Zt) E.expr l)) (at level 60).

 (* User-defined operators *)
 Notation "'q'" := (E.Eop (O.Ouser Q) (dnil E.expr)) (at level 60).
 Notation "'N'" := (E.Eop (O.Ouser N) (dnil E.expr)) (at level 60).
 Notation "'Efirstn'  x" := (E.Eop (O.Ouser OTake) {x}) (at level 60).
 Notation "'Elastn'  x" := (E.Eop (O.Ouser ODrop) {x}) (at level 60).
 Notation "'MapPlus'  x l" := (E.Eop (O.Ouser OMapPlus) {x,l}) (at level 60).

End Sem.

(** Semantics with optimizations *)
Module Entries.

 Module SemO <: SEM_OPT.

  Module Sem := Sem.
  Export Sem.

  Definition simpl_op (op : Uop.t) :
   E.args (Uop.targs op) -> E.expr (Uop.tres op) :=
   match op as op0 return E.args (Uop.targs op0) -> E.expr (Uop.tres op0) with
    | op => fun args => E.Eop (O.Ouser op) args
   end.

  Implicit Arguments simpl_op [].

  Lemma simpl_op_spec : forall k op args (m:Mem.t k),
   E.eval_expr (simpl_op op args) m = E.eval_expr (E.Eop (O.Ouser op) args) m.
  Proof.
   intros; simpl; trivial.
  Qed.

 End SemO.

 Module BP := BaseProp.Make SemO.Sem.

End Entries.

Module Ent := Entries.

Module Tactics := BuildTac.Make Ent.
Export Tactics.

(* Boolean comparability in U *)
Parameter Uleb : U -> U -> bool.

Hypothesis Uleb_spec: forall (u1 u2:U), if Uleb u1 u2 then u1 <= u2 else u2 < u1.

Lemma Uleb_corr_conv: forall (x y: U),
 (x <= y)%tord -> Uleb x y.
Proof.
 intros u1 u2 H.
 generalize (Uleb_spec u1 u2).
 case_eq (Uleb u1 u2); intros Heq H'.
 trivial.
 contradiction.
Qed.

Lemma Uleb_compl_conv: forall (u1 u2: U),
 (u2 < u1)%U -> Uleb u1 u2 = false.
Proof.
 intros u1 u2 H.
 generalize (Uleb_spec u1 u2).
 case_eq (Uleb u1 u2); intros Heq H'.
 contradiction.
 trivial.
Qed.

(* Multiplication of a real by a natural number *)
Fixpoint RNmult (r:R) (n:nat) {struct n} :=
 match n with
  | 0%nat => 0%R
  | S n'' => (r + (RNmult r n''))%R
 end.

Lemma RNmult_ge_0: forall (r:R) (n:nat),
 (0 <= r)%R ->
 (0 <= RNmult r n)%R.
Proof.
 induction n; intros; simpl.
 auto.
 rewrite <-(Rplus_0_r 0); apply Rplus_le_compat; auto.
Qed.

Lemma exp_Rmult: forall (r:R) (n:nat),
 (exp r ^ n = exp (RNmult r n))%R.
Proof.
 induction n; simpl; symmetry.
 apply exp_0.
 rewrite IHn; apply exp_plus.
Qed.

(* Some useful tactics *)
Ltac mem_upd_simpl :=
 repeat (rewrite Mem.get_upd_same || (rewrite Mem.get_upd_diff;
  [ | discriminate])); trivial.

Ltac expr_simpl :=
 unfold EP1, EP2, notR, andR, orR, impR, E.eval_expr; simpl;
  unfold O.eval_op; simpl; mem_upd_simpl.

(* Some auxiliary lemmas *)
Lemma Zeq_bool_comm: forall z1 z2, Zeq_bool z1 z2 = Zeq_bool z2 z1.
Proof.
 intros.
 case_eq (Zeq_bool z1 z2); intro Heq.
 symmetry; rewrite <-(@Zeq_is_eq_bool z2 z1); symmetry.
 apply (Zeq_bool_eq _ _ Heq).
 symmetry; apply not_true_iff_false; intro H'.
 apply ((Zeq_bool_neq _ _ Heq) (eq_sym (Zeq_bool_eq _ _ H'))).
Qed.

Lemma Zeqb_list_bool_comm: forall l1 l2,
 eqb_list Zeq_bool l1 l2 = eqb_list Zeq_bool l2 l1.
Proof.
 induction l1; intros; destruct l2; trivial.
 simpl; rewrite (Zeq_bool_comm a z), (IHl1 l2); trivial.
Qed.

Lemma multRU_le_Rmult : forall (u1 u2:U) (x:R),
 (0 <= x)%R ->
 (iR u1 <= x * iR u2)%R ->
 u1 <= x ** u2.
Proof.
 intros u1 u2 x Hx H; unfold  multRU; repeat case_Rle.
 rewrite <-(retract_U u1); apply (iU_le H).
 elim n; apply Rmult_le_pos; auto.
 auto.
Qed.

Lemma nth_eq: forall (A:Type) (a:A) (l1 l2:list A),
 length l1 = length l2 ->
 (forall i, (i < length l1)%nat -> nth i l1 a  = nth i l2 a) ->
 l1 = l2.
Proof.
 induction l1; intros.
 destruct l2; [ trivial | discriminate ].
 destruct l2; [ discriminate | ].
 apply f_equal2.
 apply (H0 0%nat (lt_0_Sn _)).
 apply (IHl1 _ (eq_add_S _ _ H)).
 intros i Hi; apply (H0 (S i) (lt_n_S _ _ Hi)).
Qed.

Lemma int_between_0_1_inv: forall (z:Z),
 (0 <= z <= 1%Z)%Z ->
 z = 1%Z \/ z = 0%Z.
Proof.
 intros.
 destruct (Compare.le_le_S_eq _ _ (Zabs_nat_le _ _ H)).
 (* |z| = 0 *)
 pose proof (le_n_0_eq _ (@le_S_n (Zabs_nat z) 0 H0)) as H'; clear H0.
 right; symmetry; unfold Zabs_nat in H'; case_eq z; intros; subst;
  try (pose proof (lt_O_nat_of_P p); exfalso; omega); trivial.
 (* |z| = 1 *)
 unfold Zabs_nat in H0; case_eq z; intros; rewrite H1 in H0.
 right; symmetry; trivial.
 left; rewrite (nat_of_P_inj _ _ H0); trivial.
 rewrite H1 in H; destruct H as [H' _];
  pose proof (Zlt_neg_0 p);   exfalso; omega.
Qed.

Lemma Zplus_diff_eq_compat_l: forall x y z,
 (x + y <> x + z)%Z ->
 (y <> z)%Z.
Proof.
 intros x y z H H'.
 elim H; rewrite H'; auto with arith.
Qed.

Lemma nat_eqb_eq: forall n1 n2,
 n1 = n2 ->
 nat_eqb n1 n2.
Proof.
 intros; subst; apply nat_eqb_refl.
Qed.

Lemma req_mem_upd_notin_r : forall k (m1 m2:Mem.t k) t (v2:Var.var t) e2 X,
 req_mem X m1 m2 ->
 ~Vset.mem v2 X ->
 req_mem X m1 (m2 {!v2 <-- e2!}).
Proof.
 intros; intros t0 x Hx.
 repeat rewrite Mem.get_upd_diff.
 apply H; trivial.
 intro Heq; elim H0; rewrite Heq; trivial.
Qed.

Lemma length_skipn_le: forall (A:Type) (l:list A) n,
 (length (skipn n l) <= length l)%nat.
Proof.
 induction l; intros; destruct n; simpl; auto.
Qed.

Lemma req_mem_upd_notin : forall k (m1 m2:Mem.t k) t1 t2
 (v1: Var.var t1) (v2: Var.var t2) e1 e2 X,
 req_mem X m1 m2 ->
 ~Vset.mem v1 X ->
 ~Vset.mem v2 X ->
 req_mem X (m1 {!v1 <-- e1!}) (m2 {!v2 <-- e2!}).
Proof.
 intros; intros t0 x Hx.
 repeat rewrite Mem.get_upd_diff.
 apply H; trivial.
 intro Heq; elim H1; rewrite Heq; trivial.
 intro Heq; elim H0; rewrite Heq; trivial.
Qed.

Lemma lam_ge_1: forall k, (1 <= exp (Eps k))%R.
Proof.
 intro k; rewrite <-exp_0; apply (exp_monotonic (Rlt_le _ _ (eps_pos k))).
Qed.

Lemma exp_eps_ge_1: forall k n,
 (1 <= exp (Eps k * INR n))%R.
Proof.
 intros k n; rewrite <-exp_0; apply exp_monotonic;
  apply (Rmult_le_pos _ _  (Rlt_le _ _ (eps_pos k)) (pos_INR _)).
Qed.

Hint Resolve exp_eps_ge_1 lam_ge_1 RNmult_ge_0.

Lemma length_firstn_compat: forall (A:Type) m (l1 l2:list A),
 length l1 = length l2 ->
 length (firstn m l1) = length (firstn m l2).
Proof.
 induction m.
 intros; trivial.
 intros.
 destruct l1; destruct l2; try discriminate; simpl.
 trivial.
 apply (eq_S _ _ (IHm _ _ (eq_add_S _ _ H))).
Qed.

Lemma length_skipn_compat: forall (A:Type) m (l1 l2:list A),
 length l1 = length l2 ->
 length (skipn m l1) = length (skipn m l2).
Proof.
 intros A m l1 l2 H; generalize H.
 rewrite <-(firstn_skipn m l1), <-(firstn_skipn m l2) at 1;
  rewrite 2 app_length, (length_firstn_compat _ H).
 intro H'; clear H.
 omega.
Qed.

Section NMATCH.

 Open Scope nat_scope.

 Variable A : Type.
 Variable P : A -> A -> bool.
 Variable def : A.

 Fixpoint NMatch (l1 l2:list A) {struct l1} : nat :=
  match l1,l2 with
   | x::xs,y::ys => if P x y then S (NMatch xs ys) else (NMatch xs ys)
   | _,_ => 0%nat
  end.

 Variable P_spec :  forall (a1 a2:A), if P a1 a2 then a1 <> a2 else a1 = a2.

 Lemma P_non_refl : forall a, negb (P a a).
 Proof.
  intros.
  generalize (P_spec a a).
  case_eq (P a a); intro Heq.
  intro H; elim (H (eq_refl _)).
  simpl; trivial.
 Qed.

 Lemma NMatch_0 : forall l1 l2,
  length l1 = length l2 ->
  NMatch l1 l2 = 0%nat ->
  l1 = l2.
 Proof.
  induction l1; intros.
  destruct l2; [ trivial | discriminate ].
  destruct l2; [ discriminate | ].
  simpl in  H0.
  generalize (P_spec a a0) H0;
   case (P a a0); simpl; intros Haa0 Hip.
  discriminate.
  rewrite Haa0, (IHl1 _ (eq_add_S _ _ H) Hip); trivial.
 Qed.

 Lemma  NMatch_eq: forall l, NMatch l l = 0.
 Proof.
  induction l.
  trivial.
  simpl.
  rewrite <-(negb_involutive (P a a)), P_non_refl; simpl; trivial.
 Qed.

 Definition list_ApEq (l1 l2:list A) := NMatch l1 l2 <= 1.

 Lemma list_ApEq_tl_compat: forall l1 l2,
  length l1 = length l2 ->
  list_ApEq l1 l2 ->
  list_ApEq (tl l1) (tl l2).
 Proof.
  unfold list_ApEq; intros.
  destruct l1; destruct l2; try discriminate.
  apply le_trans with (2:=H0); trivial.
  apply le_trans with (2:=H0).
  simpl; destruct (P a a0); auto.
 Qed.

 Lemma list_ApEq_first_compat: forall m l1 l2,
  length l1 = length l2 ->
  list_ApEq l1 l2 ->
  list_ApEq (firstn m l1) (firstn m l2).
 Proof.
  unfold list_ApEq.
  induction m; intros.
  simpl; auto with arith.
  destruct l1; destruct l2; try discriminate; simpl.
  auto with arith.
  simpl in H0; generalize (P_spec a a0);
   destruct (P a a0); intro Heq.
  (* diff  *)
  apply le_n_S.
  cut (NMatch (firstn m l1) (firstn m l2) = 0%nat);
   [ intro H'; rewrite H'; auto | ].
  apply le_S_n in H0; apply le_n_0_eq in H0.
  rewrite (NMatch_0 (eq_add_S _ _ H) (eq_sym H0)).
  apply NMatch_eq.
  (* same *)
  apply (IHm _ _ (eq_add_S _ _ H) H0).
 Qed.

 Lemma NMatch_app: forall l1 l1' l2 l2',
  length l1 = length l1' ->
  NMatch (l1 ++ l2) (l1' ++ l2') = NMatch l1 l1' + NMatch l2 l2'.
 Proof.
  induction l1; intros.
  destruct l1'; [ trivial | discriminate ].
  destruct l1'; [ discriminate | ].
  repeat rewrite <-app_comm_cons.
  simpl; destruct (P a a0).
  apply (eq_S (NMatch (l1 ++ l2) (l1' ++ l2'))
   ((NMatch l1 l1') + NMatch l2 l2')).
  apply (IHl1 _ _ _ (eq_add_S _ _ H)).
  apply (IHl1 _ _ _ (eq_add_S _ _ H)).
 Qed.

 Lemma list_ApEq_skipn_compat: forall m l1 l2,
  length l1 = length l2 ->
  list_ApEq l1 l2 ->
  list_ApEq (skipn m l1) (skipn m l2).
 Proof.
  unfold list_ApEq; intros m l1 l2.
  rewrite <-(firstn_skipn m l1) at 1 2.
  rewrite <-(firstn_skipn m l2) at 1 2.
  intros.
  rewrite NMatch_app in H0.
  apply le_trans with (2:=H0); auto with arith.
  rewrite (firstn_skipn m l1), (firstn_skipn m l2) in H.
  apply (length_firstn_compat _ H).
 Qed.

 Lemma list_ApEq_eq: forall l1 l2,
  l1 = l2 ->
  list_ApEq l1 l2.
 Proof.
  unfold list_ApEq; intros; subst.
  induction l2.
  auto.
  apply le_trans with (2:=IHl2).
  simpl.
  rewrite <-(negb_involutive (P a a)), (P_non_refl a); simpl; trivial.
 Qed.

 Lemma list_ApEq_hd_neq : forall l1 l2,
  length l1 = length l2 ->
  list_ApEq l1 l2 ->
  hd def l1 <> hd def l2 ->
  tl l1 = tl l2.
 Proof.
  unfold list_ApEq; intros; destruct l1; destruct l2;
   [ trivial | discriminate | discriminate | simpl in * ].
  generalize  (P_spec a a0) H0; clear H0;
   case (P a a0); simpl; intros Haa0 Hip; [ | contradiction ].
  apply (NMatch_0 (eq_add_S _ _ H) (eq_sym (le_n_0_eq _ (le_S_n _ _ Hip)))).
 Qed.

 Lemma Nmatch_neq: forall l1 l2,
  length l1  = length l2 ->
  l1 <> l2 ->
  1 <= NMatch l1 l2.
 Proof.
  induction l1; intros.
  destruct l2; [ elim (H0 (eq_refl _)) | discriminate ].
  destruct l2; [ discriminate | ].
  simpl.
  generalize (P_spec a a0); destruct (P a a0); intros Heq.
  auto with arith.
  apply (IHl1 _ (eq_add_S _ _ H)).
  intro H'; elim H0; rewrite Heq, H'; trivial.
 Qed.

 Lemma list_ApEq_firstn_neq : forall m l1 l2,
  length l1 = length l2 ->
  list_ApEq l1 l2 ->
  firstn m l1 <> firstn m l2 ->
  skipn m l1 = skipn m l2.
 Proof.
  unfold list_ApEq; intros m l1 l2 Hlen.
  rewrite <-(firstn_skipn m l1), <-(firstn_skipn m l2) at 1.
  rewrite (NMatch_app _ _ (length_firstn_compat _ Hlen)).
  intros H1 H2.
  pose proof (Nmatch_neq (length_firstn_compat _ Hlen) H2); clear H2.
  apply (NMatch_0 (length_skipn_compat _ Hlen)).
  omega.
 Qed.

End NMATCH.

Lemma length_tl_compat: forall (A:Type) (l1 l2:list A),
 length l1 = length l2 ->
 length (tl l1) = length (tl l2).
Proof.
 intro A; destruct l1; destruct l2; simpl; intros.
 trivial.
 discriminate.
 discriminate.
 auto with arith.
Qed.

Lemma Zabs_le1_elim: forall x y,  (Zabs (x - y) <= 1)%Z ->
 (Zabs (x - y) = 1)%Z \/ x = y.
Proof.
 intros.
 destruct (int_between_0_1_inv (conj (Zabs_pos (x-y)) H)); clear -H0.
 left; trivial.
 right; destruct (Zabs_spec (x-y)) as [ (H2,H3) | (H2,H3) ];
  rewrite H3 in H0; omega.
Qed.

Definition DiffBound (l1 l2: list Z) (B:nat) := forall i,
 (i < length l1)%nat ->
 (Zabs_nat (nth i l1 (0%Z) - nth i l2 (0%Z))%Z <= B)%nat.

Definition DiffBoundb  (l1 l2: list Z) (B:nat) :=
 forallb
 (fun i => leb (Zabs_nat (nth i l1 (0%Z) - nth i l2 (0%Z))%Z) B)
 (seq 0 (length l1)).

Lemma DiffBoundb_iff: forall l1 l2 B,
 DiffBoundb l1 l2 B <-> DiffBound l1 l2 B.
Proof.
 unfold DiffBoundb, DiffBound; intros l1 l2 B.
 rewrite is_true_forallb; split; intros H i Hi.
 refine (leb_complete _ _ (H i (le_In_seq _ _))); omega.
 apply In_seq_le in Hi.
 refine (leb_correct _ _ (H i _)); omega.
Qed.

Lemma DiffBound_tl_compat: forall n l1 l2,
 DiffBound l1 l2 n ->
 DiffBound (tl l1) (tl l2) n.
Proof.
 unfold DiffBound.
 intros.
 destruct l1.
 elim (lt_n_O _ H0).
 destruct l2.
 eapply le_trans; [ | apply (H (S i) (lt_n_S _ _ H0)) ];
  destruct i; simpl; auto.
 simpl.
 apply (H (S i) (lt_n_S _ _ H0)).
Qed.

Lemma DiffBound_app_r:forall n l1 l1' l2 l2',
 length l1 = length l2 ->
 DiffBound (l1 ++ l1') (l2 ++ l2') n ->
 DiffBound l1' l2' n.
Proof.
 induction l1; intros.
 destruct l2; [ apply H0 | discriminate ].
 destruct l2; [ discriminate | ].
 apply (IHl1 _ l2 _ (eq_add_S _ _ H)).
 repeat rewrite <-app_comm_cons in H0.
 apply (DiffBound_tl_compat H0).
Qed.

Lemma DiffBound_app_l:forall n l1 l1' l2 l2',
 length l1 = length l2 ->
 DiffBound (l1 ++ l1') (l2 ++ l2') n ->
 DiffBound l1 l2 n.
Proof.
 induction l1; intros.
 destruct l2; [ | discriminate ].
 intros i Hi; elim (lt_n_O _ Hi).
 destruct l2; [ discriminate | ].
 intros i Hi; destruct i.
 apply (H0 0%nat).
 rewrite <-app_comm_cons; apply (lt_le_trans _ _ _ Hi).
 simpl; rewrite app_length; apply le_n_S; auto with arith.
 simpl; refine (@IHl1 l1' _ l2' (eq_add_S _ _ H) _ _ (lt_S_n _ _ Hi)).
 rewrite <-app_comm_cons in H0.
 apply (DiffBound_tl_compat H0).
Qed.

Lemma DiffBound_firstn_compat: forall n m l1 l2,
 length l1 = length l2 ->
 DiffBound l1 l2 n ->
 DiffBound (firstn m l1) (firstn m l2) n.
Proof.
 intros n m l1 l2 Hlen.
 rewrite <-(firstn_skipn m l1), <-(firstn_skipn m l2) at 1.
 intro H.
 refine (DiffBound_app_l (length_firstn_compat _ Hlen) H).
Qed.

Lemma DiffBound_skipn_compat: forall n m l1 l2,
 length l1 = length l2 ->
 DiffBound l1 l2 n ->
 DiffBound (skipn m l1) (skipn m l2) n.
Proof.
 intros n m l1 l2 Hlen.
 rewrite <-(firstn_skipn m l1), <-(firstn_skipn m l2) at 1.
 intro H.
 refine (DiffBound_app_r (length_firstn_compat _ Hlen) H).
Qed.

Lemma DiffBound_eq: forall M l1 l2,
 l1 = l2 ->
 DiffBound l1 l2 M.
Proof.
 intros; subst; unfold DiffBound; induction l2.
 intros i _; destruct i; simpl; apply le_0_n.
 intros i Hi; destruct i.
 simpl; rewrite Zminus_diag; apply le_0_n.
 apply (IHl2 i (lt_S_n _ _ Hi)).
Qed.

Hint Resolve length_tl_compat length_skipn_compat DiffBound_tl_compat
 DiffBound_skipn_compat
 (@list_ApEq_tl_compat Z (fun a b : Z => negb (Zeq_bool a b)))
 (@list_ApEq_skipn_compat Z (fun a b : Z => negb (Zeq_bool a b)))
 list_ApEq_eq
 (@list_ApEq_first_compat Z (fun a b : Z => negb (Zeq_bool a b)))
 length_firstn_compat : list_op DiffBound_firstn_compat.

Definition Zlist_ApEq := list_ApEq (fun a b:Z => negb (Zeq_bool a b)).

Lemma nZeq_bool_spec: forall (a1 a2:Z),
 if negb (Zeq_bool a1 a2) then a1 <> a2 else a1 = a2.
Proof.
 intros; unfold negb; generalize (Zeq_bool_if a1 a2).
 case (Zeq_bool a1 a2); trivial.
Qed.

Definition  Zlist_ApEqb (l1 l2: list Z) :=
 leb (NMatch (fun a b:Z => negb (Zeq_bool a b)) l1 l2) 1%nat.

Lemma  Zlist_ApEqb_iff: forall (l1 l2: list Z),
 Zlist_ApEqb l1 l2 <->  Zlist_ApEq l1 l2.
Proof.
 unfold Zlist_ApEq, list_ApEq, Zlist_ApEqb; intros.
 apply leb_iff.
Qed.

Section LOOP_RULE.

 Variable c : cmd.
 Variable E : env.

 Variable A : T.type.
 Variable L : Var.var (T.List A).

 Variable I : mem_rel.

 Variable lam : nat -> R.
 Variable ep : nat -o> U.
 Variable Size : nat -> nat.

 Hypothesis Size_pos : forall k, (0 < Size k)%nat.

 Variable A_eqb_dec : forall k (x y: T.interp k A), sumbool (x = y) (x <> y).

 Hypothesis HI : forall k (m1 m2:Mem.t k),
  I m1 m2 ->
  length (m1 L) = length (m2 L).

 Hypothesis Hc : forall k (m:Mem.t k),
  range (fun m':Mem.t k => m' L = skipn (Size k) (m L)) ([[c]] E m).

 Hypothesis Hlam : forall k, (1 <= lam k)%R.

 Hypothesis H_eq_Hd :
  eequiv
  (I /-\
   (fun k (m1 m2:Mem.t k) => firstn (Size k) (m1 L) = firstn (Size k) (m2 L) /\
   (m1 L) <> (m2 L)))
  E c E c
  I
  (fun _ => R1) (fzero _).

 Hypothesis H_diff_Hd :
  eequiv
  (I /-\ (fun k (m1 m2:Mem.t k) =>
   firstn (Size k) (m1 L) <> firstn (Size k) (m2 L)))
  E c E c
  (I /-\ kreq_mem {{L}})
  lam ep.

 Hypothesis Hnoninter:
  eequiv
   (I /-\ kreq_mem {{L}})
   E c E c
   (I /-\ kreq_mem {{L}})
   (fun _ => R1) (fzero _).

 Opaque leb.

 Lemma loop_sem : forall k (m:Mem.t k),
  [[ [while (0%nat <! Elen L) do c] ]] E m ==
  drestr ([[ unroll_while (0%nat <! Elen L) c (length (m L)) ]] E m)
  (negP (@EP k (0%nat <! Elen L))).
 Proof.
  intros.
  apply eq_distr_intro; intro f.
  apply deno_bounded_while_elim with (Elen L).
  intros k' m' Hm'.
  apply range_weaken with (2:=@Hc _ m').
  intros m''; generalize Hm'; clear Hm'.
  unfold EP; expr_simpl; unfold is_true; rewrite 2 leb_iff.
  destruct (m' L); simpl; intros.
  exfalso; omega.
  rewrite H0.
  generalize (Size_pos k'); destruct (Size k').
  intro H'; elim (lt_irrefl _ H').
  simpl; intros _; rewrite plus_comm; apply (le_n_S _ _ (length_skipn_le i0 n)).
  intros m'; expr_simpl; intro Hm'; rewrite Hm'.
  apply leb_correct_conv; auto with arith.
  apply le_refl.
 Qed.

 Definition DistrSel k
  (d1 d2 d3:Mem.t k -> Mem.t k -> Distr (Mem.t k * Mem.t k)) (mm:Mem.t k * Mem.t k)
  : Distr (Mem.t k * Mem.t k).
  intros.
  destruct (E.eval_expr (0%nat <! Elen L) (fst mm)).
  destruct (list_eq_dec (@A_eqb_dec k) (firstn (Size k) (fst mm L))
   (firstn (Size k) (snd mm L))).
  destruct (req_mem_dec {{L}} (fst mm) (snd mm)).
  exact (d2 (fst mm) (snd mm)).
  exact (d1 (fst mm) (snd mm)).
  exact (d3 (fst mm) (snd mm)).
  exact (Munit mm).
 Defined.

 Fixpoint WitIter k (d1 d2 d3:Mem.t k -> Mem.t k -> Distr (Mem.t k * Mem.t k))
  (mm:Mem.t k * Mem.t k) (n:nat) : Distr (Mem.t k * Mem.t k) :=
  match n with
   | S n' =>  Mlet (DistrSel d1 d2 d3 mm) (fun mm' => WitIter d1 d2 d3 mm' n')
   | 0%nat =>
    drestr (Munit mm) (fun mm => (negP (EP k (0%nat <! Elen L))) (fst mm))
  end.

 Definition WitD k n (m1 m2:Mem.t k) :=
  WitIter
  (fun m1' m2' => proj1_sig (H_eq_Hd  m1' m2'))
  (fun m1' m2' => proj1_sig (Hnoninter m1' m2'))
  (fun m1' m2' => proj1_sig (H_diff_Hd m1' m2'))
  (m1, m2) n.

 Ltac destr_sig :=
  let d := fresh "d" in
  let Hd := fresh "Hd" in
   match goal with
    |- context [(proj1_sig ?x)]  => destruct x as (d,Hd); simpl proj1_sig
   end.

 Lemma HI_syn: forall k (m1 m2:Mem.t k),
  I m1 m2 ->
  E.eval_expr (0%nat <! Elen L) m2 = E.eval_expr (0%nat <! Elen L) m1.
 Proof.
  intros; expr_simpl; setoid_rewrite (HI H); trivial.
 Qed.

 Lemma WitD_guard_false : forall k n (m1 m2:Mem.t k),
  I m1 m2 ->
  E.eval_expr (0%nat <! Elen L) m1 = false ->
  le_lift ((I /-\ EP1 (Elen L =?= 0%nat)) k)
  (WitD n m1 m2)
  (drestr (Munit m1) (negP (EP k (0%nat <! Elen L))))
  (drestr (Munit m2) (negP (EP k (0%nat <! Elen L))))
  1 0.
 Proof.
  unfold WitD.
  induction n; intros m1 m2 H1m H2m; unfold WitD; simpl.

  (* base case *)
  unfold drestr; rewrite 3 Mlet_unit.
  unfold negP, EP, negb; setoid_rewrite (@HI_syn _ _ _ H1m).
  case_eq (@E.eval_expr _ T.Bool (0%nat <! Elen L) m1);
   intro Heq; setoid_rewrite Heq.
  eapply le_lift_eq_compat; [ apply Oeq_refl | | | | |
   apply le_lift_prod ]; auto.
  apply le_lift_Munit; auto.
  split; trivial; generalize Heq; clear Heq; expr_simpl;
   intro Heq; apply leb_complete_conv in Heq; apply nat_eqb_eq; omega.

  (* inductive case *)
  rewrite le_lift_lift.
  eapply lift_Mlet with ((I /-\ EP1 (Elen L =?= 0%nat)) k).
  unfold DistrSel; simpl fst; simpl snd.
  case_eq (@E.eval_expr _ T.Bool (0%nat <! Elen L) m1); intro Heq;
   setoid_rewrite Heq.
  elim (eq_true_false_abs _ Heq H2m).
  apply lift_unit.
  split; trivial; generalize Heq; clear Heq; expr_simpl;
   intro Heq; apply leb_complete_conv in Heq; apply nat_eqb_eq; omega.
  intros m1' m2' (H1m', H2m').
  rewrite <-le_lift_lift.
  eapply le_lift_eq_compat; [ | | | | | apply (IHn _ _ H1m') ]; auto.
  generalize H2m'; clear H2m'; expr_simpl; intro H2m';
   apply nat_eqb_true in H2m'; rewrite H2m';
    apply leb_correct_conv; auto with arith.
 Qed.

 Lemma WitD_eq_L: forall k n (m1 m2:Mem.t k),
  I m1 m2 ->
  kreq_mem {{L}} m1 m2 ->
  le_lift ((I /-\ EP1 (Elen L =?= 0%nat)) k)
  (WitD n m1 m2)
  (drestr (([[unroll_while (0%nat <! Elen L) c n]]) E m1)
   (negP (EP k (0%nat <! Elen L))))
  (drestr (([[unroll_while (0%nat <! Elen L) c n]]) E m2)
   (negP (EP k (0%nat <! Elen L))))
  1 0.
 Proof.
  unfold WitD; induction n; intros m1 m2 H1m H2m.

  (* base case *)
  unfold drestr.
  rewrite (eq_distr_intro _
   (Munit m1) (unroll_while_0_elim E (0%nat <! Elen L) c m1)),
   (eq_distr_intro _ (Munit m2) (unroll_while_0_elim E (0%nat <! Elen L) c m2)).
  rewrite 2 Mlet_unit.
  simpl; unfold drestr; rewrite Mlet_unit; simpl.
  unfold negP, negb, EP; setoid_rewrite (@HI_syn _ _ _ H1m).
  apply le_lift_weaken with ((I /-\ EP1 (Elen L =?= 0%nat)) k) R1 D0; auto.
  case_eq (E.eval_expr (0%nat <! Elen L) m1); intro Heq; setoid_rewrite Heq.
  eapply le_lift_eq_compat; [ apply Oeq_refl | | | | |
   apply le_lift_prod ]; auto.
  apply le_lift_Munit; auto.
  split; trivial; generalize Heq; clear Heq; expr_simpl;
   intro Heq; apply leb_complete_conv in Heq; apply nat_eqb_eq; omega.

  (* inductive case *)
  unfold drestr.
  rewrite (Mlet_eq_compat (eq_distr_intro  _ _ (deno_cond_elim E (0%nat <! Elen L)
   (c ++ unroll_while (0%nat <! Elen L) c n) nil m1)) (Oeq_refl _)),
  (Mlet_eq_compat (eq_distr_intro  _ _ (deno_cond_elim E (0%nat <! Elen L)
   (c ++ unroll_while (0%nat <! Elen L) c n) nil m2)) (Oeq_refl _)).
  simpl WitIter; unfold DistrSel; simpl fst; simpl snd.
  setoid_rewrite (@HI_syn _ _ _ H1m).
  case_eq (@E.eval_expr _ T.Bool (0%nat <! Elen L) m1); intro Heq;
   setoid_rewrite Heq.
  (* [guard = true] *)
  rewrite 2 deno_app, 2 Mcomp.
  destruct (list_eq_dec (@A_eqb_dec k) (firstn (Size k) (m1 L))
   (firstn (Size k) (m2 L))) as [Hhead | Hhead].
  (* same head *)
  destruct (req_mem_dec {{L}} m1 m2) as [ Heq' | Heq' ].
  (* same list *)
  destr_sig.
  apply le_lift_weaken with ((I /-\ EP1 (Elen L =?= 0%nat)) k)
   (R1 * R1)%R (max (D0 + R1 ** D0)%U (D0 + R1 ** D0)%U);
   [ trivial | auto with real  | repeat multRU_simpl; repeat Usimpl; auto | ].
  eapply le_lift_Mlet.
  apply (cover_eq_prod _ _ (@mem_eqU_spec k) (@mem_eqU_spec k)); auto.
  refine (le_lift_discr_witness _ _ (@mem_eqU_spec k) (@mem_eqU_spec k)
   (sem_discr _ _ _) (sem_discr _ _ _) (Hd (conj H1m H2m))).
  trivial.
  apply (Hd (conj H1m H2m)).
  intros m1' m2' (H1m',H2m'); apply (IHn _ _  H1m' H2m').
  (* diff list *)
  contradiction.
  (* diff head *)
  elim Hhead; apply f_equal; apply (H2m _ L); auto with set.
  (* guard = false *)
  rewrite 2 deno_nil, 3 Mlet_unit.
  eapply le_lift_eq_compat; [ apply Oeq_refl | | | | |
   apply (@WitD_guard_false _ n _ _ H1m Heq) ]; auto.
 Qed.

 Lemma Parallel_loop:
  eequiv
  I
  E [ while (0%nat <! Elen L) do c ]
  E [ while (0%nat <! Elen L) do c ]
  (I /-\  (EP1 (Elen L =?= 0%nat)))
  lam ep.
 Proof.
  intros k.
  cut (forall m1 m2, sig (fun d' => I m1 m2 ->
   le_lift ((I /-\ EP1 (Elen L =?= 0%nat)) k) d'
   (drestr ([[ unroll_while  (0%nat <! Elen L) c (length (m1 L)) ]] E m1)
    (negP (EP k (0%nat <! Elen L))))
   (drestr ([[ unroll_while  (0%nat <! Elen L) c (length (m1 L)) ]] E m2)
    (negP (EP k (0%nat <! Elen L) )))
   (lam  k) (ep k))).
  intros H m1 m2; destruct (H m1 m2) as (d,Hd).
  exists d; intro Hm.
  rewrite (loop_sem m1), (loop_sem m2), <-(HI Hm); auto.

  (* maybe avoid abstracting length l1 *)
  intros; generalize (length (m1 L)); intro n; generalize m1 m2;
   clear m1 m2; intros m1 m2.
  exists (WitD  n m1 m2).
  generalize m1 m2; clear m1 m2; unfold WitD.
  induction n; intros m1 m2 Hm.

  (* base case *)
  unfold drestr.
  rewrite (eq_distr_intro _
   (Munit m1) (unroll_while_0_elim E (0%nat <! Elen L) c m1)),
   (eq_distr_intro _ (Munit m2) (unroll_while_0_elim E (0%nat <! Elen L) c m2)).
  rewrite 2 Mlet_unit.
  simpl; unfold drestr; rewrite Mlet_unit; simpl.
  unfold negP, negb, EP; setoid_rewrite (@HI_syn _ _ _ Hm).
  eapply le_lift_weaken with ((I /-\ EP1 (Elen L =?= 0%nat)) k) R1 D0; auto.
  case_eq (E.eval_expr (0%nat <! Elen L) m1); intro Heq; setoid_rewrite Heq.
  eapply le_lift_eq_compat; [ apply Oeq_refl | | | | |
   apply le_lift_prod ]; auto.
  apply le_lift_Munit; auto.
  split; trivial; generalize Heq; clear Heq; expr_simpl;
   intro Heq; apply leb_complete_conv in Heq; apply nat_eqb_eq; omega.
  (* inductive case *)
  unfold drestr.
  rewrite (Mlet_eq_compat (eq_distr_intro  _ _ (deno_cond_elim E (0%nat <! Elen L)
   (c ++ unroll_while (0%nat <! Elen L) c n) nil m1)) (Oeq_refl _)),
  (Mlet_eq_compat (eq_distr_intro  _ _ (deno_cond_elim E (0%nat <! Elen L)
   (c ++ unroll_while (0%nat <! Elen L) c n) nil m2)) (Oeq_refl _)).
  simpl WitIter; unfold DistrSel; simpl fst; simpl snd.
  setoid_rewrite (@HI_syn _ _ _ Hm).
  destr_sig.
  case_eq (@E.eval_expr _ T.Bool (0%nat <! Elen L) m1); intro Heq;
   setoid_rewrite Heq.
  (* [guard = true] *)
  rewrite 2 deno_app, 2 Mcomp.
  destruct (list_eq_dec (@A_eqb_dec k) (firstn (Size k) (m1 L))
   (firstn (Size k) (m2 L))) as [Hhead | Hhead].
  (* same head *)
  destruct (req_mem_dec {{L}} m1 m2) as [ Heq' | Heq' ].
  (* same list *)
  apply le_lift_weaken with ((I /-\ EP1 (Elen L =?= 0%nat)) k)
   ((R1 * (lam k)))%R (max (D0 + R1 ** (ep k))%U ((ep k) + (lam k) ** D0)%U);
   [ trivial | auto with real | repeat multRU_simpl; repeat Usimpl; auto | ].
  eapply le_lift_Mlet with (R2:=(I /-\ kreq_mem {{L}}) k).
  apply (cover_eq_prod _ _ (@mem_eqU_spec k) (@mem_eqU_spec k)); auto.
  refine (le_lift_discr_witness _ _ (@mem_eqU_spec k) (@mem_eqU_spec k)
   (sem_discr _ _ _) (sem_discr _ _ _) (Hd (conj Hm Heq'))).
  trivial.
  refine (Hd (conj Hm Heq')).
  intros m1' m2' Hm'.
  apply (IHn _ _ (proj1 Hm')).
  (* diff list *)
  apply le_lift_weaken with ((I /-\ EP1 (Elen L =?= 0%nat)) k)
   ((R1 * (lam k)))%R (max (D0 + R1 ** (ep k))%U ((ep k) + (lam k) ** D0)%U);
   [ trivial | auto with real | repeat multRU_simpl; repeat Usimpl; auto | ].
  destr_sig.
  assert (Hp: (I /-\ (fun (k : nat) (m1 m2 : Mem.t k) =>
   firstn (Size k) (m1 L) = firstn (Size k) (m2 L) /\
   m1 L <> m2 L)) _  m1 m2) by (repeat split; trivial;
    intros H'; elim Heq'; intros t v Hv;
     Vset_mem_inversion Hv; subst; trivial).
  eapply le_lift_Mlet.
  apply (cover_eq_prod _ _ (@mem_eqU_spec k) (@mem_eqU_spec k)); auto.
  refine (le_lift_discr_witness _ _ (@mem_eqU_spec k) (@mem_eqU_spec k)
   (sem_discr _ _ _) (sem_discr _ _ _) (Hd0 Hp)).
  trivial.
  apply  (Hd0 Hp).
  intros m1' m2' Hm'.
  apply (IHn _ _ Hm').
  (* diff head *)
  apply le_lift_weaken with ((I /-\ EP1 (Elen L =?= 0%nat)) k)
   ((lam k) * R1)%R (max ((ep k) + (lam k) ** D0)%U (D0 + R1 ** (ep k))%U);
   [ trivial | auto with real | repeat multRU_simpl; repeat Usimpl; auto | ].
  destr_sig.
  eapply le_lift_Mlet.
  apply (cover_eq_prod _ _ (@mem_eqU_spec k) (@mem_eqU_spec k)); auto.
  refine (le_lift_discr_witness _ _ (@mem_eqU_spec k) (@mem_eqU_spec k)
   (sem_discr _ _ _) (sem_discr _ _ _) (Hd0 (conj Hm Hhead))).
  trivial.
  apply (Hd0 (conj Hm Hhead)).
  intros m1' m2' Hm'.
  refine (WitD_eq_L n (proj1 Hm') (proj2 Hm')).
    (* [guard = false] *)
  rewrite 2 deno_nil, 3 Mlet_unit.
  eapply le_lift_weaken with  ((I /-\ EP1 (Elen L =?= 0%nat)) k) R1 D0; auto.
  eapply le_lift_eq_compat; [ apply Oeq_refl | | | | |
   apply (WitD_guard_false  n Hm Heq)  ]; auto.
 Qed.

End LOOP_RULE.


From MatchingLogic Require Export Logic
                                  Theories.Definedness
                                  DerivedOperators
                                  Theories.Sorts
                                  Helpers.FOL_helpers.
Import MatchingLogic.Syntax.Notations MatchingLogic.DerivedOperators.Notations.
From Coq Require Import ssreflect ssrfun ssrbool.
Require Export extralibrary
               Coq.Program.Wf
               Lia
               FunctionalExtensionality
               Logic.PropExtensionality
               Program.Equality.
From stdpp Require Import countable.
Require Export Vector PeanoNat String Arith.Lt.

Ltac separate :=
match goal with
| [H : is_true (andb _ _) |- _] => apply andb_true_iff in H as [?E1 ?E2]
| |- is_true (andb _ _) => apply andb_true_iff
end.

Definition vec {A : Set} := @t A.

Lemma Forall_map (T : Set) n (l : vec n) : forall (P : T -> Prop) (f : T -> T),
  (forall x, P x -> P (f x))
->
  Forall P l -> Forall P (map f l).
Proof.
  induction l; intros P f H; constructor;
  inversion H0; subst. auto.
  apply IHl; auto. simpl_existT. subst. auto.
Qed.

Theorem fold_left_map  (T Q : Set) n (v : vec n) :
   forall (App : Q -> T -> Q) (start : Q) f,
  fold_left App start (map f v) = @fold_left T Q (fun Acc x => App Acc (f x)) start _ v.
Proof.
  induction v; intros App start f; simpl; auto.
Qed.

Lemma map_Forall (T : Set) n (l : vec n) : forall (P : T -> Prop) (f : T -> T),
  (forall x, P (f x) -> P x)
->
  Forall P (map f l) -> Forall P l.
Proof.
  induction l; intros P f H; constructor;
  inversion H0; subst. auto.
  eapply IHl; eauto. simpl_existT. now subst.
Qed.

Lemma Forall_map_ext (T : Set) n (l : vec n) : forall (P : T -> Prop) (f : T -> T),
  (forall x, In x l -> P x -> P (f x))
->
  Forall P l -> Forall P (map f l).
Proof.
  induction l; intros P f H; constructor;
  inversion H0; subst. auto. apply H. constructor. auto.
  apply IHl; auto. intros x H1 H2. apply H. constructor 2. auto. auto. simpl_existT. now subst.
Qed.

Lemma map_Forall_ext (T : Set) n (l : vec n) : forall (P : T -> Prop) (f : T -> T),
  (forall x, In x l -> P (f x) -> P x)
->
  Forall P (map f l) -> Forall P l.
Proof.
  induction l; intros P f H; constructor;
  inversion H0; subst. auto. apply H. constructor; auto. auto.
  eapply IHl; auto. intros x H1 H2. apply H. constructor 2. auto. exact H2. simpl_existT.
  now subst.
Qed.

Lemma Forall_impl_ext  (A : Set) (P Q : A → Prop) n (l : vec n) :
   (∀ a : A, In a l -> P a → Q a) → Forall P l → Forall Q l.
Proof.
  induction l; intros H H0; constructor; inversion H0; subst.
  apply H. constructor; auto. auto.
  apply IHl; auto. intros a H1 H2. apply H; auto. constructor 2. auto.
  simpl_existT. now subst.
Qed.

Global Hint Constructors Forall : core.

Class funcs_signature :=
  { funs : Set; funs_eqdec : EqDecision funs; ar_funs : funs -> nat }.

Coercion funs : funcs_signature >-> Sortclass.

Class preds_signature :=
  { preds : Set; preds_eqdec : EqDecision preds; ar_preds : preds -> nat }.

Class FOL_variables :=
  {
    vars : Set;
    var_eqdec : EqDecision vars;
    var_countable : Countable vars;
    var_infinite : Infinite vars;
  }.

Coercion preds : preds_signature >-> Sortclass.

Section fix_signature.

  Context {Σ_vars : FOL_variables}.
  Context {Σ_funcs : funcs_signature}.

  Definition var_fresh (l : list vars) : vars := @infinite_fresh _ var_infinite l.

  Unset Elimination Schemes.
  Inductive term  : Set :=
  | bvar : nat -> term
  | fvar : vars -> term
  | func : forall (f : funs), @vec term (ar_funs f) -> term.
  Set Elimination Schemes.

  Fixpoint fsubst_term (t0 t : term) (n : vars) : term :=
  match t0 with
  | fvar t' => if var_eqdec t' n then t else t0
  | bvar _ => t0
  | func f v => func f (map (fun x => fsubst_term x t n) v)
  end.

  Fixpoint bsubst_term (t0 t : term) (n : nat) : term :=
  match t0 with
  | bvar t' => match compare_nat t' n with
               | Nat_less _ _ _ => bvar t'
               | Nat_equal _ _ _ => t
               | Nat_greater _ _ _ => bvar t' (* (pred t') ? According to Leroy *)
               end
  | fvar _ => t0
  | func f v => func f (map (fun x => bsubst_term x t n) v)
  end.

  Context {Σ_preds : preds_signature}.

  Inductive form  : Type :=
  | fal : form
  | atom : forall (P : preds), @vec term (ar_preds P) -> form
  | impl : form  -> form  -> form
  | exs : form  -> form.

  Fixpoint fsubst_form (phi : form) (t : term) (n: vars) : form :=
    match phi with
    | fal => fal
    | atom P v => atom P (map (fun x => fsubst_term x t n) v)
    | impl phi1 phi2 => impl (fsubst_form phi1 t n) (fsubst_form phi2 t n)
    | exs phi => exs (fsubst_form phi t n)
    end.

  Fixpoint bsubst_form (phi : form) (t : term) (n: nat) : form :=
    match phi with
    | fal => fal
    | atom P v => atom P (map (fun x => bsubst_term x t n) v)
    | impl phi1 phi2 => impl (bsubst_form phi1 t n) (bsubst_form phi2 t n)
    | exs phi => exs (bsubst_form phi t (S n))
    end.

  Inductive ForallT {A : Set} (P : A -> Type) : forall {n}, vec n -> Type :=
  | ForallT_nil : ForallT P (nil)
  | ForallT_cons : forall n (x : A) (l : vec n), P x -> ForallT P l -> ForallT P (@cons A x n l).

  Inductive vec_in {A : Set} (a : A) : forall {n}, vec n -> Type :=
  | vec_inB {n} (v : vec n) : vec_in a (@cons _ a n v)
  | vec_inS a' {n} (v : vec n) : vec_in a v -> vec_in a (@cons _ a' n v).
  Hint Constructors vec_in : core.

  Lemma term_rect' (p : term -> Set) :
    (forall x, p (fvar x)) ->
    (forall x, p (bvar x)) ->
    (forall F v, (ForallT p v) -> p (func F v)) -> forall (t : term), p t.
  Proof.
    intros f1 f2 f3. fix strong_term_ind' 1. destruct t as [n|n|F v].
    - apply f2.
    - apply f1.
    - apply f3. induction v.
      + econstructor.
      + econstructor. now eapply strong_term_ind'. eauto.
  Qed.

  Lemma term_rect (p : term -> Set) :
    (forall x, p (fvar x)) -> (forall x, p (bvar x)) -> (forall F v, (forall t, vec_in t v -> p t) -> p (func F v)) -> forall (t : term), p t.
  Proof.
    intros f1 f2 f3. eapply term_rect'.
    - apply f1.
    - apply f2.
    - intros F v H. apply f3. intros t. induction 1; inversion H; subst; eauto.
      apply Eqdep_dec.inj_pair2_eq_dec in H3; subst; eauto. decide equality.
  Qed.

  Lemma term_ind (p : term -> Prop) :
    (forall x, p (fvar x)) -> (forall x, p (bvar x)) -> (forall F v (IH : forall t, In t v -> p t), p (func F v)) -> forall (t : term), p t.
  Proof.
    intros f1 f2 f3. eapply term_rect'.
    - apply f1.
    - apply f2.
    - intros F v H. apply f3. intros t. induction 1; inversion H; subst; eauto.
      apply Eqdep_dec.inj_pair2_eq_dec in H3; subst; eauto. decide equality.
  Qed.

  Fixpoint wf_term (t : term) (n : nat) : bool :=
  match t with
   | bvar x => x <? n
   | fvar x => true
   | func f x => fold_right (fun t Acc => andb Acc (wf_term t n)) x true
  end.

  Fixpoint wf_form (F : form) (n : nat) : bool :=
  match F with
   | fal => true
   | atom P x => fold_right (fun t Acc => andb Acc (wf_term t n)) x true
   | impl x x0 => wf_form x n && wf_form x0 n
   | exs x => wf_form x (S n)
  end.

  Theorem wf_increase_term :
    forall t n, wf_term t n -> forall n', n' >= n -> wf_term t n'.
  Proof.
    induction t; intros n H n' H0; auto.
    * simpl in *. apply Nat.leb_le in H. apply Nat.leb_le. lia.
    * simpl in *. induction v; auto; simpl.
      simpl in H. do 2 separate.
      erewrite IH. split; auto. apply IHv; auto.
      - intros t H n1 H1 n'0 H2. eapply IH. now constructor. exact H1. auto.
      - constructor.
      - exact E2.
      - auto.
  Qed.

  Theorem wf_increase :
    forall φ n, wf_form φ n -> forall n', n' >= n -> wf_form φ n'.
  Proof.
    induction φ; intros n H n' H0; auto.
    * simpl in *. induction v; auto; simpl.
      simpl in H. do 2 separate.
      erewrite wf_increase_term. split; auto. apply IHv; auto.
      - eapply wf_increase_term. exact E2. auto.
      - auto.
    * simpl in *. apply andb_true_iff in H as [E1 E2].
      erewrite IHφ1, IHφ2; [ auto | | | |]; eassumption.
    * simpl in *. erewrite IHφ. 2: exact H. auto. lia.
  Qed.

  Theorem wf_term_subst :
    forall b t n, wf_term b (S n) -> wf_term t n ->
      wf_term (bsubst_term b t n) n.
  Proof.
    induction b; intros t n H H0; inversion H; subst.
    * constructor.
    * simpl. break_match_goal.
      - simpl. now apply Nat.ltb_lt.
      - auto.
      - simpl. apply Nat.ltb_lt in H2. lia.
    * simpl in *; induction v; simpl in *; auto.
      do 2 separate. rewrite IH; auto. constructor. split; auto.
      apply IHv; auto. intros t0 H. apply IH. now constructor 2.
  Qed.

  Theorem wf_form_subst :
    forall φ t n, wf_form φ (S n) -> wf_term t n ->
      wf_form (bsubst_form φ t n) n.
  Proof.
    induction φ; intros t n H H0; simpl; auto.
    * simpl in *; induction v; simpl in *; auto. do 2 separate.
      rewrite wf_term_subst; auto. split; auto.
      apply IHv; auto.
    * simpl in H. separate. rewrite IHφ1; auto. rewrite IHφ2; auto.
    * simpl in H. subst. apply IHφ; auto. eapply wf_increase_term. exact H0.
      lia.
  Qed.

End fix_signature.

Section semantics.
  Context {Σ_vars : FOL_variables}.
  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Variable domain : Set.

  Class interp := B_I
    {
      i_f : forall f : funs, @vec domain (ar_funs f) -> domain ;
      i_P : forall P : preds, @vec domain (ar_preds P) -> bool ; (* for decidability *)
    }.
    Context {I : interp }.
    Definition env := vars -> domain. (* for free vars *)
    Variable failure : domain. (* for wrong evaluation!!! *)

    Fixpoint mmap {A B : Type} (f : A -> option B) {n : nat} (v : t A n) :
      option (t B n) :=
    match v in (t _ n0) return (option (t B n0)) with
    | nil => Some nil
    | @cons _ a n0 v' => match f a with
                         | None => None
                         | Some x => match mmap f v' with
                                     | None => None
                                     | Some xs => Some (cons x xs)
                                     end
                         end
    end.

    Fixpoint eval (rho : env) (t : term) : domain :=
    match t with
    | fvar s => rho s
    | bvar s => failure (* for wf terms, this is never used *)
    | func f v => i_f f (Vector.map (eval rho) v)
    end.

    Definition update_env (ρ : env) (x : vars) (d : domain) : env :=
      fun v => if var_eqdec v x then d else ρ v.

    Import List.
    Import ListNotations.

    Fixpoint term_vars (t : term) : list vars :=
    match t with
     | bvar x => []
     | fvar x => [x]
     | func f x => Vector.fold_right (fun t Acc => term_vars t ++ Acc) x []
    end.

    Fixpoint form_vars (f : form) : list vars :=
    match f with
     | fal => []
     | atom P x => Vector.fold_right (fun t Acc => term_vars t ++ Acc) x []
     | impl x x0 => form_vars x ++ form_vars x0
     | exs x => form_vars x
    end.

    Fixpoint form_size (f : form) : nat :=
    match f with
     | fal => 0
     | atom P x => 0
     | impl x x0 => S (form_size x + form_size x0)
     | exs x => S (form_size x)
    end.

    Theorem subst_var_size :
      forall f x y, form_size f = form_size (bsubst_form f (fvar x) y).
    Proof.
      induction f; intros x y; auto; simpl.
      - now rewrite -> (IHf1 x y), -> (IHf2 x y).
      - now rewrite -> (IHf x (S y)).
    Qed.

    Program Fixpoint sat (rho : env) (phi : form) {measure (form_size phi)} : Prop :=
    match phi with
    | atom P v => i_P P (Vector.map (eval rho) v) = true
    | fal => False
    | impl phi psi => sat rho phi -> sat rho psi
    | exs phi => let x := var_fresh (form_vars phi) in
      exists d : domain, sat (update_env rho x d) (bsubst_form phi (fvar x) 0)
    end.
    Next Obligation. intros. subst. simpl; lia. Defined.
    Next Obligation. intros. subst. simpl; lia. Defined.
    Next Obligation. intros. subst. simpl. rewrite <- subst_var_size. lia. Defined.
    Next Obligation. Tactics.program_simpl. Defined.

    Proposition sat_atom : forall ρ P v, sat ρ (atom P v) =
                                            (i_P P (Vector.map (eval ρ) v) = true).
    Proof. reflexivity. Qed.
    Proposition sat_fal : forall ρ, sat ρ fal = False.
    Proof. reflexivity. Qed.
    Proposition sat_impl : forall ρ φ₁ φ₂, sat ρ (impl φ₁ φ₂) =
                                            (sat ρ φ₁ -> sat ρ φ₂).
    Proof.
      intros ρ φ₁ φ₂. unfold sat, sat_func.
      rewrite fix_sub_eq.
      Tactics.program_simpl. unfold projT1, projT2.
      destruct X; auto with f_equal.
      { f_equal. apply propositional_extensionality.
        epose proof (H _). epose proof (H _).
        apply ZifyClasses.eq_iff in H0. apply ZifyClasses.eq_iff in H1. split; intros.
        - eapply H0 in H2. exact H2. apply H1. auto.
        - eapply H0 in H2. exact H2. apply H1. auto.
      }
      { f_equal. apply functional_extensionality; auto. }
      { f_equal. }
    Qed.
    Proposition sat_exs : forall ρ φ, sat ρ (exs φ) =
                        (let x := var_fresh (form_vars φ) in
      exists d : domain, sat (update_env ρ x d) (bsubst_form φ (fvar x) 0)).
    Proof.
      intros ρ φ. unfold sat, sat_func.
      rewrite fix_sub_eq.
      Tactics.program_simpl. unfold projT1, projT2.
      destruct X; auto with f_equal.
      { f_equal. apply propositional_extensionality.
        epose proof (H _). epose proof (H _).
        apply ZifyClasses.eq_iff in H0. apply ZifyClasses.eq_iff in H1. split; intros.
        - eapply H0 in H2. exact H2. apply H1. auto.
        - eapply H0 in H2. exact H2. apply H1. auto.
      }
      { f_equal. apply functional_extensionality; auto. }
      { f_equal. }
    Qed.

    Notation "rho ⊨ phi" := (sat rho phi) (at level 20).

  Theorem sat_dec : forall sz φ, form_size φ <= sz -> forall ρ, {ρ ⊨ φ} + {~ ρ ⊨ φ}.
  Proof.
    induction sz; intros φ H; destruct φ; simpl in H; try lia; intros ρ.
    * right. auto.
    * rewrite sat_atom. apply bool_dec.
    * right. auto.
    * rewrite sat_atom. apply bool_dec.
    * destruct (IHsz φ1 ltac:(lia) ρ), (IHsz φ2 ltac:(lia) ρ).
      1, 3-4: left; rewrite sat_impl; intros; auto.
      congruence.
      right. rewrite sat_impl. intros. auto.
    * rewrite sat_exs. simpl.
      epose proof (IHsz (bsubst_form φ (fvar (var_fresh (form_vars φ))) 0) _).
      Search "ex" not.
      admit. (* TODO: not trivial, maybe using size based induction *)
  Abort.

End semantics.

Section proof_system.
  Context {Σ_vars : FOL_variables}.
  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Fixpoint quantify_term (t : term) (v : vars) (n : nat) : term :=
  match t with
   | bvar x => bvar x
   | fvar x => if var_eqdec v x then bvar n else fvar x
   | func f x => func f (Vector.map (fun t => quantify_term t v n) x)
  end.

  Fixpoint quantify_form (φ : form) (v : vars) (n : nat) : form :=
  match φ with
   | fal => fal
   | atom P x => atom P (Vector.map (fun t => quantify_term t v n) x)
   | impl x x0 => impl (quantify_form x v n) (quantify_form x0 v n)
   | exs x => exs (quantify_form x v (S n))
  end.

  Reserved Notation "Γ ⊢_FOL form" (at level 50).
  Inductive Hilbert_proof_sys (Γ : (list form)): form -> Set :=
  | AX (φ : form)             : wf_form φ 0 -> List.In φ Γ -> Γ ⊢_FOL φ
  | P1F (φ ψ : form)          : wf_form φ 0 -> wf_form ψ 0 -> Γ ⊢_FOL impl φ (impl ψ φ)
  | P2F (φ ψ ξ : form)        : wf_form φ 0 -> wf_form ψ 0 -> wf_form ξ 0 ->
    Γ ⊢_FOL impl (impl φ (impl ψ ξ)) (impl (impl φ ψ) (impl φ  ξ))
  | P3F (φ : form)            : wf_form φ 0 ->
    Γ ⊢_FOL impl (impl (impl φ fal) fal) φ
  | MPF (φ1 φ2 : form)        : wf_form φ1 0 -> wf_form (impl φ1 φ2) 0 ->
    Γ ⊢_FOL φ1 -> Γ ⊢_FOL impl φ1 φ2 -> Γ ⊢_FOL φ2
  | Q5F (φ : form) (t : term) :
    wf_form (exs φ) 0 -> wf_term t 0 ->
    Γ ⊢_FOL impl (bsubst_form φ t 0) (exs φ)
  | Q6F (φ ψ : form)(x : vars) :
    wf_form φ 0 -> wf_form ψ 0 -> Γ ⊢_FOL impl φ ψ ->
    ~List.In x (form_vars ψ)
  ->
    Γ ⊢_FOL impl (exs (quantify_form φ x 0)) ψ
  where "Γ ⊢_FOL form" := (Hilbert_proof_sys Γ form).

End proof_system.

Section soundness_completeness.
  Context {Σ_vars : FOL_variables}.
  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Notation "rho ⊨_FOL phi" := (sat _ _ _ rho phi) (at level 50).
  Notation "Γ ⊢_FOL form" := (Hilbert_proof_sys Γ form) (at level 50).

  Definition valid A phi :=
    forall (D : Set) (fail : D) (I : interp D) (rho : vars -> D),(forall Phi, List.In Phi A -> sat D fail rho Phi)
      -> sat D fail rho phi.

  Theorem soundness :
    forall φ Γ, Γ ⊢_FOL φ -> valid Γ φ.
  Proof.
    intros φ Γ H. induction H; subst; unfold valid; intros.
    * now apply H.
    * do 2 rewrite sat_impl. intros. auto.
    * repeat rewrite sat_impl. intros. apply H0; auto.
    * repeat rewrite sat_impl. intros.
      admit.
    * unfold valid in *.
      apply IHHilbert_proof_sys1 in H1 as IH1.
      apply IHHilbert_proof_sys2 in H1 as IH2. rewrite sat_impl in IH2. now apply IH2.
    * rewrite -> sat_impl, -> sat_exs. intros.
      exists (eval D fail rho t). clear H.
      generalize dependent φ. induction φ; intros; auto.
      - admit.
      - admit.
      - admit.
      (* TODO... *)
    * rewrite -> sat_impl, -> sat_exs. intros. unfold valid in *.
      apply IHHilbert_proof_sys in H0. rewrite sat_impl in H0. apply H0.
      destruct H1. simpl in H1.
      remember (var_fresh (form_vars (quantify_form φ x 0))) as FF.
      admit. (* TODO... *)
  Admitted.

  Theorem completeness :
    forall φ Γ, valid Γ φ -> Γ ⊢_FOL φ. Admitted.
End soundness_completeness.

Section FOL_ML_correspondence.
  Context {Σ_vars : FOL_variables}.
  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Inductive Symbols : Set :=
  | sym_fun   (name : funs)
  | sym_pred  (name : preds)
  | sym_import_definedness (d : Definedness.Symbols).

  Lemma Symbols_dec : forall (s1 s2 : Symbols), {s1 = s2} + {s1 <> s2}.
  Proof.
    repeat decide equality.
    apply Σ_funcs.
    apply Σ_preds.
  Qed.

  Instance FOLVars : MLVariables :=
  {|
    Syntax.evar := vars;
    Syntax.svar := vars;
    evar_eqdec := var_eqdec;
    svar_eqdec := var_eqdec;
    evar_countable := var_countable;
    svar_countable := var_countable;
    evar_infinite := var_infinite;
    svar_infinite := var_infinite;
  |}.
  Instance sig : Signature :=
  {|
    variables := FOLVars;
    symbols := Symbols;
    sym_eq := Symbols_dec
  |}.

  Instance definedness_syntax : Definedness.Syntax :=
  {|
     Definedness.inj := sym_import_definedness;
  |}.

  Fixpoint convert_term (t : term) : Pattern :=
  match t with
   | bvar x => patt_bound_evar x
   | fvar x => patt_free_evar x
   | func f x => fold_left (fun Acc t => patt_app Acc (convert_term t))
                  (patt_sym (sym_fun f)) x
  end.

  Fixpoint convert_form (f : form) : Pattern :=
  match f with
   | fal => patt_bott
   | atom P x => fold_left (fun Acc t => patt_app Acc (convert_term t))
                  (patt_sym (sym_pred P)) x
   | impl x x0 => patt_imp (convert_form x) (convert_form x0)
   | exs x => patt_exists (convert_form x)
  end.

  Inductive AxName :=
  | AxDefinedness (name : Definedness.AxiomName)
  | AxFun (f : funs)
  | AxPred (p : preds).

  Fixpoint add_forall_prefix (n : nat) (base : Pattern) {struct n} : Pattern :=
  match n with
  | 0 => base
  | S n' => patt_forall (add_forall_prefix n' base)
  end.

  Fixpoint make_list1 (n : nat) : list nat :=
  match n with
  | 0 => []
  | S n' => n :: make_list1 n'
  end.

  Fixpoint make_list0 (n : nat) : list nat :=
  match n with
  | 0 => []
  | S n' => n' :: make_list0 n'
  end.

  Definition axiom (name : AxName) : Pattern :=
  match name with
  | AxDefinedness name' => Definedness.axiom name'
  | AxFun f             => add_forall_prefix (ar_funs f) (patt_exists (patt_equal
                          (List.fold_left
                            (fun Acc (x : nat) => patt_app Acc (patt_bound_evar x))
                            (make_list1 (ar_funs f)) (patt_sym (sym_fun f)))
                          (patt_bound_evar 0)))

  | AxPred p            => let φ := (List.fold_left
                            (fun Acc (x : nat) => patt_app Acc (patt_bound_evar x))
                            (make_list0 (ar_preds p)) (patt_sym (sym_pred p))) in
                          add_forall_prefix (ar_preds p)
                            (patt_or (patt_equal φ patt_top) (patt_equal φ patt_bott))
  end.

  Definition named_axioms : NamedAxioms := {| NAName := AxName; NAAxiom := axiom; |}.
  Definition base_FOL_theory : Theory := theory_of_NamedAxioms named_axioms.

  Definition from_FOL_theory (Γ : list form) : Theory :=
    List.fold_right (fun x Acc => {[ convert_form x ]} ∪ Acc) base_FOL_theory Γ.

  Notation "Γ ⊢_FOL form" := (Hilbert_proof_sys Γ form) (at level 50).
  Notation "Γ ⊢_ML form" := (ML_proof_system Γ form) (at level 50).

  Theorem closed_term_FOL_ML : forall t n m,
    wf_term t n -> well_formed_closed_aux (convert_term t) n m.
  Proof.
    induction t; intros n m H; auto.
    * simpl in *.
      remember (@patt_sym sig (sym_fun F)) as start.
      assert (is_true (well_formed_closed_aux start n m)). { rewrite Heqstart. auto. }
      clear Heqstart. generalize dependent start. induction v.
      - simpl. auto.
      - intros start H0. simpl. simpl in H. separate.
        apply IHv; auto.
        intros t H1 n1 m0 H2. apply IH. now constructor 2. auto.
        simpl. rewrite -> H0, -> IH; auto. constructor.
  Qed.

  Theorem closed_form_FOL_ML : forall φ n m,
    wf_form φ n -> well_formed_closed_aux (convert_form φ) n m.
  Proof.
    induction φ; intros n m H; simpl; auto.
    * simpl in *.
      remember (@patt_sym sig (sym_pred P)) as start.
      assert (is_true (well_formed_closed_aux start n m)). { rewrite Heqstart. auto. }
      clear Heqstart. generalize dependent start. induction v.
      - simpl. auto.
      - simpl in *. separate. intros start H.
        apply IHv; auto. simpl. rewrite -> closed_term_FOL_ML, -> H; auto.
    * simpl in *. separate. subst. rewrite -> IHφ1, -> IHφ2; auto.
  Qed.

  Theorem positive_term_FOL_ML : forall t,
    well_formed_positive (convert_term t).
  Proof.
    induction t; auto.
    * simpl. remember (@patt_sym sig (sym_fun F)) as start.
      assert (is_true (well_formed_positive start)) by now rewrite Heqstart.
      clear Heqstart. generalize dependent start.
      induction v; intros start H; auto.
      simpl. apply IHv.
      - intros. apply IH; auto. now constructor 2.
      - simpl. rewrite -> H, -> IH; auto. constructor.
  Qed.

  Theorem positive_form_FOL_ML : forall φ,
    well_formed_positive (convert_form φ).
  Proof.
    induction φ; auto.
    * simpl. remember (@patt_sym sig (sym_pred P)) as start.
      assert (is_true (well_formed_positive start)) by now rewrite Heqstart.
      clear Heqstart. generalize dependent start. induction v; intros start H; auto.
      simpl. apply IHv.
      simpl. rewrite -> H, -> positive_term_FOL_ML; auto.
    * simpl. rewrite -> IHφ1, -> IHφ2; auto.
  Qed.

  Corollary wf_term_FOL_ML : forall t,
    wf_term t 0 -> well_formed (convert_term t).
  Proof.
    intros t H. unfold well_formed. separate. split.
    * apply positive_term_FOL_ML.
    * now apply closed_term_FOL_ML.
  Qed.

  Corollary wf_form_FOL_ML : forall φ,
    wf_form φ 0 -> well_formed (convert_form φ).
  Proof.
    intros φ H. unfold well_formed. separate. split.
    * apply positive_form_FOL_ML.
    * now apply closed_form_FOL_ML.
  Qed.

  Theorem in_FOL_theory : forall Γ x,
    List.In x Γ -> convert_form x ∈ from_FOL_theory Γ.
  Proof.
    induction Γ; intros x H.
    * inversion H.
    * simpl. inversion H; subst.
      - apply sets.elem_of_union_l. now apply sets.elem_of_singleton_2.
      - apply IHΓ in H0.
        now apply sets.elem_of_union_r.
  Qed.

  Hint Resolve wf_form_FOL_ML : core.
  Hint Resolve wf_term_FOL_ML : core.

  Lemma pointwise_fold : forall n0 (v : @vec term n0) start (F : Pattern -> Pattern),
    (forall (p1 p2 : Pattern), F (patt_app p1 p2) = patt_app (F p1) (F p2)) ->
    F (fold_left (λ (Acc : Pattern) (t : term), (Acc $ convert_term t)%ml)
     start v) =
  (fold_left (λ (Acc : Pattern) (t : term), (Acc $ F (convert_term t))%ml)
     (F start) v).
  Proof.
    induction v; intros start F H.
    * simpl. auto.
    * simpl. rewrite -> IHv, -> H. auto. apply H.
  Qed.

  Corollary evar_quantify_fold : forall n0 (v : @vec term n0) start x n,
    evar_quantify x n (fold_left (λ (Acc : Pattern) (t : term), (Acc $ convert_term t)%ml)
     start v) =
  (fold_left (λ (Acc : Pattern) (t : term), (Acc $ evar_quantify x n (convert_term t))%ml)
     (evar_quantify x n start) v).
  Proof.
    intros. apply pointwise_fold. intros. auto.
  Qed.

  (** This is boiler-plate *)
  Corollary bevar_subst_fold : forall n0 (v : @vec term n0) start x n,
    bevar_subst (fold_left (λ (Acc : Pattern) (t : term), (Acc $ convert_term t)%ml)
     start v) x n =
  (fold_left (λ (Acc : Pattern) (t : term), (Acc $ bevar_subst (convert_term t) x n)%ml)
     (bevar_subst start x n) v).
  Proof.
    induction v; intros.
    * simpl. auto.
    * simpl. rewrite IHv. auto.
  Qed.

  Theorem quantify_term_correspondence :
    forall t n x, convert_term (quantify_term t x n) =
                  evar_quantify x n (convert_term t).
  Proof.
    induction t; intros n x'; auto; cbn.
    * now destruct (var_eqdec x' x).
    * remember (@patt_sym sig (sym_fun F)) as start.
      rewrite fold_left_map.
      assert (start = evar_quantify x' n start) by now rewrite Heqstart.
      clear Heqstart.
      generalize dependent start.
      induction v; intros; simpl; auto.
      rewrite IHv.
      - intros. apply IH. now constructor 2.
      - simpl. rewrite <- H, IH, double_evar_quantify; auto. constructor.
      - do 2 rewrite evar_quantify_fold.
        simpl. rewrite -> IH, -> double_evar_quantify. auto. simpl.
        constructor.
  Qed.

  Theorem quantify_form_correspondence :
    forall φ n x, convert_form (quantify_form φ x n) =
                  evar_quantify x n (convert_form φ).
  Proof.
    induction φ; intros n x'; auto; cbn.
    * remember (@patt_sym sig (sym_pred P)) as start.
      rewrite fold_left_map.
      assert (start = evar_quantify x' n start) by now rewrite Heqstart.
      clear Heqstart.
      generalize dependent start.
      induction v; intros; simpl; auto.
      rewrite IHv.
      - simpl. rewrite <- H, quantify_term_correspondence, double_evar_quantify; auto.
      - do 2 rewrite evar_quantify_fold.
        simpl. rewrite -> quantify_term_correspondence, -> double_evar_quantify. auto.
    * now rewrite -> IHφ1, -> IHφ2.
    * now rewrite IHφ.
  Qed.

  Theorem term_vars_free_vars_notin :
    forall t x, ~List.In x (term_vars t) -> x ∉ (free_evars (convert_term t)).
  Proof.
    induction t; intros x' H.
    * simpl. intros H0. apply H. simpl. apply sets.elem_of_singleton_1 in H0. auto.
    * intro. simpl in H0. inversion H0.
    * simpl in H. simpl.
      remember (@patt_sym sig (sym_fun F)) as start.
      assert (x' ∉ free_evars start) by now rewrite Heqstart.
      clear Heqstart. generalize dependent start.
      induction v; intros.
      - auto.
      - simpl. epose proof (IHv _ _ (start $ convert_term h)%ml _). clear IHv.
        apply H1.
      Unshelve.
        intros. apply IH. now constructor 2. auto.
        simpl in H. now apply notin_app_r in H.
        simpl in H. apply notin_app_l in H. apply IH in H.
        simpl. intro. apply elem_of_union in H1; inversion H1; contradiction.
        constructor.
  Qed.

  Theorem form_vars_free_vars_notin :
    forall φ x, ~List.In x (form_vars φ) -> x ∉ (free_evars (convert_form φ)).
  Proof.
    induction φ; intros x' H; auto.
    * intro. inversion H0.
    * simpl in H. simpl.
      remember (@patt_sym sig (sym_pred P)) as start.
      assert (x' ∉ free_evars start) by now rewrite Heqstart.
      clear Heqstart. generalize dependent start.
      induction v; intros.
      - auto.
      - simpl. epose proof (IHv _ (start $ convert_term h)%ml _). clear IHv.
        apply H1.
      Unshelve.
        simpl in H. now apply notin_app_r in H.
        simpl in H. apply notin_app_l in H. apply term_vars_free_vars_notin in H.
        simpl. intro. apply elem_of_union in H1; inversion H1; contradiction.
    * simpl in *. apply notin_app_r in H as H'. apply notin_app_l in H.
      apply IHφ1 in H. apply IHφ2 in H'.
      apply sets.not_elem_of_union. auto.
  Qed.

  Theorem bevar_subst_corr_term :
    forall b t n, wf_term t n ->
                  convert_term (bsubst_term b t n) =
                  bevar_subst (convert_term b) (convert_term t) n.
  Proof.
    induction b; intros t n H; auto.
    * simpl. now break_match_goal.
    * simpl. remember (@patt_sym sig (sym_fun F)) as start.
      rewrite fold_left_map.
      assert (start = bevar_subst start (convert_term t) n) by now rewrite Heqstart.
      clear Heqstart.
      generalize dependent start.
      induction v; intros; simpl; auto.
      rewrite IHv.
      - intros. apply IH. constructor 2; auto. auto.
      - simpl. erewrite <- H0, IH, double_bevar_subst; auto.
        apply closed_term_FOL_ML. auto. constructor.
      - do 2 rewrite bevar_subst_fold.
        simpl. erewrite IH, double_bevar_subst; auto.
        apply closed_term_FOL_ML. auto. constructor.
    Unshelve. all: exact 0.
  Qed.

  Theorem bevar_subst_corr_form :
    forall φ t n, wf_term t n ->
                  convert_form (bsubst_form φ t n) =
                  bevar_subst (convert_form φ) (convert_term t) n.
  Proof.
    induction φ; intros t n H; auto.
    * simpl.
      remember (@patt_sym sig (sym_pred P)) as start.
      rewrite fold_left_map.
      assert (start = bevar_subst start (convert_term t) n) by now rewrite Heqstart.
      clear Heqstart. revert H.
      generalize dependent start.
      induction v; intros; simpl; auto.
      rewrite IHv.
      - intros. rewrite bevar_subst_corr_term; auto.
        simpl. erewrite double_bevar_subst. rewrite <- H0. auto.
        apply closed_term_FOL_ML. auto.
      - auto.
      - do 2 rewrite bevar_subst_fold.
        simpl. erewrite bevar_subst_corr_term, double_bevar_subst. auto.
        apply closed_term_FOL_ML; auto. auto.
    * simpl. now rewrite -> IHφ1, -> IHφ2.
    * simpl. rewrite IHφ. auto. eapply wf_increase_term. apply H. lia. auto.
    Unshelve. all: exact 0.
  Qed.

  Theorem ax_in :
    forall Γ F, axiom F ∈ from_FOL_theory Γ.
  Proof.
    induction Γ; intros F.
    * simpl. unfold base_FOL_theory. econstructor.
      reflexivity.
    * simpl. apply sets.elem_of_union_r. apply IHΓ.
  Qed.

  Lemma add_forall_prefix_subst : forall n φ ψ m,
    bevar_subst (add_forall_prefix n φ) ψ m = add_forall_prefix n (bevar_subst φ ψ (m + n)).
  Proof.
    induction n; intros.
    * cbn. auto.
    * simpl. rewrite -> IHn, -> Nat.add_succ_comm. auto.
  Qed.

  Lemma subst_make_list : forall n m ψ start, m > n ->
    bevar_subst
       (List.fold_left
          (λ (Acc : Pattern) (x : nat),
             (Acc $ patt_bound_evar x)%ml)
          (make_list1 n) start)
       ψ m =
    (List.fold_left
          (λ (Acc : Pattern) (x : nat),
             (Acc $ patt_bound_evar x)%ml)
          (make_list1 n) (bevar_subst start ψ m)).
  Proof.
    induction n; intros; cbn; auto.
    rewrite IHn. lia. cbn. break_match_goal.
    * congruence.
    * lia.
    * auto.
  Qed.

  Lemma term_mu_free :
    forall t, mu_free (convert_term t).
  Proof.
    induction t; auto.
    simpl. remember (@patt_sym sig (sym_fun F)) as start.
    assert (is_true (mu_free start)) by (rewrite Heqstart; constructor). clear Heqstart.
    generalize dependent start.
    induction v; simpl.
    * intros. auto.
    * intros. eapply IHv.
      intros. apply IH. constructor 2; auto.
      simpl. rewrite H. auto. apply IH. constructor.
  Qed.

  Lemma form_mu_free:
    forall φ, mu_free (convert_form φ).
  Proof.
    induction φ; auto.
    * simpl. remember (@patt_sym sig (sym_pred P)) as start.
      assert (is_true (mu_free start)) by (rewrite Heqstart; constructor). clear Heqstart.
      generalize dependent start. induction v; simpl; auto.
      intros start H. eapply IHv.
      simpl. now rewrite -> H, -> term_mu_free.
    * simpl. now rewrite -> IHφ1, -> IHφ2.
  Qed.

  Lemma well_formed_closed_prefix φ : forall n k m,
    is_true (well_formed_closed_aux (add_forall_prefix n φ) k m) <->
    is_true (well_formed_closed_aux φ (n + k) m).
  Proof.
    induction n; simpl; auto; intros.
    do 2 rewrite andb_true_r.
    rewrite -> IHn, -> NPeano.Nat.add_succ_r. auto.
  Qed.

  Lemma well_formed_positive_prefix φ : forall n,
    is_true (well_formed_positive (add_forall_prefix n φ)) <->
    is_true (well_formed_positive φ).
  Proof.
    induction n; simpl; auto.
    do 2 rewrite andb_true_r. auto.
  Qed.

  Lemma well_formed_closed_list n : forall start m k, m > n ->
    is_true (well_formed_closed_aux start m k) ->
    is_true (well_formed_closed_aux
     (List.fold_left
        (λ (Acc : Pattern) (x : nat), (Acc $ patt_bound_evar x)%ml)
        (make_list1 n) start )
     m k).
  Proof.
    induction n; intros start m k H H0; simpl; auto.
    apply (IHn). lia. simpl. rewrite H0. simpl. apply NPeano.Nat.ltb_lt. lia.
  Qed.

  Lemma well_formed_positive_list n : forall start,
    is_true (well_formed_positive start) ->
    is_true (well_formed_positive
     (List.fold_left
        (λ (Acc : Pattern) (x : nat), (Acc $ patt_bound_evar x)%ml)
        (make_list1 n) start)).
  Proof.
    induction n; intros; simpl; auto.
    apply (IHn). simpl. rewrite H. auto.
  Qed.

  Lemma well_formed_closed_list0 n : forall start m k, m >= n ->
    is_true (well_formed_closed_aux start m k) ->
    is_true (well_formed_closed_aux
     (List.fold_left
        (λ (Acc : Pattern) (x : nat), (Acc $ patt_bound_evar x)%ml)
        (make_list0 n) start)
     m k).
  Proof.
    induction n; intros start m k H H0; simpl; auto.
    apply (IHn). lia. simpl. rewrite H0. simpl. apply NPeano.Nat.ltb_lt. lia.
  Qed.

  Lemma well_formed_positive_list0 n : forall start,
    is_true (well_formed_positive start) ->
    is_true (well_formed_positive
     (List.fold_left
        (λ (Acc : Pattern) (x : nat), (Acc $ patt_bound_evar x)%ml)
        (make_list0 n) start)).
  Proof.
    induction n; intros start H; simpl; auto.
    apply (IHn). simpl. rewrite H. auto.
  Qed.

  Theorem ax_wf :
    forall F, is_true (well_formed (axiom F)).
  Proof.
    unfold axiom. intros F.
    break_match_goal.
    * unfold Definedness.axiom. destruct name. simpl. constructor.
    * unfold well_formed, well_formed_closed. apply andb_true_intro. split.
      - apply well_formed_positive_prefix. simpl. rewrite well_formed_positive_list. auto.
        auto.
      - apply well_formed_closed_prefix. simpl. rewrite well_formed_closed_list.
        simpl. auto. lia. all: now simpl.
    * unfold well_formed, well_formed_closed. apply andb_true_intro. split.
      - apply well_formed_positive_prefix. simpl. rewrite well_formed_positive_list0. auto.
        auto.
      - apply well_formed_closed_prefix. simpl. rewrite well_formed_closed_list0.
        simpl. auto. lia. all: now simpl.
  Qed.

  Proposition term_functionality :
    forall t Γ, wf_term t 0 ->
      from_FOL_theory Γ ⊢_ML patt_exists (patt_equal (convert_term t) (patt_bound_evar 0)).
  Proof.
    induction t using term_rect; intros.
    * simpl.
      pose proof (Ex_quan (from_FOL_theory Γ ) (patt_equal (patt_free_evar x) (patt_bound_evar 0)) x).
      simpl in H0. eapply Modus_ponens. 4: exact H0.
      all: auto.
      epose proof (@patt_equal_refl _ _ (patt_free_evar x) (from_FOL_theory Γ) _).
      exact H1.
    * simpl in H. apply Nat.ltb_lt in H. lia.
    * assert (from_FOL_theory Γ ⊢_ML axiom (AxFun F)). {
        apply hypothesis. apply ax_wf. apply ax_in.
      } simpl in H1, H0.
      simpl. remember (@patt_sym sig (sym_fun F)) as start.
      assert (forall n ψ, bevar_subst start ψ n = start) as HIND.
        { intros. rewrite Heqstart. auto. }
      assert (is_true (mu_free start)) as HMUF. { rewrite Heqstart. constructor. }
      assert (is_true (well_formed start)) as WFS. { rewrite Heqstart. auto. }
      clear Heqstart. generalize dependent start.
      revert H0. induction v; intros.
      - cbn. simpl in H1. exact H1.
      - cbn in *. eapply (IHv _ _ (start $ convert_term h)%ml).
        clear IHv. separate.
        specialize (H h ltac:(constructor) Γ E2).
        remember (add_forall_prefix n
            (ex ,
             patt_equal
               (List.fold_left
                  (λ (Acc : Pattern) (x : nat), (Acc $ patt_bound_evar x)%ml)
                  (make_list1 n) (start $ patt_bound_evar (S n))%ml)
               BoundVarSugar.b0)) as A.
        pose proof (@forall_functional_subst _ _ A (convert_term h) (from_FOL_theory Γ)).
        assert (mu_free A). {
          rewrite HeqA. clear H HIND H1 HeqA E1 E2 H0 h v Γ A F WFS.
          generalize dependent start. induction n; simpl.
          * intros. repeat constructor. all: rewrite HMUF; auto.
          * intros. simpl. rewrite IHn; auto. simpl. now rewrite HMUF.
        }
        assert (well_formed (all , A)) as WfA.
        {
          rewrite HeqA. clear H E1 E2 H2 HIND H1 H H0 h v Γ H2 HeqA A F HMUF.
          unfold well_formed, well_formed_closed.
          apply eq_sym, andb_true_eq in WFS. destruct WFS.
          apply andb_true_intro. split.
          * clear H0. apply well_formed_positive_all, well_formed_positive_prefix.
            simpl. generalize dependent start. induction n; simpl; intros.
            - rewrite <- H. auto.
            - rewrite IHn; auto. simpl. rewrite <- H. auto.
          * clear H.  apply well_formed_closed_all, well_formed_closed_prefix.
            simpl. replace (0 <? S (n + 1)) with true.
            2: apply eq_sym, NPeano.Nat.ltb_lt; lia.
            repeat rewrite andb_true_r. rewrite well_formed_closed_list; auto.
            lia. simpl. apply andb_true_intro.
            split.
            - eapply wfc_aux_extend. apply eq_sym, H0. all: lia.
            - apply NPeano.Nat.ltb_lt. lia.
        }
        assert (from_FOL_theory Γ ⊢_ML (all , A and ex , patt_equal (convert_term h) BoundVarSugar.b0 )). {
          apply conj_intro_meta; auto.
          unfold well_formed. simpl. rewrite positive_term_FOL_ML.
          unfold well_formed_closed. simpl. apply wf_increase_term with (n' := 1) in E2. 2: lia.
          eapply closed_term_FOL_ML in E2.
          rewrite E2. auto.
        }
        apply Modus_ponens in H0; auto.
        2: {
          unfold well_formed in *. simpl. rewrite positive_term_FOL_ML.
          unfold well_formed_closed in *. simpl. apply wf_increase_term with (n' := 1) in E2. 2: lia.
          eapply closed_term_FOL_ML in E2.
          rewrite E2. separate.
          simpl in E0, E3. do 4 rewrite andb_true_r in E0, E3.
          rewrite -> E0, -> E3. auto.
        }
        2: {
          unfold well_formed in *. simpl. rewrite positive_term_FOL_ML.
          unfold well_formed_closed in *. simpl.
          eapply wf_increase_term with (n' := 1) in E2 as H4'. 2: lia.
          eapply closed_term_FOL_ML in H4'.
          separate. simpl in E0, E3. do 4 rewrite andb_true_r in E0, E3.
          rewrite -> E0, -> E3.
          rewrite -> bevar_subst_positive, -> bevar_subst_closed, -> closed_term_FOL_ML; auto.
          eapply wf_increase_term. eassumption. lia.
          now apply closed_term_FOL_ML.
          now apply positive_term_FOL_ML.
        }
        simpl in H0.
        rewrite -> HeqA, -> add_forall_prefix_subst in H0.
        simpl Nat.add in H0.
        replace (bevar_subst
              (ex ,
               @patt_equal sig definedness_syntax
                 (List.fold_left
                    (λ (Acc : Pattern) (x : nat),
                       (Acc $ patt_bound_evar x)%ml)
                    (make_list1 n) (start $ patt_bound_evar (S n))%ml)
                 BoundVarSugar.b0) (convert_term h) n) with
             ((ex ,
               @patt_equal sig definedness_syntax
                 (bevar_subst (List.fold_left
                    (λ (Acc : Pattern) (x : nat),
                       (Acc $ patt_bound_evar x)%ml)
                    (make_list1 n) (start $ patt_bound_evar (S n))%ml) (convert_term h) (S n))
                 BoundVarSugar.b0)) in H by auto.
        simpl in H0.
        rewrite subst_make_list in H0. lia.
        simpl in H0. rewrite HIND in H0. break_match_hyp.
        + lia.
        + exact H0.
        + lia.

        (** asserted hypotheses *)
        + apply wf_ex_to_wf_body. unfold well_formed, well_formed_closed in *.
          do 2 separate. simpl in E0, E3.
          do 4 rewrite andb_true_r in E0, E3. simpl. now rewrite -> E0, -> E3.
        + intros. simpl. rewrite HIND. erewrite well_formed_bevar_subst.
          auto.
          2: { apply closed_term_FOL_ML. inversion H0. separate. eassumption. }
          lia.
        + simpl. now rewrite -> HMUF, -> term_mu_free.
        + unfold well_formed, well_formed_closed in *.
          simpl. apply eq_sym, andb_true_eq in WFS. destruct WFS.
          rewrite <- H2, <- H3.
          simpl. rewrite -> positive_term_FOL_ML, -> closed_term_FOL_ML; auto.
          separate. auto.
  Unshelve.
    4-7: exact 0.
    ** auto.
    ** intros. apply H; auto. constructor 2; auto.
    ** now separate.
  Qed.

  Theorem arrow_1 : forall (φ : form) (Γ : list form),
    Γ ⊢_FOL φ
   ->
    from_FOL_theory Γ ⊢_ML convert_form φ.
  Proof.
    intros φ Γ IH. induction IH; intros.
    * apply hypothesis. now apply wf_form_FOL_ML. now apply in_FOL_theory.
    * simpl. apply P1; auto.
    * apply P2; auto.
    * apply P3; auto.
    * eapply Modus_ponens. 3: exact IHIH1. 3: exact IHIH2. all: auto.
      simpl in i0. separate. auto.
    * simpl.
      epose proof (term_functionality t Γ i0).
      pose proof (@exists_functional_subst _ _ (convert_form φ) (convert_term t) (from_FOL_theory Γ)).
      simpl in H0. rewrite bevar_subst_corr_form; auto.
      eapply and_impl_patt2. 4: exact H. 4: apply H0.
      all: unfold well_formed, well_formed_closed; simpl.
      all: try rewrite -> closed_term_FOL_ML, -> positive_term_FOL_ML; auto.
      apply wf_increase_term with (n := 0); auto.
      2: try rewrite -> closed_form_FOL_ML, -> positive_form_FOL_ML; auto.
      rewrite -> bevar_subst_well_formedness, -> well_formed_positive_bevar_subst.
      auto.
      1, 6: apply form_mu_free.
      apply positive_form_FOL_ML.
      apply positive_term_FOL_ML.
      apply closed_form_FOL_ML; auto.
      apply closed_term_FOL_ML; auto.
      apply wf_ex_to_wf_body. apply wf_form_FOL_ML in i. exact i.
    * simpl. rewrite quantify_form_correspondence. eapply Ex_gen; auto.
      apply form_vars_free_vars_notin. auto.
  Qed.

End FOL_ML_correspondence.

Section tests.

  Inductive PA_funcs : Set :=
    Zero : PA_funcs
  | Succ : PA_funcs
  | Plus : PA_funcs
  | Mult : PA_funcs.

  Theorem pa_funs_eqdec : EqDecision PA_funcs.
  Proof.
    unfold EqDecision, Decision; intros. decide equality.
  Qed.

  Definition PA_funcs_ar (f : PA_funcs ) :=
  match f with
   | Zero => 0
   | Succ => 1
   | Plus => 2
   | Mult => 2
   end.

  Inductive PA_preds : Set :=
    Eq : PA_preds.

  Theorem pa_preds_eqdec : EqDecision PA_preds.
  Proof.
    unfold EqDecision, Decision; intros. decide equality.
  Qed.

  Definition PA_preds_ar (P : PA_preds) :=
  match P with
   | Eq => 2
  end.

  Instance PA_funcs_signature : funcs_signature :=
  {| funs := PA_funcs ; funs_eqdec := pa_funs_eqdec; ar_funs := PA_funcs_ar |}.

  Instance PA_preds_signature : preds_signature :=
  {| preds := PA_preds ; preds_eqdec := pa_preds_eqdec; ar_preds := PA_preds_ar |}.

  Context {Σ_vars : FOL_variables}.
  Instance FOLVars2 : MLVariables :=
  {|
    Syntax.evar := vars;
    evar_eqdec := var_eqdec;
    svar_eqdec := var_eqdec;
    evar_countable := var_countable;
    svar_countable := var_countable;
    Syntax.svar := vars;
    evar_infinite := var_infinite;
    svar_infinite := var_infinite;

  |}.
  Instance sig2 : Signature :=
  {|
    variables := FOLVars;
    symbols := Symbols;
    sym_eq := Symbols_dec
  |}.

  Instance definedness_syntax2 : Definedness.Syntax :=
  {|
     Definedness.inj := sym_import_definedness;
  |}.

  Goal axiom (AxFun Mult) = patt_forall (patt_forall (patt_exists (patt_equal
             (patt_app (patt_app (patt_sym (sym_fun Mult)) (patt_bound_evar 2)) (patt_bound_evar 1))
             (patt_bound_evar 0)))).
  Proof.
    simpl. reflexivity.
  Qed.
  Goal axiom (AxPred Eq) = patt_forall (patt_forall (patt_or (patt_equal
             (patt_app (patt_app (patt_sym (sym_pred Eq)) (patt_bound_evar 1)) (patt_bound_evar 0)) patt_top)
             (patt_equal
             (patt_app (patt_app (patt_sym (sym_pred Eq)) (patt_bound_evar 1)) (patt_bound_evar 0)) patt_bott))
             ).
  Proof.
    simpl. reflexivity.
  Qed.
  Goal convert_term (func Plus (cons (func Zero nil) (cons (func Succ (cons (func Zero nil) nil)) nil))) =
     patt_app (patt_app (patt_sym (sym_fun Plus)) (patt_sym (sym_fun Zero))) (patt_app (patt_sym (sym_fun Succ)) (patt_sym (sym_fun Zero))).
   Proof.
     simpl. reflexivity.
   Qed.

End tests.