Require Export parser.
Require Export refine.

(** the security of TPU *)
Definition TPU: IA := parse
"IA [t1,t2,t3,t4] (t1) [startT] [nOk,ok,logF,endT] []
[t1->(startT)t2, t2->(nOk)t4, t4->(logF)t3, t2->(ok)t3,t3->(endT)t1]".

Eval compute in SMENI_refinement TPU TPU. (*true*)


Require Import Charge.ModularFunc.BaseFunc.
Require Import Charge.ModularFunc.ListFunc.
Require Import Charge.ModularFunc.BaseType.
Require Import Charge.ModularFunc.ListType.
Require Import Charge.ModularFunc.SemiEqDecTyp.
Require Import Charge.ModularFunc.Denotation.

Require Import Charge.Tactics.Lists.ListTacs.
Require Import Charge.Tactics.Base.MirrorCoreTacs.
Require Import Charge.Tactics.Base.DenotationTacs.

Require Import ExtLib.Core.RelDec.

Require Import MirrorCore.TypesI.
Require Import MirrorCore.Lambda.AppN.
Require Import MirrorCore.Lambda.Red.
Require Import MirrorCore.Lambda.RedAll.
Require Import MirrorCore.Lambda.Expr.

Require Import MirrorCore.RTac.Simplify.
Section Fold.
  Context {typ func : Type} {RType_typ : RType typ} {RSym_func : RSym func}.
  Context {BT : BaseType typ} {BTD : BaseTypeD BT}.
  Context {LT : ListType typ} {LTD : ListTypeD LT}.
  Context {BF : BaseFunc typ func} {LF: ListFunc typ func}.
  Context {Heq : RelDec (@eq typ)} {HC : RelDec_Correct Heq}.
  Context {Heqd : SemiEqDecTyp typ} {HeqdOk : SemiEqDecTypOk Heqd}.
  Context {Typ2_Fun : Typ2 RType_typ Fun}.
  Context {Typ0_Prop : Typ0 RType_typ Prop}.

  Context {BFOk : BaseFuncOk typ func} {LFOk : ListFuncOk typ func}.

  Context {RTypeOk_typ : RTypeOk}.
  Context {RSymOk_func : RSymOk RSym_func}.
  Context {Typ2Ok_Fun : Typ2Ok Typ2_Fun}.

  Definition foldTac (e : expr typ func) (args : list (expr typ func)) : expr typ func :=
    match listS e with
      | Some (pFold t u) =>
        match args with
          | f :: acc :: lst :: nil =>
            match baseS lst with
              | Some (pConst v lst) =>
		  	    match type_cast v (tyList u) with
		  	      | Some pf =>
                    fold_right (fun x acc => beta (beta (App (App f (mkConst u x)) acc))) acc
                       (listD (eq_rect _ typD lst _ pf))
                  | None => apps e args
                end
		  	  | Some _ => apps e args
		  	  | None =>
		  	    let (lst', e') := expr_to_list lst in
		  	      match listS e' with
		  	        | Some (pNil v) =>
		  	          match type_cast u v with
		  	            | Some pf => fold_right (fun x acc => beta (beta (App (App f x) acc))) acc lst'
		  	            | _ => fold_right (fun x acc => beta (beta (App (App f x) acc))) (apps e (f::acc::e'::nil)) lst'
		  	          end
		  	        | _ =>
		  	          fold_right (fun x acc => beta (beta (App (App f x) acc))) (apps e (f::acc::e'::nil)) lst'
		  	      end
            end
          | _ => apps e args
        end
      | _ => apps e args
    end.

  Definition FOLD := SIMPLIFY (typ := typ) (fun _ _ _ _ => (beta_all (fun _ => foldTac))).

Local Opaque beta.

Opaque baseS listS.
Locate exprD'.
  Lemma exprD_fold_const tus tvs (t u : typ) (f acc : expr typ func) (lst : list (typD u))
    (fD : exprT tus tvs (typD (typ2 u (typ2 t t)))) (accD : exprT tus tvs (typD t))
    (Hf : ExprDsimul.ExprDenote.exprD' tus tvs (typ2 u (typ2 t t)) f = Some fD)
    (Hacc : ExprDsimul.ExprDenote.exprD' tus tvs t acc = Some accD) :
    ExprDsimul.ExprDenote.exprD' tus tvs
      t (fold_right (fun x acc => beta (beta (App (App f (mkConst u x)) acc))) acc lst) =
    Some
      (fun us vs => fold_right (tyArrD2 (fD us vs)) (accD us vs) lst).
  Proof.
    induction lst; intros; subst; simpl.
    + assumption.
    + repeat reduce.
      reduce.
      rewrite bf_typeof_const.
      reduce.
      rewrite mkConst_sound.
      reduce. reflexivity.
  Qed.

  Lemma exprD_fold_expr_nil tus tvs (t u : typ) (f acc : expr typ func) (lst : list (expr typ func)) (xs ys g : expr typ func)
    (fD : exprT tus tvs (typD (typ2 u (typ2 t t)))) (accD : exprT tus tvs (typD t))
    (xsD ysD : exprT tus tvs (typD (tyList u)))
    (Hf : ExprDsimul.ExprDenote.exprD' tus tvs (typ2 u (typ2 t t)) f = Some fD)
    (Hacc : ExprDsimul.ExprDenote.exprD' tus tvs t acc = Some accD)
    (Hlst : expr_to_list ys = (lst, xs))
    (Hg : ExprDsimul.ExprDenote.exprD' tus tvs (typ2 (typ2 u (typ2 t t)) (typ2 t (typ2 (tyList u) t))) g =
        Some (fun _ _ => foldD t u))
    (Hxs : listS xs = Some (pNil u))
    (Hys : ExprDsimul.ExprDenote.exprD' tus tvs (tyList u) ys = Some ysD) :
    ExprDsimul.ExprDenote.exprD' tus tvs t
      (fold_right (fun x acc => beta (beta (App (App f x) acc))) acc lst) =
    Some
      (fun us vs => fold_right (tyArrD2 (fD us vs)) (accD us vs) (listD (ysD us vs))).
  Proof.
    generalize dependent ys; generalize dependent ysD.
    induction lst; intros; subst; simpl.
    + apply expr_to_list_nil in Hlst; subst.
      reduce. simpl. assumption.
    + reduce.
      destruct (expr_to_list_cons tus tvs _ _ Hlst H) as [? [? ?]]; subst.
      reduce; subst.
      specialize (IHlst _ _ H3 Heqo0).
      reduce. reflexivity.
  Qed.

  Lemma exprD_fold_expr tus tvs (t u : typ) (f acc : expr typ func) (lst : list (expr typ func)) (xs ys g : expr typ func)
    (fD : exprT tus tvs (typD (typ2 u (typ2 t t)))) (accD : exprT tus tvs (typD t))
    (xsD ysD : exprT tus tvs (typD (tyList u)))
    (Hf : ExprDsimul.ExprDenote.exprD' tus tvs (typ2 u (typ2 t t)) f = Some fD)
    (Hacc : ExprDsimul.ExprDenote.exprD' tus tvs t acc = Some accD)
    (Hlst : expr_to_list ys = (lst, xs))
    (Hg : ExprDsimul.ExprDenote.exprD' tus tvs (typ2 (typ2 u (typ2 t t)) (typ2 t (typ2 (tyList u) t))) g =
        Some (fun _ _ => foldD t u))
    (Hys : ExprDsimul.ExprDenote.exprD' tus tvs (tyList u) ys = Some ysD) :
    ExprDsimul.ExprDenote.exprD' tus tvs t
      (fold_right (fun x acc => beta (beta (App (App f x) acc))) (App (App (App g f) acc) xs) lst) =
    Some
      (fun us vs => fold_right (tyArrD2 (fD us vs)) (accD us vs) (listD (ysD us vs))).
  Proof.
    generalize dependent ys; generalize dependent ysD.
    induction lst; intros; subst; simpl.
    + apply expr_to_list_nil in Hlst; subst.
      reduce. reflexivity.
    + reduce.
      destruct (expr_to_list_cons tus tvs _ _ Hlst H) as [? [? ?]]; subst.
      reduce; subst.
      specialize (IHlst _ _ H3 Heqo0).
      reduce.
      reflexivity.
  Qed.

  Lemma foldTacOk : partial_reducer_ok foldTac.
  Proof.
    unfold partial_reducer_ok; intros.
    exists val; split; [|reflexivity].
    unfold foldTac.

    do 8 (destruct_exprs; try assumption).
    + destruct_exprs; reduce; try reflexivity.
      apply exprD_fold_const; assumption.
    + do 2 (destruct_exprs; try (reduce; eapply exprD_fold_expr; eassumption)).
      destruct_exprs; try (reduce; eapply exprD_fold_expr; eassumption).
      reduce.
	  eapply exprD_fold_expr_nil; try eassumption.
  Qed.

End Fold.


Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Maps.
Require Import compcert.lib.Integers.

Require Import sepcomp.semantics.
Require Import sepcomp.semantics_lemmas.

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

Section closed_safety.

Variable (G C D Z M : Type).

Variable sem : CoreSemantics G C M.

Variable ge : G.

Fixpoint safeN (n : nat) (c : C) (m : M) : Prop :=
  match n with
    | O => True
    | S n' =>
      match halted sem c with
        | None =>
          (exists c', exists m', corestep sem ge c m c' m') /\
          (forall c' m', corestep sem ge c m c' m' -> safeN n' c' m')
        | Some i => True
      end
  end.

Lemma safe_downward1 n c m : safeN (S n) c m -> safeN n c m.
Proof.
revert c m; induction n; simpl; intros; auto.
destruct (halted sem c); auto.
destruct H as [H H0].
destruct H as [c' [m' H2]].
split. exists c', m'; auto.
intros c'' m'' H3.
specialize (H0 _ _ H3). destruct n; auto.
Qed.

Lemma safe_downward (n n' : nat) c m :
  le n' n -> safeN n c m -> safeN n' c m.
Proof.
do 2 intro. revert c m H0. induction H; auto.
intros. apply IHle. apply safe_downward1. auto.
Qed.

Lemma safe_corestep_forward c m c' m' n :
  corestep sem ge c m c' m' -> safeN (S n) c m ->
  safeN n c' m'.
Proof.
simpl; intros.
generalize H as H'; intro.
eapply corestep_not_halted in H; rewrite H in H0.
destruct H0 as [H1 H2]. clear H H1.
apply H2; auto.
Qed.

Lemma safe_corestepN_forward c m c' m' n n0 :
  corestepN sem ge n0 c m c' m' ->
  safeN (n + S n0) c m -> safeN n c' m'.
Proof.
intros.
revert c m c' m' n H H0.
induction n0; intros; auto.
simpl in H; inv H.
eapply safe_downward in H0; eauto. omega.
simpl in H. destruct H as [c2 [m2 [STEP STEPN]]].
eapply IHn0; eauto.
assert (Heq: (n + S (S n0) = S (n + S n0))%nat) by omega.
rewrite Heq in H0.
eapply safe_corestep_forward in H0; eauto.
Qed.

Lemma corestep_star_fun :
  corestep_fun sem ->
  forall c m c' m' c'' m'' n,
  corestepN sem ge n c m c' m' ->
  corestepN sem ge n c m c'' m'' ->
  c'=c'' /\ m'=m''.
Proof.
intro FUN. intros. revert c m H H0. induction n; auto.
simpl. intros ? ?. inversion 1; subst. inversion 1; subst.
split; auto.
simpl.
intros c m H H2.
destruct H as [c2 [m2 [STEP STEPN]]].
destruct H2 as [c2' [m2' [STEP' STEPN']]].
assert (c2 = c2' /\ m2 = m2').
  unfold corestep_fun in FUN. eapply FUN; eauto.
inv H.
eapply IHn; eauto.
Qed.

End closed_safety.


Set Default Goal Selector "!".

From Undecidability.H10 Require Import H10 dio_single dio_logic.
From Undecidability.L.Datatypes Require Import LNat Lists LOptions LSum.
From Undecidability.L Require Import Tactics.LTactics Computability.MuRec Computability.Synthetic Tactics.GenEncode.
From Undecidability.Shared Require Import DLW.Utils.finite DLW.Vec.vec DLW.Vec.pos.
From Undecidability.MuRec Require Import MuRec recalg ra_sem_eq.

Reserved Notation "  '[' f ';' v ';' min ';' c ']' '▹' x " (at level 70).

(* Bigstep semantics for recursive algorithms *)

Inductive ra_bs_c : nat -> nat -> forall k, recalg k -> vec nat k -> nat -> Prop :=
    | in_ra_bs_c_cst  : forall min c n v,             [ra_cst n;        v; min; S c] ▹ n
    | in_ra_bs_c_zero : forall min c v,               [ra_zero;         v; min; S c] ▹ 0
    | in_ra_bs_c_succ : forall min c v,               [ra_succ;         v; min; S c] ▹ S (vec_head v)
    | in_ra_bs_c_proj : forall min c k v j,           [@ra_proj k j;    v; min; S c] ▹ vec_pos v j

    | in_ra_bs_c_comp : forall min c k i f (gj : vec (recalg i) k) v w x,
                                         (forall j, [vec_pos gj j;    v; min; c - pos2nat j] ▹ vec_pos w j)
                                 ->             [f;               w; min; S c] ▹ x
                                 ->             [ra_comp f gj;    v; min; S (S c)] ▹ x

    | in_ra_bs_c_rec_0 : forall min c k f (g : recalg (S (S k))) v x,
                                               [f;               v; min; c] ▹ x
                                 ->             [ra_rec f g;   0##v; min; S c] ▹ x

    | in_ra_bs_c_rec_S : forall min c k f (g : recalg (S (S k))) v n x y,
                                             [ra_rec f g;   n##v; min; c] ▹ x
                               ->             [g;         n##x##v; min; c] ▹ y
                               ->             [ra_rec f g; S n##v; min; S c] ▹ y

    | in_ra_bs_c_min : forall min c k (f : recalg (S k)) v x w , x >= min ->
                           (forall j : pos x, pos2nat j >= min -> [f;    pos2nat j##v; 0; c - (pos2nat j - min)] ▹ S (vec_pos w j))
                                             ->             [f;            x##v; 0; c - (x - min)] ▹ 0
                                             ->             [ra_min f;        v; min; S c] ▹ x
where " [ f ; v ; min ; c ] ▹ x " := (@ra_bs_c min c _ f v x).

Lemma ra_bs_mono min k (f : recalg k) v c1 x :
  [f ; v ; min ; c1 ] ▹ x -> forall c2, c1 <= c2 -> [f ; v ; min; c2] ▹ x.
Proof.
  induction 1; intros; try (destruct c2;[ lia | ]).
  - econstructor.
  - econstructor.
  - econstructor.
  - econstructor.
  - destruct c2; try lia. econstructor.
    + intros. eapply H0. lia.
    + eapply IHra_bs_c. lia.
  - econstructor. eapply IHra_bs_c. lia.
  - econstructor.
    + eapply IHra_bs_c1. lia.
    + eapply IHra_bs_c2. lia.
  - econstructor.
    + lia.
    + intros. eapply H1; lia.
    + eapply IHra_bs_c. lia.
Qed.

Lemma vec_sum_le:
  forall (k : nat) (cst : vec nat k) (j : pos k), vec_pos cst j <= vec_sum cst.
Proof.
  intros k cst j.
  induction cst; cbn.
  - invert pos j.
  - invert pos j.
    + lia.
    + specialize (IHcst j); lia.
Qed.

Lemma ra_bs_from_c k (f : recalg k) c v x :
 [f ; v ; 0 ; c] ▹ x -> [ f; v ] ▹ x.
Proof.
  remember 0 as min.
  induction 1; subst; eauto using ra_bs.
  econstructor.
  + intros; eapply H1; lia.
  + auto.
Qed.

Lemma ra_bs_to_c k (f : recalg k) v x :
  [ f; v ] ▹ x -> exists c, [f ; v ; 0 ; c] ▹ x.
Proof.
  induction 1.
  - exists 1. econstructor.
  - exists 1. econstructor.
  - exists 1. econstructor.
  - exists 1. econstructor.
  - destruct IHra_bs as [c].
    eapply vec_reif in H0 as [cst].
    exists (2 + c + vec_sum cst + k). cbn.
    econstructor.
    + intros. eapply ra_bs_mono. 1:eauto.
      rewrite <- Nat.add_sub_assoc.
      2: pose (pos2nat_prop j); lia.
      enough (vec_pos cst j <= vec_sum cst).
      1: lia. eapply vec_sum_le.
    + eapply ra_bs_mono. 1: eauto. lia.
  - destruct IHra_bs as [c]. exists (S c). now econstructor.
  - destruct IHra_bs1 as [c1].
    destruct IHra_bs2 as [c2].
    exists (1 + c1 + c2).
    cbn. econstructor.
    + eapply ra_bs_mono. 1: eauto. lia.
    + eapply ra_bs_mono. 1: eauto. lia.
  - destruct IHra_bs as [c].
    eapply vec_reif in H0 as [cst].
    exists (1 + c + vec_sum cst + x). cbn.
    econstructor. 1: lia.
    + intros. eapply ra_bs_mono. 1: eauto.
      rewrite <- Nat.add_sub_assoc.
      2: pose (pos2nat_prop j); lia.
      enough (vec_pos cst j <= vec_sum cst) by lia.
      eapply vec_sum_le.
    + eapply ra_bs_mono. 1: eauto. lia.
Qed.

Local Hint Resolve ra_bs_from_c ra_bs_to_c : core.

Fact ra_bs_c_correct k (f : recalg k) v x :
  [|f|] v x <-> exists c, [f ; v ; 0 ; c] ▹ x.
Proof.
  rewrite ra_bs_correct; split; auto.
  intros (c & H); revert H; apply ra_bs_from_c.
Qed.

(*
Inductive reccode :=
| rc_cst (n : nat)
| rc_zero
| rc_succ
| rc_proj (n : nat)
| rc_comp (f : reccode) (g : reccode)
| rc_cons (f : reccode) (g : reccode)
| rc_nil
| rc_rec (f : reccode) (g : reccode)
| rc_min (f : reccode).

Fixpoint eval (fuel : nat) (min : nat) (c : reccode) (v : list nat) : option (nat + list nat) :=
  match fuel with
  | 0 => None
  | S fuel =>
    match c with
    | rc_cst n => Some (inl n)
    | rc_zero => Some (inl 0)
    | rc_succ => match v with
                | x :: _ => Some (inl (S x))
                | _ => None
                end
    | rc_proj n => match nth_error v n with Some r => Some (inl r) | None => None end
    | rc_comp f g => match eval fuel min g v
                    with
                    | Some (inr g) => match eval fuel min f g with Some (inl f) => Some (inl f) | _ => None end
                    | _ => None
                    end
    | rc_cons f g => match eval fuel min f v, eval fuel min g v with
                    | Some (inl f), Some (inr g) => Some (inr (f :: g))
                    | _, _ => None
                    end
    | rc_nil => Some (inr nil)
    | rc_rec f g => match v with
                   | 0 :: v => match eval fuel min f v with Some (inl r) => Some (inl r) | _ => None end
                   | S n :: v => match eval fuel min (rc_rec f g) (n :: v) with
                               | Some (inl y) => match eval fuel min g (n :: y :: v) with Some (inl r) => Some (inl r) | _ => None end
                               | _ => None
                               end
                   | _ => None
                   end
    | rc_min f => match eval fuel 0 f (min :: v) with
                 | Some (inl 0) => Some (inl min)
                 | Some (inl _) => match eval fuel (S min) (rc_min f) v with Some (inl r) => Some (inl r) | _ => None end
                 | _ => None
                 end
    end
  end.
*)

Require Import Undecidability.L.Reductions.MuRec.MuRec_extract.

Definition rec_erase i (erase : forall i, recalg i -> reccode) := (fix rec k (v : vec (recalg i) k) := match v with vec_nil => rc_nil | x ## v => rc_cons (erase _ x) (rec _ v) end).

Fixpoint erase k (f : recalg k) : reccode :=
  match f with
  | ra_cst n => rc_cst n
  | ra_zero => rc_zero
  | ra_succ => rc_succ
  | ra_proj _ p => rc_proj (pos2nat p)
  | ra_comp _ _ f g => rc_comp (erase f) (rec_erase erase g)
  | ra_rec _ f g => rc_rec (erase f) (erase g)
  | ra_min _ f => rc_min (erase f)
  end.

Lemma vec_list_nth:
  forall (k : nat) (p : pos k) (v : vec nat k), nth_error (vec_list v) (pos2nat p) = Some (vec_pos v p).
Proof.
  intros k p v.
  induction v.
  - invert pos p.
  - cbn; invert pos p.
    + reflexivity.
    + eapply IHv.
Qed.

Lemma eval_inv n min i k (v : vec (recalg i) k) a l :
  eval n min (rec_erase erase v) a = Some (inr l) ->
  exists x, vec_list x = l /\
  (forall j : pos k, eval (n -S (pos2nat j)) min (erase (vec_pos v j)) a = Some (inl (vec_pos x j))).
Proof.
  induction v in n,l |- *.
  - destruct n; cbn.
    + firstorder congruence.
      exact vec_nil.
    + intros [=]; subst.
      exists vec_nil.
      split; auto.
      intro j; invert pos j.
  - destruct n. 1: inversion 1.
    intros ?. cbn in H.
    destruct (eval n) eqn:E1; try congruence.
    destruct s; try congruence.
    destruct (eval n min (rec_erase erase v) a) eqn:E2; try congruence.
    destruct s; try congruence. inv H.
    edestruct IHv as (? & ? & ?). 1: eauto.
    exists (n1 ## x). split. 1: cbn; firstorder congruence.
    intros j; pos_inv j.
    + rewrite pos2nat_fst in *. assert (S n - 1 = n) by lia. rewrite H1 in *.
      cbn -[eval].  eassumption.
    + rewrite pos2nat_nxt.
      specialize (H0 j).
      assert (S n - S (S (pos2nat j)) = n - S (pos2nat j)) by lia. rewrite H1 in *.
      cbn. rewrite H0. reflexivity.
Qed.

Lemma le_ind2 m (P : nat -> Prop) :
  P m -> (forall n, P (S n) -> S n <= m -> P n) -> forall n, n <= m -> P n.
Proof.
  intros. induction H1.
  - eauto.
  - eauto.
Qed.

Lemma vec_pos_gt n X (w : vec X n) j k n1:
  pos2nat k < pos2nat j ->
  vec_pos w j = vec_pos (vec_change w k n1) j.
Proof.
  intros.
  induction w.
  - invert pos j.
  - invert pos j; cbn.
    + invert pos k; cbn; auto; lia.
    + invert pos k; cbn; auto.
      apply IHw.
      rewrite !pos2nat_nxt in H; lia.
Qed.

Lemma erase_correct k min (f : recalg k) v n c  :
  (ra_bs_c min c f v n <-> eval c min (erase f) (vec_list v) = Some (inl n)).
Proof.
  revert k min f v n.
  pattern c. eapply lt_wf_ind. intros.
  destruct f; cbn.
  - split.
    + inversion 1. subst.
      eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H4. subst.
      reflexivity.
    + destruct n; inversion 1. subst. econstructor.
  - split.
    + inversion 1. subst.
      eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H3. subst.
      reflexivity.
    + destruct n; inversion 1. subst. econstructor.
  - split.
    + inversion 1. subst.
      eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H3. subst.
      cbn; revert H0; vec split v with x; auto.
    + destruct n; inversion 1.
      revert H0 H2; vec split v with x; cbn.
      intros [=] _; subst; constructor.
  - split.
    + inversion 1. subst.
      eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H5. subst.
      eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H6. subst.
      cbn. rewrite vec_list_nth. reflexivity.
    + destruct n; inversion 1. rewrite vec_list_nth in H2. inv H2. econstructor.
  - split.
    + inversion 1. subst.
      eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H2. subst.
      eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H7. subst.
      eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H7. subst.
      eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H8. subst.
      assert (forall j : pos k, eval (c0 - pos2nat j) min (erase (vec_pos t j)) (vec_list v) = Some (inl (vec_pos w j))).
      { intros. eapply H. 1: lia.

      cbn. eapply H. 1: lia. eapply H. 1: lia. specialize (H9 j).
      eapply H in H9. 2:lia. eapply H. 1: lia. eauto. }

      remember (S c0) as c'. cbn.

      assert (eval c' min (rec_erase erase t) (vec_list v) = Some (inr (vec_list w))).
      { subst. clear - H1. revert c0 H1. induction t; intros.
        - cbn; vec nil w; reflexivity.
        - cbn. pose proof (H1 pos_fst). cbn in H. rewrite pos2nat_fst in H.
          replace (c0 - 0) with c0 in H by lia. rewrite H.
          revert H1 H; vec split w with y; intros H1 H.
          destruct c0. 1: cbn in H. 1: inv H. erewrite IHt.
          1: reflexivity.
          intros. specialize (H1 (pos_nxt j)). rewrite pos2nat_nxt in H1.
          eassumption.
      }
      rewrite H2. subst. eapply H in H10. 1: rewrite H10. 1: reflexivity. lia.
    + destruct n; inversion 1.
      destruct (eval n min (rec_erase erase t) (vec_list v)) eqn:E; try congruence.
      destruct s; try congruence.
      destruct (eval n min (erase f) l) eqn:E2; try congruence.
      destruct s; try congruence. inv H2.
      destruct n; try now inv E2.

      destruct (list_vec_full l).
      destruct (eval_inv E) as (w & ? & ?). subst.

      eapply in_ra_bs_c_comp with (w := w).
      * intros. eapply H. 1: lia. specialize (H2 j). assert (S n - S (pos2nat j) = n - pos2nat j) by lia. rewrite H1 in *.
        eauto.
      * eapply H. 1: lia. eassumption.
  - split. 1: inversion 1.
    + eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H4. subst.
      eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H6. subst.
      eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H7. subst.
      cbn.
      eapply H in H8. 2:lia. rewrite H8. reflexivity.
    + eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H2. subst.
      eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H5. subst.
      eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H6. subst.
      eapply H in H7.
      1: cbn. 2:lia. cbn in H7. rewrite H7.
      eapply H in H9. 2:lia. cbn in H9. rewrite H9. reflexivity.
    + intros. destruct n; inv H0.
      revert H2; vec split v with n1; cbn; intros H2.
      destruct n1.
      * destruct (eval n min (erase f1) (vec_list v)) eqn:E.
        1: destruct s; inv H2.
        -- econstructor. eapply H. 1: lia. eauto.
        -- econstructor. congruence.
      * destruct eval eqn:E2; try congruence.
        destruct s; try congruence.
        destruct (eval n min (erase f2)) eqn:E3.
        1: destruct s; inv H2.
        -- econstructor. 1: eapply H. 1: lia. 1: eauto. eapply H. 1: lia. eauto.
        -- congruence.
  - split.
    + inversion 1. subst.
      eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H1. subst.
      eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H2. subst.
      clear H0. unfold ge in *.
      revert c0 H w H7 H8. pattern n0. revert min H3.
      eapply le_ind2; intros.
      * cbn in *. eapply H in H8. 2:lia.
        assert (c0 - (n0 - n0) = c0) by lia. rewrite H0 in *.
        cbn in H8. rewrite H8. reflexivity.
      * destruct n0; try lia.
        assert (n < S n0) by lia.
        assert (H10 := H7).
        specialize (H7 (nat2pos H2)). rewrite pos2nat_nat2pos in H7.
        assert (n <= n) by lia. eapply H7 in H3.
        eapply H1 in H3. 2: lia. cbn.
        assert (c0 - (n - n) = c0) by lia. rewrite H4 in *. cbn in H3. rewrite H3.

        assert (eval c0 (S n) (rc_min (erase f)) (vec_list v) = Some (inl (S n0))).
        { eapply H1 with (f := ra_min f). 1: lia.
          destruct c0. 1: inv H3.
          econstructor. 1: lia.
          - intros ? ?. specialize (H10 j).
            assert (S c0 - (pos2nat j - n) = c0 - (pos2nat j - S n)) by lia.
            rewrite H6 in *.  eapply H10. lia.
          - assert (S c0 - (S n0 - n) = c0 - (S n0 - S n)) by lia. rewrite H5 in *.
            eassumption. }
        now rewrite H5.
    + intros.
      destruct n; try now inv H0. cbn in H0.
      destruct (eval n) eqn:E1; try now inv H0.
      destruct s; try congruence.
      destruct n1; inv H0.
      * econstructor. 1: lia.
        -- intros. pose proof (pos2nat_prop j). lia.
        -- eapply H. 1:lia. assert (n - (n0 - n0) = n) as -> by lia. eassumption.
      * destruct (eval n (S min)) eqn:E2; try now inv H2.
        destruct s; inv H2.
        eapply H with (f := ra_min f) in E2. 2:lia.
        eapply H with (v := vec_cons min v) in E1. 2:lia.
        inversion E2; subst.
        eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H0. subst.
        eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H1. subst.
        assert (min < n0) by lia.
        eapply in_ra_bs_c_min with (w := vec_change w (nat2pos H0) n1).
        -- lia.
        -- intros. inversion H1.
           ++ subst.
              rewrite nat2pos_pos2nat.
              rewrite vec_change_eq. 2:reflexivity.
              assert (S c0 - (pos2nat j - pos2nat j) = S c0) as -> by lia.
              eassumption.
           ++ specialize (H6 j).
              assert (S c0 - (S m - min) = c0 - (pos2nat j - S min)) by lia. rewrite H5 in *.
              enough (vec_pos w j = vec_pos (vec_change w (nat2pos H0) n1) j).
              { rewrite H8 in H6. rewrite H3. eapply H6. lia. }
              assert (pos2nat j > min) by lia.
              eapply vec_pos_gt.
              rewrite pos2nat_nat2pos. lia.
        -- assert (S c0 - (n0 - min) = c0 - (n0 - S min)) by lia. rewrite H1. eassumption.
           Unshelve. exact vec_zero.
Qed.

Require Import Undecidability.L.Reductions.MuRec.MuRec_extract.

Definition evalfun fuel c v := match eval fuel 0 c v with Some (inl x) => Some x | _ => None end.

From Undecidability Require Import MuRec_computable LVector.
From Undecidability.L.Util Require Import NaryApp ClosedLAdmissible.

Import L_Notations.

Definition cont_vec (k : nat) : term := lam (many_lam k (k (Vector.fold_right (fun n s => (ext (@cons nat) (var n)) s) (many_vars k)  (ext (@nil nat))))).

Lemma helper_closed k :
  bound k (Vector.fold_right (fun (n : nat) (s0 : term) => ext (@cons nat) n s0) (many_vars k) (ext (@nil nat))).
Proof.
  induction k.
  - cbn. cbv. repeat econstructor.
  - rewrite many_vars_S. cbn. econstructor. 1: econstructor. 1: eapply closed_dcl_x. 1: Lproc.
    1: econstructor; lia.
    eapply bound_ge. 1: eauto. lia.
Qed.

Lemma subst_closed s n u :
  closed s -> subst s n u = s.
Proof.
  now intros ->.
Qed.

Lemma vector_closed:
  forall (k : nat) (v : Vector.t nat k) (x : term), Vector.In x (Vector.map enc v) -> proc x.
Proof.
  intros k v.
  induction v; cbn; intros ? Hi. 1: inversion Hi. inv Hi. 1:Lproc. eapply IHv. eapply Eqdep_dec.inj_pair2_eq_dec in H2. 1:subst; eauto. eapply nat_eq_dec.
Qed.

Lemma cont_vec_correct k s (v : Vector.t nat k) :
  proc s ->
  many_app (cont_vec k s) (Vector.map enc v) == s (enc v).
Proof.
  intros Hs.
  unfold cont_vec.
  rewrite equiv_many_app_L.
  2:{ eapply beta_red. 1:Lproc. rewrite subst_many_lam. replace (k + 0) with k by lia. reflexivity. }
  cbn -[plus mult]. rewrite Nat.eqb_refl.
  rewrite bound_closed_k. 2:eapply helper_closed.
  replace (3 * k) with (k + 2 * k) by lia.
  etransitivity.
  { apply many_beta. eapply vector_closed. }
  rewrite many_subst_app.
  rewrite many_subst_closed. 2:Lproc.
  replace (2 * k) with (2 * k + 0) by lia.
  eapply equiv_R.
  induction v.
  - cbn. reflexivity.
  - rewrite many_vars_S. cbn -[mult]. rewrite subst_closed; [ | now Lproc].
    rewrite Nat.eqb_refl.
    rewrite !many_subst_app.
    repeat (rewrite many_subst_closed; [ | now Lproc]).
    rewrite bound_closed_k. 2:eapply helper_closed. rewrite IHv.
    rewrite !enc_vector_eq.
    now Lsimpl.
Qed.

Definition mu_option : term := (lam (0 (mu (lam (1 0 (lam (enc true)) (enc false)))) (lam 0) (lam 0))).

Lemma mu_option_proc : proc mu_option.
Proof.
  unfold mu_option. Lproc.
Qed.
#[export] Hint Resolve mu_option_proc : Lproc.

From Undecidability Require Import LOptions.

Lemma mu_option_equiv {X} `{encodable X} s (b : X)  :
  proc s ->
  mu_option s == s (mu (lam (s 0 (lam (enc true)) (enc false)))) (lam 0) (lam 0).
Proof.
  unfold mu_option. intros Hs. now Lsimpl.
Qed.

Definition mu_option_spec {X} {ENC : encodable X} {I : encInj ENC} s (b : X)  :
  proc s ->
  (forall x : X, enc x <> lam 0) ->
 (forall n : nat, exists o : option X, s (enc n) == enc o) ->
  (forall b : X, forall m n : nat, s (enc n) == enc (Some b) -> m >= n -> s (enc m) == enc (Some b)) ->
  mu_option s == enc b <-> exists n : nat, s (enc n) == enc (Some b).
Proof.
  intros Hs Hinv Ht Hm.
  rewrite (@mu_option_equiv X); eauto.
  split.
  - intros He.
    match goal with [He : ?s == _ |- _ ] => assert (converges s) as Hc end.
    { eexists. split. 1: exact He. Lproc. }
    eapply app_converges in Hc as [Hc _].
    eapply app_converges in Hc as [Hc _].
    eapply app_converges in Hc as [_ Hc].
    destruct Hc as [v [Hc Hv]].
    pose proof (Hc' := Hc).
    eapply mu_sound in Hc as [n [-> [Hc1 _]]]; eauto.
    * exists n.
      destruct (Ht n) as [ [x | ] Htt].
      -- rewrite Htt.
         enough (enc b == enc x) as -> % enc_extinj. 1: reflexivity.
         rewrite <- He.
         rewrite Hc'. Lsimpl. rewrite Htt. now Lsimpl.
      -- exfalso. eapply (Hinv b). eapply unique_normal_forms; try Lproc.
         rewrite <- He, Hc'. Lsimpl.
         rewrite Htt. Lsimpl. reflexivity.
    * Lproc.
    * intros n. destruct (Ht n) as [[] ];
      eexists; Lsimpl; rewrite H; Lsimpl; reflexivity.
  - intros [n Hn].
    edestruct mu_complete' with (n := n) as [n' [H' H'']].
    4: rewrite H'.
    + Lproc.
    + intros m. destruct (Ht m) as [ [] ];
      eexists; Lsimpl; rewrite H; Lsimpl; reflexivity.
    + Lsimpl. rewrite Hn. now Lsimpl.
    + destruct (Ht n') as [[] Heq]; rewrite Heq; Lsimpl.
      * enough (HH : enc (Some x) == enc (Some b))by now eapply enc_extinj in HH; inv HH.
        assert (n <= n' \/ n' <= n) as [Hl | Hl] by lia.
        -- eapply Hm in Hl; eauto. now rewrite <- Heq, Hl.
        -- eapply Hm in Hl; eauto. now rewrite <- Hn, Hl.
      * enough (false = true) by congruence.
        eapply enc_extinj. rewrite <- H''.
        symmetry. Lsimpl. rewrite Heq. now Lsimpl.
Qed.

#[export]
Instance computable_evalfun : computable evalfun.
Proof. extract. Qed.

Lemma vec_list_eq {n X} (v : Vector.t X n) :
  vec_list v = Vector.to_list v.
Proof.
  induction v; cbn; f_equal; eassumption.
Qed.

Require Import Undecidability.L.Reductions.MuRec.MuRec_extract.

Lemma eval_mono c min k (v : Vector.t nat k) (f : recalg k) o :
  eval c min (erase f) (vec_list v) = Some (inl o) -> forall c', c' >= c -> eval c' min (erase f) (vec_list v) = Some (inl o).
Proof.
  intros H c' Hl. eapply erase_correct in H.
  eapply ra_bs_mono in H. 2: eauto.
  now eapply erase_correct in H.
Qed.

Theorem computable_MuRec_to_L {k} (R : Vector.t nat k -> nat -> Prop) :
  MuRec_computable R -> L_computable R.
Proof.
  intros [f Hf].
  exists (cont_vec k (lam (mu_option (lam (ext evalfun 0 (enc (erase f)) 1))))).
  intros v. rewrite <- many_app_eq_nat. split.
  - intros m. rewrite L_facts.eval_iff.
    assert (lambda (encNatL m)) as [b Hb]. { change  (lambda (enc m)). Lproc. }
    rewrite Hb. rewrite eproc_equiv. rewrite cont_vec_correct. 2: unfold mu_option; Lproc.
    assert (lam (mu_option (lam (ext evalfun 0 (enc (erase f)) 1))) (enc v) ==
          mu_option (lam (ext evalfun 0 (enc (erase f)) (enc v)))).
    {  unfold mu_option. now Lsimpl. }
    rewrite H. rewrite <- Hb.
    change (encNatL m) with (enc m).
    rewrite mu_option_spec. 2:Lproc.
    2:{ intros []; cbv; congruence. }
    2:{ intros. eexists. rewrite !enc_vector_eq. Lsimpl. reflexivity. }
    1: rewrite Hf.
    1: split.
    + intros [n Hn % erase_correct] % ra_bs_to_c. exists n.
      rewrite !enc_vector_eq. Lsimpl.
      unfold evalfun. rewrite <- vec_list_eq. now rewrite Hn.
    + intros [n Hn]. eapply ra_bs_from_c. eapply erase_correct with (c := n).
      match goal with [Hn : ?s == ?b |- _ ] => evar (t : term); assert (s == t) end.
      { rewrite !enc_vector_eq. Lsimpl. subst t. reflexivity. } subst t.
      rewrite vec_list_eq. rewrite H0 in Hn. eapply enc_extinj in Hn.
      unfold evalfun in Hn. now destruct eval as [[] | ]; inv Hn.
    + intros. rewrite enc_vector_eq in *.
      match type of H0 with ?s == ?b => evar (t : term); assert (s == t) end. 1: Lsimpl. all: subst t. 1: reflexivity. rewrite H2 in H0. clear H2.
      eapply enc_extinj in H0. Lsimpl.
      unfold evalfun in *.
      destruct (eval n) as [ [] | ] eqn:E; inv H0.
      rewrite <- vec_list_eq in *.
      eapply eval_mono in E. 1: rewrite E; eauto. lia.
  - intros v' [H1 H2] % eval_iff.
    eapply star_equiv_subrelation in H1.
    rewrite cont_vec_correct in H1. 2: unfold mu_option; Lproc.
    match goal with [Hn : ?s == ?b |- _ ] => evar (t : term); assert (s == t) end.
    1: unfold mu_option. 1: Lsimpl. all: subst t. 1: reflexivity.
    rewrite H in H1.
    match type of H1 with ?s == _ => assert (converges s) end.
    1: exists v'; split; eassumption.
    eapply app_converges in H0 as [Hc _].
    eapply app_converges in Hc as [Hc _].
    eapply app_converges in Hc as [_ Hc].
    destruct Hc as [v'' [Hc1 Hc2]].
    pose proof (Hc1' := Hc1).
    eapply mu_sound in Hc1; eauto.
    + destruct Hc1 as [m [-> []]].
      rewrite Hc1' in H1.
      rewrite enc_vector_eq in H1.
      destruct (evalfun m (erase f) (Vector.to_list v)) eqn:E.
      * match type of H1 with ?s == ?b => evar (t : term); assert (s == t) end. 1: Lsimpl. all: subst t. 1: reflexivity.
      rewrite H4, E in H1.
      match type of H1 with ?s == ?b => evar (t : term); assert (s == t) end. 1: Lsimpl. all: subst t. 1: reflexivity.
      rewrite H5 in H1.
      eapply unique_normal_forms in H1. 2,3: Lproc.
      subst. exists n. reflexivity.
      * enough (true = false) by congruence. eapply enc_extinj.
        rewrite <- H0. rewrite enc_vector_eq. Lsimpl.
        now rewrite E.
    + Lproc.
    + intros n.
      destruct (evalfun n (erase f) (Vector.to_list v)) eqn:EE;
      eexists; rewrite enc_vector_eq; Lsimpl; rewrite EE; try Lsimpl; reflexivity.
Qed.

Definition UMUREC_HALTING c := exists fuel, evalfun fuel c nil <> None.

Import Undecidability.Synthetic.Definitions Undecidability.Synthetic.ReducibilityFacts.

Lemma MUREC_red : recalg.MUREC_HALTING ⪯ UMUREC_HALTING.
Proof.
  unshelve eexists.
  - intros f. exact (erase f).
  - unfold UMUREC_HALTING, MUREC_HALTING.
    intros f.
    split; intros [].
    + rewrite ra_bs_correct in H. eapply ra_bs_to_c in H as [].
      exists x0. eapply erase_correct in H. unfold evalfun. cbn in H. rewrite H. congruence.
    + unfold evalfun in H. destruct eval eqn:E; try congruence.
      destruct s; try congruence.
      eapply erase_correct with (v := vec_nil) in E.
      exists n. eapply ra_bs_correct. now eapply ra_bs_from_c.
Qed.

Local Definition r := (fun c n => match eval n 0 c [] with Some (inl n) => true | _ => false end).

Lemma MUREC_WCBV : MUREC_HALTING ⪯ converges.
Proof.
  eapply reduces_transitive. 1:eapply MUREC_red.
  eapply L_recognisable_halt.
  exists (fun c n => match eval n 0 c [] with Some (inl n) => true | _ => false end).
  split.
  - econstructor. extract.
  - firstorder.
    + unfold evalfun in *. exists x0. destruct eval; try destruct s; try congruence.
    + exists x0. unfold evalfun in *. destruct eval; try destruct s; try congruence.
Qed.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrfun ssrbool eqtype ssrnat seq.

(******************************************************************************)
(* This file contains the definitions of:                                     *)
(*   choiceType == interface for types with a choice operator.                *)
(*    countType == interface for countable types (implies choiceType).        *)
(* subCountType == interface for types that are both subType and countType.   *)
(*  xchoose exP == a standard x such that P x, given exP : exists x : T, P x  *)
(*                 when T is a choiceType. The choice depends only on the     *)
(*                 extent of P (in particular, it is independent of exP).     *)
(*   choose P x0 == if P x0, a standard x such that P x.                      *)
(*      pickle x == a nat encoding the value x : T, where T is a countType.   *)
(*    unpickle n == a partial inverse to pickle: unpickle (pickle x) = Some x *)
(*  pickle_inv n == a sharp partial inverse to pickle pickle_inv n = Some x   *)
(*                  if and only if pickle x = n.                              *)
(* [choiceType of T for cT] == clone for T of the choiceType cT.              *)
(*        [choiceType of T] == clone for T of the choiceType inferred for T.  *)
(*  [countType of T for cT] == clone for T of the countType cT.               *)
(*        [count Type of T] == clone for T of the countType inferred for T.   *)
(* [choiceMixin of T by <:] == Choice mixin for T when T has a subType p      *)
(*                        structure with p : pred cT and cT has a Choice      *)
(*                        structure; the corresponding structure is Canonical.*)
(*  [countMixin of T by <:] == Count mixin for a subType T of a countType.    *)
(*  PcanChoiceMixin fK == Choice mixin for T, given f : T -> cT where cT has  *)
(*                        a Choice structure, a left inverse partial function *)
(*                        g and fK : pcancel f g.                             *)
(*   CanChoiceMixin fK == Choice mixin for T, given f : T -> cT, g and        *)
(*                        fK : cancel f g.                                    *)
(*   PcanCountMixin fK == Count mixin for T, given f : T -> cT where cT has   *)
(*                        a Countable structure, a left inverse partial       *)
(*                        function g and fK : pcancel f g.                    *)
(*    CanCountMixin fK == Count mixin for T, given f : T -> cT, g and         *)
(*                        fK : cancel f g.                                    *)
(*      GenTree.tree T == generic n-ary tree type with nat-labeled nodes and  *)
(*                        T-labeled leaves, for example GenTree.Leaf (x : T), *)
(*                        GenTree.Node 5 [:: t; t']. GenTree.tree is equipped *)
(*                        with canonical eqType, choiceType, and countType    *)
(*                        instances, and so simple datatypes can be similarly *)
(*                        equipped by encoding into GenTree.tree and using    *)
(*                        the mixins above.                                   *)
(*        CodeSeq.code == bijection from seq nat to nat.                      *)
(*      CodeSeq.decode == bijection inverse to CodeSeq.code.                  *)
(* In addition to the lemmas relevant to these definitions, this file also    *)
(* contains definitions of a Canonical choiceType and countType instances for *)
(* all basic datatypes (e.g., nat, bool, subTypes, pairs, sums, etc.).        *)
(******************************************************************************)

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

(* Technical definitions about coding and decoding of nat sequences, which    *)
(* are used below to define various Canonical instances of the choice and     *)
(* countable interfaces.                                                      *)

Module CodeSeq.

(* Goedel-style one-to-one encoding of seq nat into nat.                      *)
(* The code for [:: n1; ...; nk] has binary representation                    *)
(*          1 0 ... 0 1 ... 1 0 ... 0 1 0 ... 0                               *)
(*            <----->         <----->   <----->                               *)
(*             nk 0s           n2 0s     n1 0s                                *)

Definition code := foldr (fun n m => 2 ^ n * m.*2.+1) 0.

Fixpoint decode_rec (v q r : nat) {struct q} :=
  match q, r with
  | 0, _         => [:: v]
  | q'.+1, 0     => v :: [rec 0, q', q']
  | q'.+1, 1     => [rec v.+1, q', q']
  | q'.+1, r'.+2 => [rec v, q', r']
  end where "[ 'rec' v , q , r ]" := (decode_rec v q r).

Definition decode n := if n is 0 then [::] else [rec 0, n.-1, n.-1].

Lemma decodeK : cancel decode code.
Proof.
have m2s: forall n, n.*2 - n = n by move=> n; rewrite -addnn addnK.
case=> //= n; rewrite -[n.+1]mul1n -(expn0 2) -{3}[n]m2s.
elim: n {2 4}n {1 3}0 => [|q IHq] [|[|r]] v //=; rewrite {}IHq ?mul1n ?m2s //.
by rewrite expnSr -mulnA mul2n.
Qed.

Lemma codeK : cancel code decode.
Proof.
elim=> //= v s IHs; rewrite -[_ * _]prednK ?muln_gt0 ?expn_gt0 //=.
rewrite -{3}[v]addn0; elim: v {1 4}0 => [|v IHv {IHs}] q.
  rewrite mul1n /= -{1}addnn -{4}IHs; move: (_ s) {IHs} => n.
  by elim: {1 3}n => //=; case: n.
rewrite expnS -mulnA mul2n -{1}addnn -[_ * _]prednK ?muln_gt0 ?expn_gt0 //.
by rewrite doubleS addSn /= addSnnS; elim: {-2}_.-1 => //=.
Qed.

Lemma ltn_code s : all (fun j => j < code s) s.
Proof.
elim: s => //= i s IHs; rewrite -[_.+1]muln1 leq_mul 1?ltn_expl //=.
apply: sub_all IHs => j /leqW lejs; rewrite -[j.+1]mul1n leq_mul ?expn_gt0 //.
by rewrite ltnS -[j]mul1n -mul2n leq_mul.
Qed.

Lemma gtn_decode n : all (ltn^~ n) (decode n).
Proof. by rewrite -{1}[n]decodeK ltn_code. Qed.

End CodeSeq.

Section OtherEncodings.
(* Miscellaneous encodings: option T -c-> seq T, T1 * T2 -c-> {i : T1 & T2}   *)
(* T1 + T2 -c-> option T1 * option T2, unit -c-> bool; bool -c-> nat is       *)
(* already covered in ssrnat by the nat_of_bool coercion, the odd predicate,  *)
(* and their "cancellation" lemma oddb. We use these encodings to propagate   *)
(* canonical structures through these type constructors so that ultimately    *)
(* all Choice and Countable instanced derive from nat and the seq and sigT    *)
(* constructors.                                                              *)

Variables T T1 T2 : Type.

Definition seq_of_opt := @oapp T _ (nseq 1) [::].
Lemma seq_of_optK : cancel seq_of_opt ohead. Proof. by case. Qed.

Definition tag_of_pair (p : T1 * T2) := @Tagged T1 p.1 (fun _ => T2) p.2.
Definition pair_of_tag (u : {i : T1 & T2}) := (tag u, tagged u).
Lemma tag_of_pairK : cancel tag_of_pair pair_of_tag. Proof. by case. Qed.
Lemma pair_of_tagK : cancel pair_of_tag tag_of_pair. Proof. by case. Qed.

Definition opair_of_sum (s : T1 + T2) :=
  match s with inl x => (Some x, None) | inr y => (None, Some y) end.
Definition sum_of_opair p :=
  oapp (some \o @inr T1 T2) (omap (@inl _ T2) p.1) p.2.
Lemma opair_of_sumK : pcancel opair_of_sum sum_of_opair. Proof. by case. Qed.

Lemma bool_of_unitK : cancel (fun _ => true) (fun _ => tt).
Proof. by case. Qed.

End OtherEncodings.

(* Generic variable-arity tree type, providing an encoding target for         *)
(* miscellaneous user datatypes. The GenTree.tree type can be combined with   *)
(* a sigT type to model multi-sorted concrete datatypes.                      *)
Module GenTree.

Section Def.

Variable T : Type.

Unset Elimination Schemes.
Inductive tree := Leaf of T | Node of nat & seq tree.

Definition tree_rect K IH_leaf IH_node :=
  fix loop t : K t := match t with
  | Leaf x => IH_leaf x
  | Node n f0 =>
    let fix iter_pair f : foldr (fun t => prod (K t)) unit f :=
      if f is t :: f' then (loop t, iter_pair f') else tt in
    IH_node n f0 (iter_pair f0)
  end.
Definition tree_rec (K : tree -> Set) := @tree_rect K.
Definition tree_ind K IH_leaf IH_node :=
  fix loop t : K t : Prop := match t with
  | Leaf x => IH_leaf x
  | Node n f0 =>
    let fix iter_conj f : foldr (fun t => and (K t)) True f :=
        if f is t :: f' then conj (loop t) (iter_conj f') else Logic.I
      in IH_node n f0 (iter_conj f0)
    end.

Fixpoint encode t : seq (nat + T) :=
  match t with
  | Leaf x => [:: inr _ x]
  | Node n f => inl _ n.+1 :: rcons (flatten (map encode f)) (inl _ 0)
  end.

Definition decode_step c fs :=
  match c with
  | inr x => (Leaf x :: fs.1, fs.2)
  | inl 0 => ([::], fs.1 :: fs.2)
  | inl n.+1 => (Node n fs.1 :: head [::] fs.2, behead fs.2)
  end.

Definition decode c := ohead (foldr decode_step ([::], [::]) c).1.

Lemma codeK : pcancel encode decode.
Proof.
move=> t; rewrite /decode; set fs := (_, _).
suffices ->: foldr decode_step fs (encode t) = (t :: fs.1, fs.2) by [].
elim: t => //= n f IHt in (fs) *; elim: f IHt => //= t f IHf [].
by rewrite rcons_cat foldr_cat => -> /= /IHf[-> -> ->].
Qed.

End Def.

End GenTree.
Arguments GenTree.codeK : clear implicits.

Definition tree_eqMixin (T : eqType) := PcanEqMixin (GenTree.codeK T).
Canonical tree_eqType (T : eqType) := EqType (GenTree.tree T) (tree_eqMixin T).

(* Structures for Types with a choice function, and for Types with countably  *)
(* many elements. The two concepts are closely linked: we indeed make         *)
(* Countable a subclass of Choice, as countable choice is valid in CiC. This  *)
(* apparent redundancy is needed to ensure the consistency of the Canonical   *)
(* inference, as the canonical Choice for a given type may differ from the    *)
(* countable choice for its canonical Countable structure, e.g., for options. *)
(*   The Choice interface exposes two choice functions; for T : choiceType    *)
(* and P : pred T, we provide:                                                *)
(*    xchoose : (exists x, P x) -> T                                          *)
(*    choose : pred T -> T -> T                                               *)
(*   While P (xchoose exP) will always hold, P (choose P x0) will be true if  *)
(* and only if P x0 holds. Both xchoose and choose are extensional in P and   *)
(* do not depend on the witness exP or x0 (provided P x0 holds). Note that    *)
(* xchoose is slightly more powerful, but less convenient to use.             *)
(*   However, neither choose nor xchoose are composable: it would not be      *)
(* be possible to extend the Choice structure to arbitrary pairs using only   *)
(* these functions, for instance. Internally, the interfaces provides a       *)
(* subtly stronger operation, Choice.InternalTheory.find, which performs a    *)
(* limited search using an integer parameter only rather than a full value as *)
(* [x]choose does. This is not a restriction in a constructive theory, where  *)
(* all types are concrete and hence countable. In the case of an axiomatic    *)
(* theory, such as that of the Coq reals library, postulating a suitable      *)
(* axiom of choice suppresses the need for guidance. Nevertheless this        *)
(* operation is just what is needed to make the Choice interface compose.     *)
(*   The Countable interface provides three functions; for T : countType we   *)
(* get pickle : T -> nat, and unpickle, pickle_inv : nat -> option T.         *)
(* The functions provide an effective embedding of T in nat: unpickle is a    *)
(* left inverse to pickle, which satisfies pcancel pickle unpickle, i.e.,     *)
(* unpickle \o pickle =1 some; pickle_inv is a more precise inverse for which *)
(* we also have ocancel pickle_inv pickle. Both unpickle and pickle need to   *)
(* be partial functions to allow for possibly empty types such as {x | P x}.  *)
(*   The names of these functions underline the correspondence with the       *)
(* notion of "Serializable" types in programming languages.                   *)
(*   Finally, we need to provide a join class to let type inference unify     *)
(* subType and countType class constraints, e.g., for a countable subType of  *)
(* an uncountable choiceType (the issue does not arise earlier with eqType or *)
(* choiceType because in practice the base type of an Equality/Choice subType *)
(* is always an Equality/Choice Type).                                        *)

Module Choice.

Section ClassDef.

Record mixin_of T := Mixin {
  find : pred T -> nat -> option T;
  _ : forall P n x, find P n = Some x -> P x;
  _ : forall P : pred T, (exists x, P x) -> exists n, find P n;
  _ : forall P Q : pred T, P =1 Q -> find P =1 find Q
}.

Record class_of T := Class {base : Equality.class_of T; mixin : mixin_of T}.
Local Coercion base : class_of >->  Equality.class_of.

Structure type := Pack {sort; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.
Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c T.
Let xT := let: Pack T _ _ := cT in T.
Notation xclass := (class : class_of xT).

Definition pack m :=
  fun b bT & phant_id (Equality.class bT) b => Pack (@Class T b m) T.

(* Inheritance *)
Definition eqType := @Equality.Pack cT xclass xT.

End ClassDef.

Module Import Exports.
Coercion base : class_of >-> Equality.class_of.
Coercion sort : type >-> Sortclass.
Coercion eqType : type >-> Equality.type.
Canonical eqType.
Notation choiceType := type.
Notation choiceMixin := mixin_of.
Notation ChoiceType T m := (@pack T m _ _ id).
Notation "[ 'choiceType' 'of' T 'for' cT ]" :=  (@clone T cT _ idfun)
  (at level 0, format "[ 'choiceType'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'choiceType' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'choiceType'  'of'  T ]") : form_scope.

End Exports.

Module InternalTheory.
Section InternalTheory.
(* Inner choice function. *)
Definition find T := find (mixin (class T)).

Variable T : choiceType.
Implicit Types P Q : pred T.

Lemma correct P n x : find P n = Some x -> P x.
Proof. by case: T => _ [_ []] //= in P n x *. Qed.

Lemma complete P : (exists x, P x) -> (exists n, find P n).
Proof. by case: T => _ [_ []] //= in P *. Qed.

Lemma extensional P Q : P =1 Q -> find P =1 find Q.
Proof. by case: T => _ [_ []] //= in P Q *. Qed.

Fact xchoose_subproof P exP : {x | find P (ex_minn (@complete P exP)) = Some x}.
Proof.
by case: (ex_minnP (complete exP)) => n; case: (find P n) => // x; exists x.
Qed.

End InternalTheory.
End InternalTheory.

End Choice.
Export Choice.Exports.

Section ChoiceTheory.

Implicit Type T : choiceType.
Import Choice.InternalTheory CodeSeq.
Local Notation dc := decode.

Section OneType.

Variable T : choiceType.
Implicit Types P Q : pred T.

Definition xchoose P exP := sval (@xchoose_subproof T P exP).

Lemma xchooseP P exP : P (@xchoose P exP).
Proof. by rewrite /xchoose; case: (xchoose_subproof exP) => x /= /correct. Qed.

Lemma eq_xchoose P Q exP exQ : P =1 Q -> @xchoose P exP = @xchoose Q exQ.
Proof.
rewrite /xchoose => eqPQ.
case: (xchoose_subproof exP) => x; case: (xchoose_subproof exQ) => y /=.
case: ex_minnP => n; case: ex_minnP => m.
rewrite -(extensional eqPQ) {1}(extensional eqPQ).
move=> Qm minPm Pn minQn; suffices /eqP->: m == n by move=> -> [].
by rewrite eqn_leq minQn ?minPm.
Qed.

Lemma sigW P : (exists x, P x) -> {x | P x}.
Proof. by move=> exP; exists (xchoose exP); apply: xchooseP. Qed.

Lemma sig2W P Q : (exists2 x, P x & Q x) -> {x | P x & Q x}.
Proof.
move=> exPQ; have [|x /andP[]] := @sigW (predI P Q); last by exists x.
by have [x Px Qx] := exPQ; exists x; apply/andP.
Qed.

Lemma sig_eqW (vT : eqType) (lhs rhs : T -> vT) :
  (exists x, lhs x = rhs x) -> {x | lhs x = rhs x}.
Proof.
move=> exP; suffices [x /eqP Ex]: {x | lhs x == rhs x} by exists x.
by apply: sigW; have [x /eqP Ex] := exP; exists x.
Qed.

Lemma sig2_eqW (vT : eqType) (P : pred T) (lhs rhs : T -> vT) :
  (exists2 x, P x & lhs x = rhs x) -> {x | P x & lhs x = rhs x}.
Proof.
move=> exP; suffices [x Px /eqP Ex]: {x | P x & lhs x == rhs x} by exists x.
by apply: sig2W; have [x Px /eqP Ex] := exP; exists x.
Qed.

Definition choose P x0 :=
  if insub x0 : {? x | P x} is Some (exist x Px) then
    xchoose (ex_intro [eta P] x Px)
  else x0.

Lemma chooseP P x0 : P x0 -> P (choose P x0).
Proof. by move=> Px0; rewrite /choose insubT xchooseP. Qed.

Lemma choose_id P x0 y0 : P x0 -> P y0 -> choose P x0 = choose P y0.
Proof. by move=> Px0 Py0; rewrite /choose !insubT /=; apply: eq_xchoose. Qed.

Lemma eq_choose P Q : P =1 Q -> choose P =1 choose Q.
Proof.
rewrite /choose => eqPQ x0.
do [case: insubP; rewrite eqPQ] => [[x Px] Qx0 _| ?]; last by rewrite insubN.
by rewrite insubT; apply: eq_xchoose.
Qed.

Section CanChoice.

Variables (sT : Type) (f : sT -> T).

Lemma PcanChoiceMixin f' : pcancel f f' -> choiceMixin sT.
Proof.
move=> fK; pose liftP sP := [pred x | oapp sP false (f' x)].
pose sf sP := [fun n => obind f' (find (liftP sP) n)].
exists sf => [sP n x | sP [y sPy] | sP sQ eqPQ n] /=.
- by case Df: (find _ n) => //= [?] Dx; have:= correct Df; rewrite /= Dx.
- have [|n Pn] := @complete T (liftP sP); first by exists (f y); rewrite /= fK.
  exists n; case Df: (find _ n) Pn => //= [x] _.
  by have:= correct Df => /=; case: (f' x).
by congr (obind _ _); apply: extensional => x /=; case: (f' x) => /=.
Qed.

Definition CanChoiceMixin f' (fK : cancel f f') :=
  PcanChoiceMixin (can_pcan fK).

End CanChoice.

Section SubChoice.

Variables (P : pred T) (sT : subType P).

Definition sub_choiceMixin := PcanChoiceMixin (@valK T P sT).
Definition sub_choiceClass := @Choice.Class sT (sub_eqMixin sT) sub_choiceMixin.
Canonical sub_choiceType := Choice.Pack sub_choiceClass sT.

End SubChoice.

Fact seq_choiceMixin : choiceMixin (seq T).
Proof.
pose r f := [fun xs => fun x : T => f (x :: xs) : option (seq T)].
pose fix f sP ns xs {struct ns} :=
  if ns is n :: ns1 then let fr := r (f sP ns1) xs in obind fr (find fr n)
  else if sP xs then Some xs else None.
exists (fun sP nn => f sP (dc nn) nil) => [sP n ys | sP [ys] | sP sQ eqPQ n].
- elim: {n}(dc n) nil => [|n ns IHs] xs /=; first by case: ifP => // sPxs [<-].
  by case: (find _ n) => //= [x]; apply: IHs.
- rewrite -(cats0 ys); elim/last_ind: ys nil => [|ys y IHs] xs /=.
    by move=> sPxs; exists 0; rewrite /= sPxs.
  rewrite cat_rcons => /IHs[n1 sPn1] {IHs}.
  have /complete[n]: exists z, f sP (dc n1) (z :: xs) by exists y.
  case Df: (find _ n)=> // [x] _; exists (code (n :: dc n1)).
  by rewrite codeK /= Df /= (correct Df).
elim: {n}(dc n) nil => [|n ns IHs] xs /=; first by rewrite eqPQ.
rewrite (@extensional _ _ (r (f sQ ns) xs)) => [|x]; last by rewrite IHs.
by case: find => /=.
Qed.
Canonical seq_choiceType := Eval hnf in ChoiceType (seq T) seq_choiceMixin.

End OneType.

Section TagChoice.

Variables (I : choiceType) (T_ : I -> choiceType).

Fact tagged_choiceMixin : choiceMixin {i : I & T_ i}.
Proof.
pose mkT i (x : T_ i) := Tagged T_ x.
pose ft tP n i := omap (mkT i) (find (tP \o mkT i) n).
pose fi tP ni nt := obind (ft tP nt) (find (ft tP nt) ni).
pose f tP n := if dc n is [:: ni; nt] then fi tP ni nt else None.
exists f => [tP n u | tP [[i x] tPxi] | sP sQ eqPQ n].
- rewrite /f /fi; case: (dc n) => [|ni [|nt []]] //=.
  case: (find _ _) => //= [i]; rewrite /ft.
  by case Df: (find _ _) => //= [x] [<-]; have:= correct Df.
- have /complete[nt tPnt]: exists y, (tP \o mkT i) y by exists x.
  have{tPnt}: exists j, ft tP nt j by exists i; rewrite /ft; case: find tPnt.
  case/complete=> ni tPn; exists (code [:: ni; nt]); rewrite /f codeK /fi.
  by case Df: find tPn => //= [j] _; have:= correct Df.
rewrite /f /fi; case: (dc n) => [|ni [|nt []]] //=.
rewrite (@extensional _ _ (ft sQ nt)) => [|i].
  by case: find => //= i; congr (omap _ _); apply: extensional => x /=.
by congr (omap _ _); apply: extensional => x /=.
Qed.
Canonical tagged_choiceType :=
  Eval hnf in ChoiceType {i : I & T_ i} tagged_choiceMixin.

End TagChoice.

Fact nat_choiceMixin : choiceMixin nat.
Proof.
pose f := [fun (P : pred nat) n => if P n then Some n else None].
exists f => [P n m | P [n Pn] | P Q eqPQ n] /=; last by rewrite eqPQ.
  by case: ifP => // Pn [<-].
by exists n; rewrite Pn.
Qed.
Canonical nat_choiceType := Eval hnf in ChoiceType nat nat_choiceMixin.

Definition bool_choiceMixin := CanChoiceMixin oddb.
Canonical bool_choiceType := Eval hnf in ChoiceType bool bool_choiceMixin.
Canonical bitseq_choiceType := Eval hnf in [choiceType of bitseq].

Definition unit_choiceMixin := CanChoiceMixin bool_of_unitK.
Canonical unit_choiceType := Eval hnf in ChoiceType unit unit_choiceMixin.

Definition option_choiceMixin T := CanChoiceMixin (@seq_of_optK T).
Canonical option_choiceType T :=
  Eval hnf in ChoiceType (option T) (option_choiceMixin T).

Definition sig_choiceMixin T (P : pred T) : choiceMixin {x | P x} :=
   sub_choiceMixin _.
Canonical sig_choiceType T (P : pred T) :=
 Eval hnf in ChoiceType {x | P x} (sig_choiceMixin P).

Definition prod_choiceMixin T1 T2 := CanChoiceMixin (@tag_of_pairK T1 T2).
Canonical prod_choiceType T1 T2 :=
  Eval hnf in ChoiceType (T1 * T2) (prod_choiceMixin T1 T2).

Definition sum_choiceMixin T1 T2 := PcanChoiceMixin (@opair_of_sumK T1 T2).
Canonical sum_choiceType T1 T2 :=
  Eval hnf in ChoiceType (T1 + T2) (sum_choiceMixin T1 T2).

Definition tree_choiceMixin T := PcanChoiceMixin (GenTree.codeK T).
Canonical tree_choiceType T := ChoiceType (GenTree.tree T) (tree_choiceMixin T).

End ChoiceTheory.

Prenex Implicits xchoose choose.
Notation "[ 'choiceMixin' 'of' T 'by' <: ]" :=
  (sub_choiceMixin _ : choiceMixin T)
  (at level 0, format "[ 'choiceMixin'  'of'  T  'by'  <: ]") : form_scope.

Module Countable.

Record mixin_of (T : Type) : Type := Mixin {
  pickle : T -> nat;
  unpickle : nat -> option T;
  pickleK : pcancel pickle unpickle
}.

Definition EqMixin T m := PcanEqMixin (@pickleK T m).
Definition ChoiceMixin T m := PcanChoiceMixin (@pickleK T m).

Section ClassDef.

Record class_of T := Class { base : Choice.class_of T; mixin : mixin_of T }.
Local Coercion base : class_of >-> Choice.class_of.

Structure type : Type := Pack {sort : Type; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.
Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c T.
Let xT := let: Pack T _ _ := cT in T.
Notation xclass := (class : class_of xT).

Definition pack m :=
  fun bT b & phant_id (Choice.class bT) b => Pack (@Class T b m) T.

Definition eqType := @Equality.Pack cT xclass xT.
Definition choiceType := @Choice.Pack cT xclass xT.

End ClassDef.

Module Exports.
Coercion base : class_of >-> Choice.class_of.
Coercion mixin : class_of >-> mixin_of.
Coercion sort : type >-> Sortclass.
Coercion eqType : type >-> Equality.type.
Canonical eqType.
Coercion choiceType : type >-> Choice.type.
Canonical choiceType.
Notation countType := type.
Notation CountType T m := (@pack T m _ _ id).
Notation CountMixin := Mixin.
Notation CountChoiceMixin := ChoiceMixin.
Notation "[ 'countType' 'of' T 'for' cT ]" := (@clone T cT _ idfun)
 (at level 0, format "[ 'countType'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'countType' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'countType'  'of'  T ]") : form_scope.

End Exports.

End Countable.
Export Countable.Exports.

Definition unpickle T := Countable.unpickle (Countable.class T).
Definition pickle T := Countable.pickle (Countable.class T).
Arguments unpickle [T].
Prenex Implicits pickle unpickle.

Section CountableTheory.

Variable T : countType.

Lemma pickleK : @pcancel nat T pickle unpickle.
Proof. exact: Countable.pickleK. Qed.

Definition pickle_inv n :=
  obind (fun x : T => if pickle x == n then Some x else None) (unpickle n).

Lemma pickle_invK : ocancel pickle_inv pickle.
Proof.
by rewrite /pickle_inv => n; case def_x: (unpickle n) => //= [x]; case: eqP.
Qed.

Lemma pickleK_inv : pcancel pickle pickle_inv.
Proof. by rewrite /pickle_inv => x; rewrite pickleK /= eqxx. Qed.

Lemma pcan_pickleK sT f f' :
  @pcancel T sT f f' -> pcancel (pickle \o f) (pcomp f' unpickle).
Proof. by move=> fK x; rewrite /pcomp pickleK /= fK. Qed.

Definition PcanCountMixin sT f f' (fK : pcancel f f') :=
  @CountMixin sT _ _ (pcan_pickleK fK).

Definition CanCountMixin sT f f' (fK : cancel f f') :=
  @PcanCountMixin sT _ _ (can_pcan fK).

Definition sub_countMixin P sT := PcanCountMixin (@valK T P sT).

Definition pickle_seq s := CodeSeq.code (map (@pickle T) s).
Definition unpickle_seq n := Some (pmap (@unpickle T) (CodeSeq.decode n)).
Lemma pickle_seqK : pcancel pickle_seq unpickle_seq.
Proof. by move=> s; rewrite /unpickle_seq CodeSeq.codeK (map_pK pickleK). Qed.

Definition seq_countMixin := CountMixin pickle_seqK.
Canonical seq_countType := Eval hnf in CountType (seq T) seq_countMixin.

End CountableTheory.

Notation "[ 'countMixin' 'of' T 'by' <: ]" :=
    (sub_countMixin _ : Countable.mixin_of T)
  (at level 0, format "[ 'countMixin'  'of'  T  'by'  <: ]") : form_scope.

Section SubCountType.

Variables (T : choiceType) (P : pred T).
Import Countable.

Structure subCountType : Type :=
  SubCountType {subCount_sort :> subType P; _ : mixin_of subCount_sort}.

Coercion sub_countType (sT : subCountType) :=
  Eval hnf in pack (let: SubCountType _ m := sT return mixin_of sT in m) id.
Canonical sub_countType.

Definition pack_subCountType U :=
  fun sT cT & sub_sort sT * sort cT -> U * U =>
  fun b m   & phant_id (Class b m) (class cT) => @SubCountType sT m.

End SubCountType.

(* This assumes that T has both countType and subType structures. *)
Notation "[ 'subCountType' 'of' T ]" :=
    (@pack_subCountType _ _ T _ _ id _ _ id)
  (at level 0, format "[ 'subCountType'  'of'  T ]") : form_scope.

Section TagCountType.

Variables (I : countType) (T_ : I -> countType).

Definition pickle_tagged (u : {i : I & T_ i}) :=
  CodeSeq.code [:: pickle (tag u); pickle (tagged u)].
Definition unpickle_tagged s :=
  if CodeSeq.decode s is [:: ni; nx] then
    obind (fun i => omap (@Tagged I i T_) (unpickle nx)) (unpickle ni)
  else None.
Lemma pickle_taggedK : pcancel pickle_tagged unpickle_tagged.
Proof.
by case=> i x; rewrite /unpickle_tagged CodeSeq.codeK /= pickleK /= pickleK.
Qed.

Definition tag_countMixin := CountMixin pickle_taggedK.
Canonical tag_countType := Eval hnf in CountType {i : I & T_ i} tag_countMixin.

End TagCountType.

(* The remaining Canonicals for standard datatypes. *)
Section CountableDataTypes.

Implicit Type T : countType.

Lemma nat_pickleK : pcancel id (@Some nat). Proof. by []. Qed.
Definition nat_countMixin := CountMixin nat_pickleK.
Canonical nat_countType := Eval hnf in CountType nat nat_countMixin.

Definition bool_countMixin := CanCountMixin oddb.
Canonical bool_countType := Eval hnf in CountType bool bool_countMixin.
Canonical bitseq_countType :=  Eval hnf in [countType of bitseq].

Definition unit_countMixin := CanCountMixin bool_of_unitK.
Canonical unit_countType := Eval hnf in CountType unit unit_countMixin.

Definition option_countMixin T := CanCountMixin (@seq_of_optK T).
Canonical option_countType T :=
  Eval hnf in CountType (option T) (option_countMixin T).

Definition sig_countMixin T (P : pred T) := [countMixin of {x | P x} by <:].
Canonical sig_countType T (P : pred T) :=
  Eval hnf in CountType {x | P x} (sig_countMixin P).
Canonical sig_subCountType T (P : pred T) :=
  Eval hnf in [subCountType of {x | P x}].

Definition prod_countMixin T1 T2 := CanCountMixin (@tag_of_pairK T1 T2).
Canonical prod_countType T1 T2 :=
  Eval hnf in CountType (T1 * T2) (prod_countMixin T1 T2).

Definition sum_countMixin T1 T2 := PcanCountMixin (@opair_of_sumK T1 T2).
Canonical sum_countType T1 T2 :=
  Eval hnf in CountType (T1 + T2) (sum_countMixin T1 T2).

Definition tree_countMixin T := PcanCountMixin (GenTree.codeK T).
Canonical tree_countType T := CountType (GenTree.tree T) (tree_countMixin T).

End CountableDataTypes.


Require Import CSSsVerification.
Import ListNotations.

Definition i  : id := Id "i".
Definition f1 : id := Id "f1".
Definition f2 : id := Id "f2".
Definition f3 : id := Id "f3".
Definition f4 : id := Id "f4".
Definition f5 : id := Id "f5".
Definition f6 : id := Id "f6".
Definition f7 : id := Id "f7".
Definition bc : id := Id "bc".
Definition bk : id := Id "bk".
Definition tv : id := Id "tv".

Definition Append :=
  i ::= (ANum 1);;
  WHILE (BLe (AId i) (AFsize f1)) DO
    CBlookup bc (BKAddr f1 (AId i));;
    CFcontentAppend f2 [(BKId bc)];;
    i ::= (APlus (AId i) (ANum 1))
  END.

Example append_correct :
  {{ [[ (eqV (AFsize f3) (AFsize f1)) &
        (point_toF f1 (Fi f3)) @@ (point_toF f2 (Fi f4)) ]]
  }}

  Append

  {{ [[ (eqV (AFsize f3) (AFsize f1)) &
        (point_toF f1 (Fi f3)) @@ (point_toF f2 (Appfe (Fi f4) (Fi f3))) ]]
  }}.
Proof.
  unfold Append.
  apply rule_seq with
    (Q:= [[ (eqV (AId i) (APlus (AFsize f1) (ANum 1))) //\\
            (eqV (AFsize f5) (AMinus (AId i) (ANum 1))) //\\
            (eqV (AFsize f6) (APlus (AMinus (AFsize f1) (AId i)) (ANum 1)))
          & point_toF f1 (Appfe (Fi f5) (Fi f6)) @@
            point_toF f2 (Appfe (Fi f4) (Fi f5)) ]]).
  -apply rule_consequence_post with
        (Q':= (fun st => (([[ (eqV (AFsize f5) (AMinus (AId i) (ANum 1))) //\\
                            (eqV (AFsize f6) (APlus (AMinus (AFsize f1) (AId i)) (ANum 1)))
                          & point_toF f1 (Appfe (Fi f5) (Fi f6)) @@
                            point_toF f2 (Appfe (Fi f4) (Fi f5)) ]]) st)
                         /\ not (bassn (BLe (AId i) (AFsize f1)) st))).
   eapply rule_consequence_pre.
   apply rule_while.
   apply rule_seq with
      (Q:= [[ (leV (AId i) (AFsize f1)) //\\
              (eqV (AFsize f5) (AMinus (AId i) (ANum 1))) //\\
              (eqV (AFsize f7) (AMinus (AFsize f1) (AId i)))
            & point_toF f1 (Appfe (Appbk (Fi f5) (BKId bk)) (Fi f7)) @@
              point_toF f2 (Appfe (Fi f4) (Fi f5)) /@\
              (bk_eq (BKId bc) (BKId bk)) ]]).
   +apply rule_seq with
      (Q:= [[ (leV (AId i) (AFsize f1)) //\\ (eqV (AFsize f5) (AId i)) //\\
              (eqV (AFsize f6) (AMinus (AFsize f1) (AId i)))
              & point_toF f1 (Appfe (Fi f5) (Fi f6)) @@
                point_toF f2 (Appfe (Fi f4) (Fi f5)) ]]).
    *eapply rule_consequence_pre.
     apply rule_asgn.
    *eapply rule_consequence_pre.
     apply rule_consequence_post with
        (Q':= [[  (leV (AId i) (AFsize f1)) //\\
                  (eqV (AFsize f5) (AMinus (AId i) (ANum 1))) //\\
                  (eqV (AFsize f7) (AMinus (AFsize f1) (AId i)))
               &  point_toF f2 (Appbk (Appfe (Fi f4) (Fi f5)) (BKId bc))
              ]]).
     apply rule_FcontentAppendBk.
     ++unfold not_appear. auto.
   +apply rule_consequence_post with
        (Q':= [[  (leV (AId i) (AFsize f1)) //\\
                  (eqV (AFsize f5) (AMinus (AId i) (ANum 1))) //\\
                  (eqV (AFsize f7) (AMinus (AFsize f1) (AId i)))
               &  (BKId bc =b= (BKId bk)) /@\
                  (point_toB (BKAddr f1 (AId i)) (bk_sub bc (BKId tv) (BKId bk)))
              ]]).
    eapply rule_consequence_pre.
    apply rule_Blookup.
  -apply rule_consequence_post with
        (Q':= [[  (leV (AId i) (APlus (AFsize f1) (ANum 1))) //\\
                  (eqV (AFsize f5) (AMinus (AId i) (ANum 1))) //\\
                  (eqV (AFsize f6) (APlus (AMinus (AFsize f1) (AId i)) (ANum 1)))
              & point_toF f1 (Appfe (Fi f5) (Fi f6)) @@
                point_toF f2 (Appfe (Fi f4) (Fi f5)) ]]).
   eapply rule_consequence_pre.
   apply rule_asgn.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A1 A2 B1 B2 C1 C2 P : Universe, ((wd_ A1 A2 /\ (wd_ B1 B2 /\ (wd_ A1 A2 /\ (wd_ C1 C2 /\ (col_ P B1 B2 /\ (col_ P C1 C2 /\ (col_ A1 B1 B2 /\ (col_ A2 B1 B2 /\ (col_ A1 C1 C2 /\ col_ A2 C1 C2))))))))) -> col_ C1 B1 B2)).
Proof.
  time tac.
Qed.

End FOFProblem.