Require Import List.

(*

BNF : Backus Naur Form

A BNF is a concise way of describing a set of objects.

  bit ::= 0 | 1

  binary_string ::= bit | binary_string bit

  (* in class *)
  parens ::= () | ( parens ) | parens parens

BNF is a metalanguage.

Normally write in concrete syntax.

Can be ambiguous.

Converting concrete syntax to abstract syntax is parsing.

*)

Definition name := nat.

(* why expr first? *)
Inductive expr : Set :=
| const : nat -> expr
| var : name -> expr
| add : expr -> expr -> expr
| mul : expr -> expr -> expr.

Inductive stmt : Set :=
| skip : stmt
| updt : name -> expr -> stmt
| seq : stmt -> stmt -> stmt
| branch : expr -> stmt -> stmt -> stmt
| loop : expr -> stmt -> stmt.

Fixpoint nconsts (e: expr) : nat :=
  match e with
    | const n => 1
    | var v => 0
    | add l r => nconsts l + nconsts r
    | mul l r => nconsts l + nconsts r
  end.

Lemma has_3_consts:
  exists e, nconsts e = 3.
Proof.
  exists (add (const 1) (add (const 1) (const 1))). reflexivity.
Qed.

Check orb.

Fixpoint has_const (e: expr) : bool :=
  match e with
    | const _ => true
    | var _ => false
    | add l r => orb (has_const l) (has_const r)
    | mul l r => orb (has_const l) (has_const r)
  end.

Fixpoint has_var (e: expr) : bool :=
  match e with
    | const _ => false
    | var _ => true
    | add l r => orb (has_var l) (has_var r)
    | mul l r => orb (has_var l) (has_var r)
  end.

Lemma bottoms_out:
  forall e, has_const e = true \/ has_var e = true.
Proof.
  intro. induction e.
  firstorder.
  firstorder.
  destruct IHe1.
  simpl. firstorder.
  destruct IHe2.
  simpl. firstorder.
  simpl.


Require Import ProofIrrelevance.
Require Import Eqdep_dec.

Require Import foltl.
Require Import set.
Require Import dec.
Require Import finite.

Section VarSet.

Context {Ts: Type} {Tv: Ts->Type} {Tc: Ts->Type} {Tp: Type}.
Variable Sg: @Sig Ts Tv Tc Tp.

Definition VarSet := forall s, SV.set (variable s).

Definition vsIn {s} (v: variable s) (F: VarSet) := SV.set_In v (F s).

Lemma vsIn_dec {s} (v: variable s) F : {vsIn v F} + {not (vsIn v F)}.
Proof.
  destruct (SV.set_In_dec v (F s)); [left|right]; auto.
Defined.

Definition vsSubset e1 e2 := forall s, SV.subset (T:=variable s) (e1 s) (e2 s).

Lemma vsSubset_dec e1 e2 : {vsSubset e1 e2} + { not (vsSubset e1 e2) }.
Proof.
  intros.
  unfold vsSubset.
  destruct (all_dec (fun (s: (Sort (Sig:=Sg))) => {| dc_dec := SV.subset_dec (e1 s) (e2 s) |})); simpl in *.
  left; auto.
  destruct s as [s h].
  right; intro.
  apply h; apply H.
Defined.

Lemma vsSubset_refl : forall e, vsSubset e e.
Proof.
  repeat intro; auto.
Qed.

Lemma vsSubset_trans : forall {e1 e2 e3}, vsSubset e1 e2 -> vsSubset e2 e3 -> vsSubset e1 e3.
Proof.
  repeat intro; auto.
  apply H0.
  apply H.
  auto.
Qed.

Definition vsAdd {s} (v: variable s) (e: VarSet): VarSet :=
  fun s' =>
    match eq_dec s s' with
      left h => match h in _=s' return SV.set (variable s') with
                  eq_refl => SV.add v (e s)
                end
    | right _ => e s'
    end.

Lemma vsAdd_l: forall {s} (v: variable s) (e: VarSet),
  SV.set_In v (vsAdd v e s).
Proof.
  unfold vsAdd; simpl; intros.
  destruct (eq_dec s s); try tauto.
  rewrite (proof_irrelevance _ e0 eq_refl).
  apply SV.InAdd_l.
Qed.

Lemma vsAdd_r: forall {s s'} (v: variable s) (e: VarSet) {w: variable s'},
  SV.set_In w (e s') -> SV.set_In w (vsAdd v e s').
Proof.
  intros.
  unfold vsAdd.
  destruct (eq_dec s s'); auto.
  subst s'.
  apply SV.InAdd_r; auto.
Qed.

Lemma vsAdd_elim: forall {s s'} (v: variable s) (e: VarSet) {w: variable s'},
  SV.set_In w (vsAdd v e s') -> isEq2 (U:=variable) s' w s v \/ SV.set_In w (e s').
Proof.
  intros.
  unfold vsAdd in H.
  unfold isEq2; simpl.
  destruct (eq_dec s s').
  subst s'.
  apply SV.InAdd in H; destruct H.
  subst v.
  left; auto.
  right; auto.
  right; auto.
Qed.

Lemma vsAdd_ne: forall {s s'} {v: variable s} {e: VarSet} {w: variable s'},
  SV.set_In w (vsAdd v e s') -> not (isEq2 (U:=variable) s' w s v) -> SV.set_In w (e s').
Proof.
  intros.
  apply vsAdd_elim in H.
  destruct H; tauto.
Qed.

Lemma vsAdd_ne2: forall {s s'} {v: variable s} {e: VarSet} {w: variable s'},
  SV.set_In w (vsAdd v e s') -> not (SV.set_In w (e s')) -> (isEq2 (U:=variable) s' w s v).
Proof.
  intros.
  apply vsAdd_elim in H.
  destruct H; tauto.
Qed.

Definition vsEmpty: VarSet := fun s => SV.empty _.

Definition vsSing {s} (v: variable s): VarSet :=
  fun s' =>
    match eq_dec s s' with
      left h => match h in _=s' return SV.set (variable s') with
                  eq_refl => SV.sing _  v
                end
    | right _ => SV.empty _
    end.

Definition vsUnion (e1 e2: VarSet): VarSet :=
  fun s => SV.union (e1 s) (e2 s).

Lemma vsUnion_l: forall {s v} {e1 e2: VarSet},
  SV.set_In v (e1 s) -> SV.set_In v (vsUnion e1 e2 s).
Proof.
  intros.
  apply SV.InUnion_l; auto.
Qed.

Lemma vsUnion_r: forall {s v} {e1 e2: VarSet},
  SV.set_In v (e2 s) -> SV.set_In v (vsUnion e1 e2 s).
Proof.
  intros.
  apply SV.InUnion_r; auto.
Qed.

Lemma vsUnion_elim: forall {s v} {e1 e2: VarSet},
  SV.set_In v (vsUnion e1 e2 s) -> SV.set_In v (e1 s) \/ SV.set_In v (e2 s).
Proof.
  intros.
  apply SV.InUnion in H.
  destruct H; tauto.
Qed.

Lemma vsUnion_equiv: forall {s} {v: variable s} {e1 e2: VarSet},
  vsIn v (vsUnion e1 e2) <-> vsIn v e1 \/ vsIn v e2.
Proof.
  intros; split; intro.
  apply vsUnion_elim in H; apply H.
  destruct H; [apply vsUnion_l | apply vsUnion_r]; apply H.
Qed.

Definition vsInter (e1 e2: VarSet): VarSet :=
  fun s => SV.inter (e1 s) (e2 s).

Lemma vsInter_intro: forall {s v} {e1 e2: VarSet},
  SV.set_In v (e1 s) -> SV.set_In v (e2 s) -> SV.set_In v (vsInter e1 e2 s).
Proof.
  intros.
  apply SV.InInter; auto.
Qed.

Lemma vsInter_elim: forall {s v} {e1 e2: VarSet},
  SV.set_In v (vsInter e1 e2 s) -> SV.set_In v (e1 s) /\ SV.set_In v (e2 s).
Proof.
  intros; split.
  apply SV.InInter_l in H; auto.
  apply SV.InInter_r in H; auto.
Qed.

Definition vsGUnion `{K: Finite} (ek: K->VarSet): VarSet :=
  fun s => SV.GUnion (T1:=K) (T2:=variable s) fin_set fin_set (fun k _ => ek k s).

Lemma vsGUnion_intro `{K:Finite} {ek: K->VarSet}:
  forall s k, SV.subset (ek k s) (vsGUnion ek s).
Proof.
  repeat intro.
  unfold vsGUnion.
  apply SV.InCUnion_intro with (u:=k); simpl; auto.
  apply fin_all.
  apply fin_all.
Qed.

Lemma vsGUnion_elim `{K:Finite} {ek: K->VarSet} s (v: variable s):
  vsIn v (vsGUnion ek) -> exists k, vsIn v (ek k).
Proof.
  repeat intro.
  unfold vsGUnion in H.
  apply SV.InCUnion_elim in H; simpl; auto.
  destruct H as [k [h1 [h2 h3]]].
  exists k.
  apply h3.
  apply h2.
Qed.

Lemma vsSubsetUnion_elim_l: forall e1 e2 e,
  vsSubset (vsUnion e1 e2) e -> vsSubset e1 e.
Proof.
  repeat intro.
  apply (H s v); clear H; intros.
  apply vsUnion_l; auto.
Qed.

Lemma vsSubsetUnion_elim_r: forall e1 e2 e,
  vsSubset (vsUnion e1 e2) e -> vsSubset e2 e.
Proof.
  repeat intro.
  apply (H s v); clear H; intros.
  apply vsUnion_r; auto.
Qed.

Lemma vsSubsetGUnion_elim `{K:Finite} {ek: K->VarSet} e:
  vsSubset (vsGUnion ek) e -> forall k, vsSubset (ek k) e.
Proof.
  repeat intro.
  unfold vsGUnion.
  apply (H s v); clear H.
  apply SV.InCUnion_intro with (u:=k); simpl; auto.
  apply fin_all.
  apply fin_all.
Qed.

Definition vsRemove {s} (v: variable s) (e: VarSet): VarSet :=
  fun s' => match eq_dec s s' with
    left h =>
      match h in _=s' return SV.set (variable s') with
        eq_refl => SV.remove v (e s)
      end
  | right _ => e s'
  end.

Lemma vsInRemove_intro: forall s (v: variable s) (e: VarSet) s' (w: variable s'),
  vsIn w e -> not (isEq2 (U:=variable) s v s' w) -> vsIn w (vsRemove v e).
Proof.
  intros.
  unfold vsRemove, vsIn; simpl.
  destruct (eq_dec s s'); auto.
  subst s'.
  apply SV.InRemove.
  intro.
  subst w.
  apply H0; reflexivity.
  apply H.
Qed.

Lemma vsInRemove_elim: forall s (v: variable s) (e: VarSet) s' (w: variable s'),
  vsIn w (vsRemove v e) -> vsIn w e /\ not (isEq2 (U:=variable) s v s' w).
Proof.
  intros.
  unfold vsRemove, vsIn in H.
  destruct (eq_dec s s'); auto.
  subst s'.
  split.
  apply SV.InRemove_r in H; apply H.
  apply SV.InRemove_l in H.
  simpl; intro.
  apply H; clear H.
  apply inj_pair2_eq_dec in H0; try apply eq_dec.
  symmetry; apply H0.

  split.
  apply H.
  intro; apply n; clear n.
  injection H0; intro; auto.
Qed.

Lemma vsRemove_equiv: forall {s} {v: variable s} {e: VarSet} s' (v': variable s'),
  vsIn v' (vsRemove v e) <-> vsIn v' e /\ not (isEq2 (U:=variable) s v s' v').
Proof.
  intros; split; intro.
  apply vsInRemove_elim in H; apply H.
  apply vsInRemove_intro; tauto.
Qed.

Definition vsFinite (vs: VarSet): Finite :=
  DepPairFin Sort (fun s => asFinite (vs s)).

Lemma vsSing_intro: forall s v, SV.set_In v (vsSing v s).
Proof.
  intros.
  unfold vsSing.
  destruct (eq_dec s s); try tauto.
  rewrite (proof_irrelevance _ e eq_refl).
  left; auto.
Qed.

Lemma vsSing_intro_eq: forall s (v: variable s) s' (w: variable s'), isEq2 (U:=variable) s v s' w -> vsIn v (vsSing w).
Proof.
  intros.
  unfold vsSing, vsIn.
  destruct (eq_dec s' s); try tauto.
  subst s'.
  left.
  apply inj_pair2_eq_dec in H; try apply eq_dec.
  symmetry; assumption.
  exfalso; apply n.
  injection H; intros; auto.
Qed.

Lemma vsSing_elim: forall s (v: variable s) s' (w: variable s'),
  SV.set_In v (vsSing w s) -> isEq2 (U:=variable) s v s' w.
Proof.
  intros.
  unfold vsSing in H.
  unfold isEq2; simpl.
  destruct (eq_dec s' s); try tauto; subst.
  destruct H; try tauto; subst; auto.
Qed.

Lemma vsSubsetSing: forall {s} {v: variable s} e, vsSubset (vsSing v) e -> SV.set_In v (e s).
Proof.
  intros.
  apply SV.subset_sing; repeat intro.
  generalize (H s v0); intro.
  apply H1.
  destruct H0.
  subst v0.
  apply vsSing_intro.
  destruct H0.
Qed.

Lemma vsSubsetSing_r: forall {s} {v: variable s} e, vsSubset e (vsSing v) -> forall s' (w: variable s'), vsIn w e -> isEq2 (U:=variable) s' w s v.
Proof.
  intros.
  generalize (H _ w H0); clear H; intro.
  apply vsSing_elim in H; auto.
Qed.

Definition vsVars `{K: Finite} {sk: K->Sort} (vk: forall k, variable (sk k)) : VarSet :=
  vsGUnion (fun k => vsSing (vk k)).

Lemma vsVars_intro: forall `{K: Finite} {sk: K->Sort} (vk: forall k, variable (sk k)),
  forall k, SV.set_In (vk k) (vsVars vk (sk k)).
Proof.
  intros.
  apply SV.InCUnion_intro with (u:=k); auto.
  apply fin_all; simpl; intros; auto.
  apply fin_all.
  intro.
  apply vsSing_intro.
Qed.

Lemma vsVars_elim: forall `{K: Finite} {sk: K->Sort} (vk: forall k, variable (sk k)),
  forall s (v: variable s), SV.set_In v (vsVars vk s) -> exists k, isEq2 (U:=variable) (sk k) (vk k) s v.
Proof.
  intros.
  unfold vsVars in H.
  apply SV.InCUnion_elim in H.
  destruct H as [u [h1 [h2 h3]]].
  exists u; unfold isEq2; simpl.
  apply h3 in h2; clear h3.
  apply vsSing_elim in h2.
  symmetry; apply h2.
Qed.

End VarSet.

Require Import Coq.Logic.FunctionalExtensionality.

Section VSMap.
  Context {Ts: Type}.
  Context `{srcSig: Sig (Ts:=Ts)}.
  Context `{dstSig: Sig (Ts:=Ts)}.
  Variable f : forall s, variable (Sig:=srcSig) s -> variable (Sig:=dstSig) s.

  Definition vsMap e: VarSet dstSig := fun s => List.map (f s) (e s).

  Lemma vsSubset_map: forall {e1 e2}, vsSubset srcSig e1 e2 -> vsSubset dstSig (vsMap e1) (vsMap e2).
  Proof.
    unfold vsMap; repeat intro.
    apply List.in_map_iff in H0.
    destruct H0 as [x [h1 h2]]; subst v.
    apply List.in_map_iff.
    exists x; split; auto.
    apply H in h2; auto.
  Qed.

  Lemma vsMap_In_intro: forall {s v e}, vsIn srcSig v e -> vsIn dstSig (f s v) (vsMap e).
  Proof.
    unfold vsIn, vsMap; intros.
    apply List.in_map_iff.
    exists v; split; auto.
  Qed.

  Lemma vsUnion_map_l: forall {e e1 e2},
    vsSubset _ (vsUnion srcSig e1 e2) e -> vsSubset _ (vsUnion dstSig (vsMap e1) (vsMap e2)) (vsMap e) .
  Proof.
    repeat intro.
    apply (vsUnion_elim dstSig) in H0.
    destruct H0; apply List.in_map_iff in H0; destruct H0 as [x [h1 h2]]; subst v;
      apply List.in_map_iff; exists x; split; auto; apply H.
    now apply vsUnion_l.
    now apply vsUnion_r.
  Qed.

  Lemma vsUnion_map_r: forall {e e1 e2},
    vsSubset _ e (vsUnion srcSig e1 e2) -> vsSubset _ (vsMap e) (vsUnion dstSig (vsMap e1) (vsMap e2)).
  Proof.
    repeat intro.
    apply List.in_map_iff in H0.
    destruct H0 as [x [h1 h2]]; subst v.
    apply H in h2.
    apply vsUnion_elim in h2.
    destruct h2; [apply SV.InUnion_l | apply SV.InUnion_r]; apply List.in_map_iff; exists x; auto.
  Qed.

  Definition isInj {T1 T2} (f: T1 -> T2) := forall x1 x2, f x1 = f x2 -> x1 = x2.

  Lemma vsMap_add: forall s (v: variable s) (hf: forall s, isInj (f s)) e,
    vsAdd dstSig (f s v) (vsMap e) = vsMap (vsAdd srcSig v e).
  Proof.
    intros.
    apply functional_extensionality_dep; intros s'.
    unfold vsMap, vsAdd; simpl.
    destruct (eq_dec s s'); auto.
    subst s'.
    match goal with |- match ?cnd with _=>_ end=_ => destruct cnd end.
    rewrite (proof_irrelevance _ _ eq_refl).
    generalize (hf s); generalize (f s); intros g hg; clear hf f.
    generalize (e s); clear e; intro l.
    induction l; simpl; intros; auto.
    destruct (eq_dec v a).
    subst a.
    match goal with |- match ?cnd with _=>_ end=_ => destruct cnd; tauto end.
    match goal with |- match ?cnd with _=>_ end=_ => destruct cnd end.
    apply hg in e; tauto.
    simpl; rewrite <-IHl; clear IHl.
    reflexivity.
    tauto.
    match goal with |- match ?cnd with _=>_ end=_ => destruct cnd; tauto end.
  Qed.

  Lemma vsMap_In_elim: forall  {s v e},
    (forall s, isInj (f s)) -> vsIn dstSig (f s v) (vsMap e) -> vsIn srcSig v e.
  Proof.
    unfold vsIn, vsMap; intros.
    apply List.in_map_iff in H0.
    destruct H0 as [x [h1 h2]].
    apply H in h1; subst x; auto.
  Qed.

  Lemma vsMap_In_ran: forall {s v e},
    vsIn dstSig v (vsMap e) -> exists v', v = f s v'.
  Proof.
    unfold vsIn, vsMap; intros.
    apply List.in_map_iff in H.
    destruct H as [x [h1 h2]].
    exists x; symmetry; auto.
  Qed.

  Lemma vsMap_Union: forall {e1 e2}, (forall s, isInj (f s)) -> forall s' (v': variable (Sig:=dstSig) s'),
    vsIn _ v' (vsMap (vsUnion srcSig e1 e2)) <-> vsIn _ v' (vsUnion dstSig (vsMap e1) (vsMap e2)).
  Proof.
    intros.
    split; intro.
    destruct (vsMap_In_ran H0) as [v h]; subst v'.
    apply (vsMap_In_elim) in H0; auto.
    apply vsUnion_elim in H0.
    destruct H0; [apply vsUnion_l | apply vsUnion_r]; apply vsMap_In_intro; auto.

    apply vsUnion_elim in H0; destruct H0.
    destruct (vsMap_In_ran H0) as [v h]; subst v'.
    apply vsMap_In_elim in H0; auto.
    apply vsMap_In_intro; apply vsUnion_l; apply H0.

    destruct (vsMap_In_ran H0) as [v h]; subst v'.
    apply vsMap_In_elim in H0; auto.
    apply vsMap_In_intro; apply vsUnion_r; apply H0.
  Qed.

  Lemma vsMap_Inter: forall {e1 e2}, (forall s, isInj (f s)) -> forall s' (v': variable (Sig:=dstSig) s'),
    vsIn _ v' (vsMap (vsInter srcSig e1 e2)) <-> vsIn _ v' (vsInter dstSig (vsMap e1) (vsMap e2)).
  Proof.
    intros.
    split; intro.
    destruct (vsMap_In_ran H0) as [v h]; subst v'.
    apply (vsMap_In_elim) in H0; auto.
    apply vsInter_elim in H0; destruct H0.
    apply vsInter_intro; apply vsMap_In_intro; auto.

    apply vsInter_elim in H0; destruct H0.
    destruct (vsMap_In_ran H0) as [v h]; subst v'.
    apply vsMap_In_intro.
    apply (vsMap_In_elim H) in H0.
    apply (vsMap_In_elim H) in H1.
    apply vsInter_intro; auto.
  Qed.

  Lemma vsMap_Remove: forall {s v} {e}, (forall s, isInj (f s)) -> forall s' (v': variable (Sig:=dstSig) s'),
    vsIn _ v' (vsMap (vsRemove srcSig v e)) <-> vsIn _ v' (vsRemove dstSig (f s v) (vsMap e)).
  Proof.
    intros; split; intro.
    destruct (vsMap_In_ran H0) as [w h]; subst v'.
    apply (vsMap_In_elim) in H0; auto.
    apply vsInRemove_elim in H0.
    apply vsInRemove_intro; auto.
    apply vsMap_In_intro; tauto.
    intro; apply proj2 in H0; apply H0; clear H0.
    inversion H1; clear H1; intros; subst s'.
    apply inj_pair2_eq_dec in H3; try apply eq_dec.
    apply (H s) in H3; subst w; constructor.

    apply vsInRemove_elim in H0; destruct H0.
    destruct (vsMap_In_ran H0) as [w h]; subst v'.
    apply (vsMap_In_elim) in H0; auto.
    apply vsMap_In_intro; auto.
    apply vsInRemove_intro; auto.
    intro; apply H1; clear H1.
    inversion H2; clear H2; intros; subst s'; auto.
    constructor.
  Qed.

End VSMap.


From CertiCoq.Plugin Require Import CertiCoq.

Require Import ZArith.
Require Import Psatz.

Module Type UInt63.
  Axiom t : Type.
  Axiom from_Z : Z -> t.
  Axiom to_Z : t -> Z.
  Axiom add : t -> t -> t.
  Axiom mul : t -> t -> t.
End UInt63.

Module FM <: UInt63.
  Definition t := {z : Z | 0 <= z < 2^63}%Z.
  Definition from_Z (z : Z) : t.
    exists (Z.modulo z (2^63)).
    apply Z_mod_lt.
    constructor.
  Defined.

  Definition to_Z (z : t) : Z := proj1_sig z.

  Lemma mod63_ok:
    forall z, (0 <= z mod (2^63) < 2^63)%Z.
  Proof.
    intro. apply Z.mod_pos_bound.
    apply Z.pow_pos_nonneg; lia.
   Qed.

  Definition add (x y: t) : t :=
  let '(exist _ xz x_pf) := x in
  let '(exist _ yz y_pf) := y in
  let z := ((xz + yz) mod (2^63))%Z in
  exist _ z (mod63_ok _).

  Definition mul (x y: t) : t :=
  let '(exist _ xz x_pf) := x in
  let '(exist _ yz y_pf) := y in
  let z := ((xz * yz) mod (2^63))%Z in
  exist _ z (mod63_ok _).

End FM.

Module C : UInt63.
  Axiom t : Type.
  Axiom from_Z : Z -> t.
  Axiom to_Z : t -> Z.
  Axiom add : t -> t -> t.
  Axiom mul : t -> t -> t.
End C.

Definition prog := C.to_Z (C.add (C.from_Z 3%Z) (C.from_Z 4%Z)).

CertiCoq Compile -cps prog
  Extract Constants [
    C.from_Z => "uint63_from_Z",
    C.to_Z => "uint63_to_Z" with tinfo,
    C.add => "uint63_add"
  ]
  Include [ "prims.h" ].
CertiCoq Generate Glue -file "glue" [ Z ].


Require Import Coq.Init.Peano.
Require Import Notations.
Require Import Coq.Lists.List.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.omega.Omega.
Require Import Coq.Arith.Le.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Numbers.NatInt.NZMul.
Require Import Coq.Structures.OrdersFacts.
Require Import Coq.ZArith.Znat.
Require Import Coq.QArith.QArith_base.
Require Import  Coq.QArith.QOrderedType.
Require Import QArith_base Equalities Orders OrdersTac.
Require Import Coq.Sorting.Permutation.
Require Import Wf.
Require Import Lexicographic_Product.
Require Import Qreduction.
Require Import Coq.Bool.Bool.
Require Import Inverse_Image.
Require Import Coq.Bool.Sumbool.
Require Import Coq.Sorting.Mergesort.
Import ListNotations.
(*Add LoadPath "STV".*)
Add LoadPath "/home/users/u5711205/Modular-STVCalculi/".
Require Import Parameters.
Require Import FrameBase.
Import FrameBase.

Inductive Cand := Alice | Bob | Charlie.
Module Instantiate.
Definition cand := Cand.
Definition cand_all := [Alice;Bob;Charlie].
Definition st := (1)%nat.
Definition quota := (8 # 3)%Q.
Definition ValidBallot (l: list cand) :=
    match l with
      [] => false
     |_ => true
    end.

Lemma cand_nodup : NoDup cand_all.
Proof.
 unfold cand_all.
  repeat
    apply NoDup_cons ||
    intro ||
    destruct H as [H1 | H] ||
    discriminate ||
    inversion H.
  apply NoDup_nil.
Defined.

Lemma cand_finite : forall c, In c cand_all.
Proof.
unfold cand_all; intro a; repeat induction a
                                   || (unfold In; tauto).
Defined.

Lemma cand_eq_dec : forall (c: cand) d, {c = d} + {c <> d}.
Proof.
 intros a b;
  repeat induction a;
    repeat (induction b) || (right; discriminate) ||(left; trivial).
Defined.

Lemma cand_in_dec : forall (c: cand) l, {In c l} + {~ In c l}.
Proof.
 intros.
 induction l.
 right.
 intro i.
 inversion i.
 destruct (cand_eq_dec a c) as [ p |q].
 left;left; auto.
 destruct IHl as [i | j].
 left; right; auto.
 right.
 intro k.
 apply j.
 destruct k as [k1 | k2].
 contradict q.
 auto.
 auto.
Defined.

(*
Definition st := (1)%nat.

Definition quota := (2 # 1)%Q.
*)

End Instantiate.

Module M := B Instantiate.


(**

Definition of the precategory of cones over a precategory C together with a proof that that
precategory is a univalent_category if C is ([is_univalent_CONE]).

Written by Benedikt Ahrens, following discussions with J. Gross, D. Grayson and V. Voevodsky
*)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.PartA.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Local Open Scope cat.

Section Cone.

  Variables J : precategory.
  Variable C : category.

Variable F : functor J C.

Definition ConeData : UU := ∑ a : C, ∏ j : J, a --> F j.

Definition ConeTop (a : ConeData) : C := pr1 a.
Definition ConeMor (a : ConeData) (j : J) : ConeTop a --> F j := (pr2 a) j.

Lemma eq_ConeData_eq (a b : ConeData) (p q : a = b) :
   base_paths _ _ p = base_paths _ _ q -> p = q.
Proof.
  intro H.
  apply (eq_equalities_between_pairs _ _ _ _ _ _ H).
  apply uip.
  apply (impred 2); intro j.
  apply C.
Defined.

Definition ConeProp (a : ConeData) :=
  ∏ j j' (f : j --> j'), ConeMor a j · #F f = ConeMor a j'.

Lemma isaprop_ConeProp (a : ConeData) : isaprop (ConeProp a).
Proof.
  repeat (apply impred; intro).
  apply C.
Qed.

Definition Cone := total2 (λ a : ConeData, ConeProp a).

Definition ConeData_from_Cone : Cone -> ConeData := λ a, pr1 a.

Lemma eq_Cone_eq (a b : Cone) (p q : a = b) :
   base_paths _ _ (base_paths _ _ p) =
   base_paths _ _ (base_paths _ _ q) -> p = q.
Proof.
  intro H.
  assert (H2 : base_paths _ _ p = base_paths _ _ q).
  apply eq_ConeData_eq.
  apply H.
  apply (eq_equalities_between_pairs _ _ _ _ _ _ H2).
  apply uip.
  apply isasetaprop.
  apply isaprop_ConeProp.
Defined.

Coercion ConeData_from_Cone : Cone >-> ConeData.

Definition ConeProp_from_Cone (a : Cone) : ConeProp a := pr2 a.
Coercion ConeProp_from_Cone : Cone >-> ConeProp.

Lemma cone_prop (a : Cone) :
  ∏ j j' (f : j --> j'), ConeMor a j · #F f = ConeMor a j'.
Proof.
  exact (pr2 a).
Qed.

Definition Cone_eq (a b : Cone) : pr1 a = pr1 b -> a = b.
Proof.
  intro H.
  apply (total2_paths_f H).
  apply proofirrelevance.
  apply isaprop_ConeProp.
Defined.

Definition Cone_Mor (M N : Cone) :=
  total2 (fun f : ConeTop M --> ConeTop N =>
        ∏ j : J, f · ConeMor N j = ConeMor M j).

Lemma isaset_Cone_Mor (M N : Cone) : isaset (Cone_Mor M N).
Proof.
  apply (isofhleveltotal2 2).
  apply C.
  intros.
  apply hlevelntosn.
  apply impred.
  intros.
  apply C.
Qed.

Definition ConeConnect {M N : Cone} (f : Cone_Mor M N) :
    ConeTop M --> ConeTop N := pr1 f.

Lemma Cone_Mor_eq (M N : Cone) (f g : Cone_Mor M N) :
   ConeConnect f = ConeConnect g -> f = g.
Proof.
  intro H.
  apply (total2_paths_f H).
  apply proofirrelevance.
  apply impred; intro; apply C.
Qed.

Lemma cone_mor_prop M N (f : Cone_Mor M N) :
    ∏ j : J, ConeConnect f · ConeMor N j = ConeMor M j.
Proof.
  exact (pr2 f).
Qed.

Definition Cone_id (A : Cone) : Cone_Mor A A.
Proof.
  exists (identity _).
  intros; apply id_left.
Defined.

Definition Cone_comp (A B D : Cone) (f : Cone_Mor A B)
        (g : Cone_Mor B D) : Cone_Mor A D.
Proof.
  exists (ConeConnect f · ConeConnect g).
  intro j.
  (* make this proof opaque *)
  rewrite <- assoc.
  rewrite cone_mor_prop.
  rewrite cone_mor_prop.
  apply idpath.
Defined.

Definition Cone_precategory_ob_mor : precategory_ob_mor :=
   make_precategory_ob_mor Cone
   (λ a b, Cone_Mor a b).

Definition Cone_precategory_data : precategory_data.
Proof.
  exists Cone_precategory_ob_mor.
  exists Cone_id.
  exact Cone_comp.
Defined.

Lemma is_precategory_Cone : is_precategory Cone_precategory_data.
Proof.
  repeat split; simpl.

  intros;
  apply Cone_Mor_eq;
  simpl; apply id_left.

  intros;
  apply Cone_Mor_eq;
  simpl; apply id_right.

  intros;
  apply Cone_Mor_eq;
  simpl; apply assoc.

  intros;
  apply Cone_Mor_eq;
  simpl; apply assoc'.
Defined.

Definition CONEpre : precategory := tpair _ _ is_precategory_Cone.

Lemma has_homsets_CONEpre : has_homsets CONEpre.
Proof.
  intros x y.
  apply isaset_Cone_Mor.
Qed.

Definition CONE : category := CONEpre ,, has_homsets_CONEpre.

(* this should not need the pr1 before f *)

Definition iso_projects_from_CONE (a b : CONE) (f : z_iso a b) :
  is_z_isomorphism (ConeConnect (pr1 f)).
Proof.
  set (T:=z_iso_inv_after_z_iso f).
  set (T':=z_iso_after_z_iso_inv f).
  exists (ConeConnect (inv_from_z_iso f)).
  split; simpl.
  - apply (base_paths _ _ T).
  - apply (base_paths _ _ T').
Defined.

Definition ConeConnectIso {a b : CONE} (f : z_iso a b) :
   z_iso (ConeTop (pr1 a)) (ConeTop (pr1 b)) :=
 tpair _ _ (iso_projects_from_CONE a b f).

Lemma ConeConnectIso_identity_iso (a : CONE) :
   ConeConnectIso (identity_z_iso a) = identity_z_iso _ .
Proof.
  apply z_iso_eq. apply idpath.
Qed.

Lemma ConeConnectIso_inj (a b : CONE) (f g : z_iso a b) :
   ConeConnectIso f = ConeConnectIso g -> f = g.
Proof.
  intro H.
  apply z_iso_eq; simpl in *.
  apply Cone_Mor_eq.
  apply (base_paths _ _ H).
Qed.

Lemma inv_from_iso_ConeConnectIso (a b : CONE) (f : z_iso a b):
  pr1 (inv_from_z_iso f) = inv_from_z_iso (ConeConnectIso f).
Proof.
  apply idpath.
Defined.

End Cone.

Arguments CONE [J C].
Arguments ConeConnect [J C].

Section CONE_category.

Variable J : precategory.
Variable C : category.
Variable F : functor J C.
Hypothesis is_cat_C : is_univalent C.

Definition isotoid_CONE_pr1 (a b : CONE F) : z_iso a b -> pr1 a = pr1 b.
Proof.
  intro f.
  apply (total2_paths_f (isotoid _ is_cat_C (ConeConnectIso _ _ _ f))).
  intermediate_path ((λ c : J,
     idtoiso (!isotoid C is_cat_C (ConeConnectIso _ _ _ f))· pr2 (pr1 a) c)).
  apply transportf_isotoid_dep'.
  apply funextsec.
  intro t.
  intermediate_path (idtoiso (isotoid C is_cat_C (z_iso_inv_from_z_iso (ConeConnectIso _ _ _ f)))·
       pr2 (pr1 a) t).
  apply cancel_postcomposition.
  apply maponpaths. apply maponpaths.
  apply inv_isotoid.
  intermediate_path (z_iso_inv_from_z_iso (ConeConnectIso _ _ _ f)· pr2 (pr1 a) t).
  apply cancel_postcomposition.
  set (H := idtoiso_isotoid _ is_cat_C _ _ (z_iso_inv_from_z_iso (ConeConnectIso _ _ _ f))).
  simpl in *.
  apply (base_paths _ _ H).
  simpl.
  set (T':= inv_from_z_iso f).
  set (T:=pr2 (inv_from_z_iso f) t).
  simpl in *.
  rewrite <- inv_from_iso_ConeConnectIso.
  apply T.
Defined.

Definition isotoid_CONE {a b : CONE F} : z_iso a b -> a = b.
Proof.
  intro f.
  apply Cone_eq.
  apply (isotoid_CONE_pr1 _ _ f).
Defined.

Lemma eq_CONE_pr1 (M N : CONE F) (p q : M = N) : base_paths _ _ p = base_paths _ _ q -> p = q.
Proof.
  intro H.
  simpl in *.
  apply (eq_equalities_between_pairs _ _ _ _ _ _ H).
  apply proofirrelevancecontr.
  apply isaprop_ConeProp.
Defined.

Lemma base_paths_isotoid_CONE (M : CONE F):
base_paths (pr1 M) (pr1 M)
      (base_paths M M (isotoid_CONE (identity_z_iso M))) =
    base_paths (pr1 M) (pr1 M) (idpath (pr1 M)).
Proof.
  intermediate_path (base_paths (pr1 M) (pr1 M) (isotoid_CONE_pr1 M M (identity_z_iso M))).
  unfold Cone_eq.
  apply maponpaths.
  apply base_total2_paths.
  intermediate_path (isotoid C is_cat_C (ConeConnectIso _ _ _ (identity_z_iso M))).
  unfold isotoid_CONE_pr1.
  apply base_total2_paths.
  intermediate_path (isotoid C is_cat_C (identity_z_iso (ConeTop _ _ _ (pr1 M)))).
  apply maponpaths, ConeConnectIso_identity_iso.
  apply isotoid_identity_iso.
Defined.

Lemma isotoid_CONE_idtoiso (M N : CONE F) : ∏ p : M = N, isotoid_CONE (idtoiso p) = p.
Proof.
  intro p.
  induction p.
  apply eq_Cone_eq.
  apply base_paths_isotoid_CONE.
Qed.

Lemma ConeConnect_idtoiso (M N : CONE F) (p : M = N):
  ConeConnect _ _ _ (pr1 (idtoiso p)) = idtoiso ((base_paths _ _ (base_paths _ _  p))).
Proof.
  destruct p.
  apply idpath.
Qed.

Lemma idtoiso_isotoid_CONE (M N : CONE F) : ∏ f : z_iso M N, idtoiso (isotoid_CONE f) = f.
Proof.
  intro f.
  apply z_iso_eq.
  apply Cone_Mor_eq.
  etrans; [apply ConeConnect_idtoiso |].
  unfold isotoid_CONE.
  unfold Cone_eq.
  rewrite base_total2_paths.
  unfold isotoid_CONE_pr1.
  rewrite base_total2_paths.
  simpl.
  rewrite idtoiso_isotoid.
  apply idpath.
Qed.

Lemma is_univalent_CONE : is_univalent (CONE F).
Proof.
  intros a b.
  apply (isweq_iso _  (@isotoid_CONE a b)).
  apply isotoid_CONE_idtoiso.
  apply idtoiso_isotoid_CONE.
Defined.

End CONE_category.


Require Import Basic.

Inductive Result {A} := solution (a:A) | uninhabited.
Arguments Result _ : clear implicits.

Class Search `{Basic} := {
  search {A} : Space A -> Result A;
  searchSolution {A s} {a:A} : search s = solution a -> In ⟦ s ⟧ a;
  searchUninhabited {A s} : search s = uninhabited -> ⟦ s ⟧ = Empty_set A
}.


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

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

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

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

Fixpoint eqb (n m: natural) : bool :=
  match n, m with
    | Zero, Zero => true
    | Zero, Succ _ => false
    | Succ _, Zero => false
    | Succ n', Succ m' => eqb n' m'
  end.

  Fixpoint mem  (mem_arg1 : lst) (mem_arg0 : natural)
  := match mem_arg0, mem_arg1 with
    | x, Nil => false
    | x, Cons y z => orb (eqb x y) (mem z x)
    end.

Fixpoint less (less_arg0 : natural) (less_arg1 : natural) : bool
           := match less_arg0, less_arg1 with
              | x, Zero => false
              | Zero, Succ x => true
              | Succ x, Succ y => less x y
              end.

Fixpoint insort  (insort_arg1 : lst) (insort_arg0 : natural) : lst
           := match insort_arg1, insort_arg0 with
              |  Nil, i => Cons i Nil
              | Cons x y, i => if less i x then Cons i (Cons x y) else Cons x (insort y i)
              end.

Fixpoint sort (sort_arg0 : lst) : lst
           := match sort_arg0 with
              | Nil => Nil
              | Cons x y => insort (sort y) x
              end.

Theorem eqb_refl: forall n, eqb n n = true.
Proof.
  induction n; simpl.
  { assumption. }
  { reflexivity. }
Qed.

Theorem theorem0 : forall (x : natural) (y : natural) (z : lst), eq x y -> eq (mem (insort z y) x) true.
Proof.
  intros.
  induction z.
  { subst. simpl. destruct (less y n).
    { simpl. rewrite eqb_refl. simpl. reflexivity. }
    { simpl. rewrite IHz. apply Bool.orb_true_r. }
  }
  { simpl.  subst. lfind.  simpl.  reflexivity.  }
Admitted.


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

(*i $Id: Logic_Type.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** This module defines type constructors for types in [Type]
    ([Datatypes.v] and [Logic.v] defined them for types in [Set]) *)

Set Implicit Arguments.

Require Import Datatypes.
Require Export Logic.

(** Negation of a type in [Type] *)

Definition notT (A:Type) := A -> False.

(** Properties of [identity] *)

Section identity_is_a_congruence.

 Variables A B : Type.
 Variable f : A -> B.

 Variables x y z : A.

 Lemma identity_sym : identity x y -> identity y x.
 Proof.
  destruct 1; trivial.
 Defined.

 Lemma identity_trans : identity x y -> identity y z -> identity x z.
 Proof.
  destruct 2; trivial.
 Defined.

 Lemma identity_congr : identity x y -> identity (f x) (f y).
 Proof.
  destruct 1; trivial.
 Defined.

 Lemma not_identity_sym : notT (identity x y) -> notT (identity y x).
 Proof.
  red in |- *; intros H H'; apply H; destruct H'; trivial.
 Qed.

End identity_is_a_congruence.

Definition identity_ind_r :
  forall (A:Type) (a:A) (P:A -> Prop), P a -> forall y:A, identity y a -> P y.
 intros A x P H y H0; case identity_sym with (1 := H0); trivial.
Defined.

Definition identity_rec_r :
  forall (A:Type) (a:A) (P:A -> Set), P a -> forall y:A, identity y a -> P y.
 intros A x P H y H0; case identity_sym with (1 := H0); trivial.
Defined.

Definition identity_rect_r :
  forall (A:Type) (a:A) (P:A -> Type), P a -> forall y:A, identity y a -> P y.
 intros A x P H y H0; case identity_sym with (1 := H0); trivial.
Defined.

Hint Immediate identity_sym not_identity_sym: core v62.

Notation refl_id := identity_refl (only parsing).
Notation sym_id := identity_sym (only parsing).
Notation trans_id := identity_trans (only parsing).
Notation sym_not_id := not_identity_sym (only parsing).


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** Definitions of Vectors and functions to use them

   Author: Pierre Boutillier
   Institution: PPS, INRIA 12/2010
*)

(**
Names should be "caml name in list.ml" if exists and order of arguments
have to be the same. complain if you see mistakes ... *)

Require Import Arith_base.
Require Vectors.Fin.
Open Local Scope nat_scope.

(**
A vector is a list of size n whose elements belong to a set A. *)

Inductive t A : nat -> Type :=
  |nil : t A 0
  |cons : forall (h:A) (n:nat), t A n -> t A (S n).

Local Notation "[]" := (nil _).
Local Notation "h :: t" := (cons _ h _ t) (at level 60, right associativity).

Section SCHEMES.

(** An induction scheme for non-empty vectors *)

Definition rectS {A} (P:forall {n}, t A (S n) -> Type)
 (bas: forall a: A, P (a :: []))
 (rect: forall a {n} (v: t A (S n)), P v -> P (a :: v)) :=
 fix rectS_fix {n} (v: t A (S n)) : P v :=
 match v with
 |nil => @id
 |cons a 0 v =>
   match v as vnn in t _ nn
       return
         match nn as nnn return t A nnn -> Type with
         |0 => fun vm => P (a :: vm)
         |S _ => fun _ => ID
         end vnn
     with
     |nil => bas a
     |_ :: _ => @id
     end
 |cons a (S nn') v => rect a v (rectS_fix v)
 end.

(** An induction scheme for 2 vectors of same length *)
Definition rect2 {A B} (P:forall {n}, t A n -> t B n -> Type)
  (bas : P [] []) (rect : forall {n v1 v2}, P v1 v2 ->
    forall a b, P (a :: v1) (b :: v2)) :=
fix rect2_fix {n} (v1:t A n):
  forall v2 : t B n, P v1 v2 :=
match v1 as v1' in t _ n1
  return forall v2 : t B n1, P v1' v2 with
  |[] => fun v2 =>
     match v2 with
       |[] => bas
       |_ :: _ => @id
     end
  |h1 :: t1 => fun v2 =>
    match v2 as v2' in t _ n2
      return match n2 as n2'
        return t B n2' -> Type with
        |0 => fun _ => @ID
        |S n' => fun v2 => forall t1' : t A n',
          P (h1 :: t1') v2
        end v2' with
      |[] => @id
      |h2 :: t2 => fun t1' =>
        rect (rect2_fix t1' t2) h1 h2
    end t1
end.

(** A vector of length [0] is [nil] *)
Definition case0 {A} (P:t A 0 -> Type) (H:P (nil A)) v:P v :=
match v with
  |[] => H
end.

(** A vector of length [S _] is [cons] *)
Definition caseS {A} (P : forall n, t A (S n) -> Type)
  (H : forall h {n} t, @P n (h :: t)) {n} v : P n v :=
match v with
  |[] => @id (* Why needed ? *)
  |h :: t => H h t
end.
End SCHEMES.

Section BASES.
(** The first element of a non empty vector *)
Definition hd {A} {n} (v:t A (S n)) := Eval cbv delta beta in
(caseS (fun n v => A) (fun h n t => h) v).

(** The last element of an non empty vector *)
Definition last {A} {n} (v : t A (S n)) := Eval cbv delta in
(rectS (fun _ _ => A) (fun a => a) (fun _ _ _ H => H) v).

(** Build a vector of n{^ th} [a] *)
Fixpoint const {A} (a:A) (n:nat) :=
  match n return t A n with
  | O => nil A
  | S n => a :: (const a n)
  end.

(** The [p]{^ th} element of a vector of length [m].

Computational behavior of this function should be the same as
ocaml function. *)
Fixpoint nth {A} {m} (v' : t A m) (p : Fin.t m) {struct p} : A :=
match p in Fin.t m' return t A m' -> A with
 |Fin.F1 q => fun v => caseS (fun n v' => A) (fun h n t => h) v
 |Fin.FS q p' => fun v => (caseS (fun n v' => Fin.t n -> A)
   (fun h n t p0 => nth t p0) v) p'
end v'.

(** An equivalent definition of [nth]. *)
Definition nth_order {A} {n} (v: t A n) {p} (H: p < n) :=
(nth v (Fin.of_nat_lt H)).

(** Put [a] at the p{^ th} place of [v] *)
Fixpoint replace {A n} (v : t A n) (p: Fin.t n) (a : A) {struct p}: t A n :=
  match p in Fin.t j return t A j -> t A j with
  |Fin.F1 k => fun v': t A (S k) => caseS (fun n _ => t A (S n)) (fun h _ t => a :: t) v'
  |Fin.FS k p' => fun v': t A (S k) =>
    (caseS (fun n _ => Fin.t n -> t A (S n)) (fun h _ t p2 => h :: (replace t p2 a)) v') p'
  end v.

(** Version of replace with [lt] *)
Definition replace_order {A n} (v: t A n) {p} (H: p < n) :=
replace v (Fin.of_nat_lt H).

(** Remove the first element of a non empty vector *)
Definition tl {A} {n} (v:t A (S n)) := Eval cbv delta beta in
(caseS (fun n v => t A n) (fun h n t => t) v).

(** Remove last element of a non-empty vector *)
Definition shiftout {A} {n:nat} (v:t A (S n)) : t A n :=
Eval cbv delta beta in (rectS (fun n _ => t A n) (fun a => [])
  (fun h _ _ H => h :: H) v).

(** Add an element at the end of a vector *)
Fixpoint shiftin {A} {n:nat} (a : A) (v:t A n) : t A (S n) :=
match v with
  |[] => a :: []
  |h :: t => h :: (shiftin a t)
end.

(** Copy last element of a vector *)
Definition shiftrepeat {A} {n} (v:t A (S n)) : t A (S (S n)) :=
Eval cbv delta beta in (rectS (fun n _ => t A (S (S n)))
  (fun h =>  h :: h :: []) (fun h _ _ H => h :: H) v).

(** Remove [p] last elements of a vector *)
Lemma trunc : forall {A} {n} (p:nat), n > p -> t A n
  -> t A (n - p).
Proof.
  induction p as [| p f]; intros H v.
  rewrite <- minus_n_O.
  exact v.

  apply shiftout.

  rewrite minus_Sn_m.
  apply f.
  auto with *.
  exact v.
  auto with *.
Defined.

(** Concatenation of two vectors *)
Fixpoint append {A}{n}{p} (v:t A n) (w:t A p):t A (n+p) :=
  match v with
  | [] => w
  | a :: v' => a :: (append v' w)
  end.

Infix "++" := append.

(** Two definitions of the tail recursive function that appends two lists but
reverses the first one *)

(** This one has the exact expected computational behavior *)
Fixpoint rev_append_tail {A n p} (v : t A n) (w: t A p)
  : t A (tail_plus n p) :=
  match v with
  | [] => w
  | a :: v' => rev_append_tail v' (a :: w)
  end.

(** This one has a better type *)
Definition rev_append {A n p} (v: t A n) (w: t A p)
  :t A (n + p) :=
eq_rect _ (fun n => t A n) (rev_append_tail v w) _
  (eq_sym _ _ _ (plus_tail_plus n p)).

(** rev [a₁ ; a₂ ; .. ; an] is [an ; a{n-1} ; .. ; a₁]

Caution : There is a lot of rewrite garbage in this definition *)
Definition rev {A n} (v : t A n) : t A n :=
 eq_rect _ (fun n => t A n) (rev_append v [])
   _ (eq_sym _ _ _ (plus_n_O _)).

End BASES.
Local Notation "v [@ p ]" := (nth v p) (at level 1).

Section ITERATORS.
(** * Here are special non dependent useful instantiation of induction
schemes *)

(** Uniform application on the arguments of the vector *)
Definition map {A} {B} (f : A -> B) : forall {n} (v:t A n), t B n :=
  fix map_fix {n} (v : t A n) : t B n := match v with
  | [] => []
  | a :: v' => (f a) :: (map_fix v')
  end.

(** map2 g [x1 .. xn] [y1 .. yn] = [(g x1 y1) .. (g xn yn)] *)
Definition map2 {A B C} (g:A -> B -> C) {n} (v1:t A n) (v2:t B n)
  : t C n :=
Eval cbv delta beta in rect2 (fun n _ _ => t C n) (nil C)
  (fun _ _ _ H a b => (g a b) :: H) v1 v2.

(** fold_left f b [x1 .. xn] = f .. (f (f b x1) x2) .. xn *)
Definition fold_left {A B:Type} (f:B->A->B): forall (b:B) {n} (v:t A n), B :=
  fix fold_left_fix (b:B) {n} (v : t A n) : B := match v with
    | [] => b
    | a :: w => (fold_left_fix (f b a) w)
  end.

(** fold_right f [x1 .. xn] b = f x1 (f x2 .. (f xn b) .. ) *)
Definition fold_right {A B : Type} (f : A->B->B) :=
  fix fold_right_fix {n} (v : t A n) (b:B)
  {struct v} : B :=
  match v with
    | [] => b
    | a :: w => f a (fold_right_fix w b)
  end.

(** fold_right2 g [x1 .. xn] [y1 .. yn] c = g x1 y1 (g x2 y2 .. (g xn yn c) .. ) *)
Definition fold_right2 {A B C} (g:A -> B -> C -> C) {n} (v:t A n)
  (w : t B n) (c:C) : C :=
Eval cbv delta beta in rect2 (fun _ _ _ => C) c
  (fun _ _ _ H a b => g a b H) v w.

(** fold_left2 f b [x1 .. xn] [y1 .. yn] = g .. (g (g a x1 y1) x2 y2) .. xn yn *)
Definition fold_left2 {A B C: Type} (f : A -> B -> C -> A) :=
fix fold_left2_fix (a : A) {n} (v : t B n) : t C n -> A :=
match v in t _ n0 return t C n0 -> A with
  |[] => fun w => match w in t _ n1
    return match n1 with |0 => A |S _ => @ID end with
    |[] => a
    |_ :: _ => @id end
  |cons vh vn vt => fun w => match w in t _ n1
    return match n1 with |0 => @ID |S n => t B n -> A end with
    |[] => @id
    |wh :: wt => fun vt' => fold_left2_fix (f a vh wh) vt' wt end vt
end.

End ITERATORS.

Section SCANNING.
Inductive Forall {A} (P: A -> Prop): forall {n} (v: t A n), Prop :=
 |Forall_nil: Forall P []
 |Forall_cons {n} x (v: t A n): P x -> Forall P v -> Forall P (x::v).
Hint Constructors Forall.

Inductive Exists {A} (P:A->Prop): forall {n}, t A n -> Prop :=
 |Exists_cons_hd {m} x (v: t A m): P x -> Exists P (x::v)
 |Exists_cons_tl {m} x (v: t A m): Exists P v -> Exists P (x::v).
Hint Constructors Exists.

Inductive In {A} (a:A): forall {n}, t A n -> Prop :=
 |In_cons_hd {m} (v: t A m): In a (a::v)
 |In_cons_tl {m} x (v: t A m): In a v -> In a (x::v).
Hint Constructors In.

Inductive Forall2 {A B} (P:A->B->Prop): forall {n}, t A n -> t B n -> Prop :=
 |Forall2_nil: Forall2 P [] []
 |Forall2_cons {m} x1 x2 (v1:t A m) v2: P x1 x2 -> Forall2 P v1 v2 ->
    Forall2 P (x1::v1) (x2::v2).
Hint Constructors Forall2.

Inductive Exists2 {A B} (P:A->B->Prop): forall {n}, t A n -> t B n -> Prop :=
 |Exists2_cons_hd {m} x1 x2 (v1: t A m) (v2: t B m): P x1 x2 -> Exists2 P (x1::v1) (x2::v2)
 |Exists2_cons_tl {m} x1 x2 (v1:t A m) v2: Exists2 P v1 v2 -> Exists2 P (x1::v1) (x2::v2).
Hint Constructors Exists2.

End SCANNING.

Section VECTORLIST.
(** * vector <=> list functions *)

Fixpoint of_list {A} (l : list A) : t A (length l) :=
match l as l' return t A (length l') with
  |Datatypes.nil => []
  |(h :: tail)%list => (h :: (of_list tail))
end.

Definition to_list {A}{n} (v : t A n) : list A :=
Eval cbv delta beta in fold_right (fun h H => Datatypes.cons h H) v Datatypes.nil.
End VECTORLIST.

Module VectorNotations.
Notation "[]" := [] : vector_scope.
Notation "h :: t" := (h :: t) (at level 60, right associativity)
  : vector_scope.

Notation "v [@ p ]" := (nth v p) (at level 1, format "v [@ p ]") : vector_scope.

Open Scope vector_scope.
End VectorNotations.


From Undecidability.L.Tactics Require Import LTactics.
From Undecidability.L Require Import Functions.EqBool.

From Undecidability.L.Datatypes Require Export List.List_enc LBool LOptions LNat.

Section Fix_X.
  Variable (X:Type).
  Context {intX : encodable X}.

  Fixpoint inb eqb (x:X) (A: list X) :=
    match A with
      nil => false
    | a::A' => orb (eqb a x) (inb eqb x A')
    end.

  Variable X_eqb : X -> X -> bool.
  Hypothesis X_eqb_spec : (forall (x y:X), Bool.reflect (x=y) (X_eqb x y)).

  Global Instance term_inb: computable inb.
  Proof.
    extract.
  Defined. (*because other extract*)

End Fix_X.

Section list_eqb.

  Variable X : Type.
  Variable eqb : X -> X -> bool.
  Variable spec : forall x y, reflect (x = y) (eqb x y).

  Fixpoint list_eqb A B :=
    match A,B with
    | nil,nil => true
    | a::A',b::B' => eqb a b && list_eqb A' B'
    | _,_ => false
    end.

  Lemma list_eqb_spec A B : reflect (A = B) (list_eqb A B).
  Proof using spec.
    revert B; induction A; intros; destruct B; cbn in *; try now econstructor.
    destruct (spec a x), (IHA B); cbn; econstructor; congruence.
  Qed.

End list_eqb.

Section int.

  Context {X : Type}.
  Context {HX : encodable X}.

  Global Instance term_list_eqb : computable (list_eqb (X:=X)).
  Proof.
    extract.
  Qed.

  Global Instance eqbList f `{eqbClass (X:=X) f}:
    eqbClass (list_eqb f).
  Proof.
    intros ? ?. eapply list_eqb_spec. all:eauto using eqb_spec.
  Qed.
  Import EqBool.
  Global Instance eqbComp_List `{eqbComp X (R:=HX)}:
    eqbComp (list X).
  Proof.
    constructor. unfold list_eqb.
    extract.
  Qed.
End int.


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

(*********************************************************************)
(** * List permutations as a composition of adjacent transpositions  *)
(*********************************************************************)

(* Adapted in May 2006 by Jean-Marc Notin from initial contents by
   Laurent Théry (Huffmann contribution, October 2003) *)

Require Import List Setoid.

Set Implicit Arguments.

Local Notation "[ ]" := nil.
Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..).

Section Permutation.

Variable A:Type.

Inductive Permutation : list A -> list A -> Prop :=
| perm_nil: Permutation [] []
| perm_skip x l l' : Permutation l l' -> Permutation (x::l) (x::l')
| perm_swap x y l : Permutation (y::x::l) (x::y::l)
| perm_trans l l' l'' : Permutation l l' -> Permutation l' l'' -> Permutation l l''.

Local Hint Constructors Permutation.

(** Some facts about [Permutation] *)

Theorem Permutation_nil : forall (l : list A), Permutation [] l -> l = [].
Proof.
  intros l HF.
  remember (@nil A) as m in HF.
  induction HF; discriminate || auto.
Qed.

Theorem Permutation_nil_cons : forall (l : list A) (x : A), ~ Permutation nil (x::l).
Proof.
  intros l x HF.
  apply Permutation_nil in HF; discriminate.
Qed.

(** Permutation over lists is a equivalence relation *)

Theorem Permutation_refl : forall l : list A, Permutation l l.
Proof.
  induction l; constructor. exact IHl.
Qed.

Theorem Permutation_sym : forall l l' : list A, Permutation l l' -> Permutation l' l.
Proof.
  intros l l' Hperm; induction Hperm; auto.
  apply perm_trans with (l':=l'); assumption.
Qed.

Theorem Permutation_trans : forall l l' l'' : list A, Permutation l l' -> Permutation l' l'' -> Permutation l l''.
Proof.
  exact perm_trans.
Qed.

End Permutation.

Hint Resolve Permutation_refl perm_nil perm_skip.

(* These hints do not reduce the size of the problem to solve and they
   must be used with care to avoid combinatoric explosions *)

Local Hint Resolve perm_swap perm_trans.
Local Hint Resolve Permutation_sym Permutation_trans.

(* This provides reflexivity, symmetry and transitivity and rewriting
   on morphims to come *)

Instance Permutation_Equivalence A : Equivalence (@Permutation A) | 10 := {
  Equivalence_Reflexive := @Permutation_refl A ;
  Equivalence_Symmetric := @Permutation_sym A ;
  Equivalence_Transitive := @Permutation_trans A }.

Add Parametric Morphism A (a:A) : (cons a)
  with signature @Permutation A ==> @Permutation A
  as Permutation_cons.
Proof.
  auto using perm_skip.
Qed.

Section Permutation_properties.

Variable A:Type.

Implicit Types a b : A.
Implicit Types l m : list A.

(** Compatibility with others operations on lists *)

Theorem Permutation_in : forall (l l' : list A) (x : A), Permutation l l' -> In x l -> In x l'.
Proof.
  intros l l' x Hperm; induction Hperm; simpl; tauto.
Qed.

Lemma Permutation_app_tail : forall (l l' tl : list A), Permutation l l' -> Permutation (l++tl) (l'++tl).
Proof.
  intros l l' tl Hperm; induction Hperm as [|x l l'|x y l|l l' l'']; simpl; auto.
  eapply Permutation_trans with (l':=l'++tl); trivial.
Qed.

Lemma Permutation_app_head : forall (l tl tl' : list A), Permutation tl tl' -> Permutation (l++tl) (l++tl').
Proof.
  intros l tl tl' Hperm; induction l; [trivial | repeat rewrite <- app_comm_cons; constructor; assumption].
Qed.

Theorem Permutation_app : forall (l m l' m' : list A), Permutation l l' -> Permutation m m' -> Permutation (l++m) (l'++m').
Proof.
  intros l m l' m' Hpermll' Hpermmm'; induction Hpermll' as [|x l l'|x y l|l l' l'']; repeat rewrite <- app_comm_cons; auto.
  apply Permutation_trans with (l' := (x :: y :: l ++ m));
	[idtac | repeat rewrite app_comm_cons; apply Permutation_app_head]; trivial.
  apply Permutation_trans with (l' := (l' ++ m')); try assumption.
  apply Permutation_app_tail; assumption.
Qed.

Add Parametric Morphism : (@app A)
  with signature @Permutation A ==> @Permutation A ==> @Permutation A
  as Permutation_app'.
  auto using Permutation_app.
Qed.

Lemma Permutation_add_inside : forall a (l l' tl tl' : list A),
  Permutation l l' -> Permutation tl tl' ->
  Permutation (l ++ a :: tl) (l' ++ a :: tl').
Proof.
  intros; apply Permutation_app; auto.
Qed.

Lemma Permutation_cons_append : forall (l : list A) x,
  Permutation (x :: l) (l ++ x :: nil).
Proof. induction l; intros; auto. simpl. rewrite <- IHl; auto. Qed.
Local Hint Resolve Permutation_cons_append.

Theorem Permutation_app_comm : forall (l l' : list A),
  Permutation (l ++ l') (l' ++ l).
Proof.
  induction l as [|x l]; simpl; intro l'.
  rewrite app_nil_r; trivial. rewrite IHl.
  rewrite app_comm_cons, Permutation_cons_append.
  now rewrite <- app_assoc.
Qed.
Local Hint Resolve Permutation_app_comm.

Theorem Permutation_cons_app : forall (l l1 l2:list A) a,
  Permutation l (l1 ++ l2) -> Permutation (a :: l) (l1 ++ a :: l2).
Proof. intros l l1 l2 a H. rewrite H.
  rewrite app_comm_cons, Permutation_cons_append.
  now rewrite <- app_assoc.
Qed.
Local Hint Resolve Permutation_cons_app.

Theorem Permutation_middle : forall (l1 l2:list A) a,
  Permutation (a :: l1 ++ l2) (l1 ++ a :: l2).
Proof.
  auto.
Qed.
Local Hint Resolve Permutation_middle.

Theorem Permutation_rev : forall (l : list A), Permutation l (rev l).
Proof.
  induction l as [| x l]; simpl; trivial. now rewrite IHl at 1.
Qed.

Add Parametric Morphism : (@rev A)
  with signature @Permutation A ==> @Permutation A as Permutation_rev'.
Proof. intros. now do 2 rewrite <- Permutation_rev. Qed.

Theorem Permutation_length : forall (l l' : list A), Permutation l l' -> length l = length l'.
Proof.
  intros l l' Hperm; induction Hperm; simpl; auto. now transitivity (length l').
Qed.

Theorem Permutation_ind_bis :
 forall P : list A -> list A -> Prop,
   P [] [] ->
   (forall x l l', Permutation l l' -> P l l' -> P (x :: l) (x :: l')) ->
   (forall x y l l', Permutation l l' -> P l l' -> P (y :: x :: l) (x :: y :: l')) ->
   (forall l l' l'', Permutation l l' -> P l l' -> Permutation l' l'' -> P l' l'' -> P l l'') ->
   forall l l', Permutation l l' -> P l l'.
Proof.
  intros P Hnil Hskip Hswap Htrans.
  induction 1; auto.
  apply Htrans with (x::y::l); auto.
  apply Hswap; auto.
  induction l; auto.
  apply Hskip; auto.
  apply Hskip; auto.
  induction l; auto.
  eauto.
Qed.

Ltac break_list l x l' H :=
  destruct l as [|x l']; simpl in *;
  injection H; intros; subst; clear H.

Theorem Permutation_nil_app_cons : forall (l l' : list A) (x : A), ~ Permutation nil (l++x::l').
Proof.
  intros l l' x HF.
  apply Permutation_nil in HF. destruct l; discriminate.
Qed.

Theorem Permutation_app_inv : forall (l1 l2 l3 l4:list A) a,
  Permutation (l1++a::l2) (l3++a::l4) -> Permutation (l1++l2) (l3 ++ l4).
Proof.
  set (P l l' :=
         forall a l1 l2 l3 l4, l=l1++a::l2 -> l'=l3++a::l4 -> Permutation (l1++l2) (l3++l4)).
  cut (forall l l', Permutation l l' -> P l l').
  intros; apply (H _ _ H0 a); auto.
  intros; apply (Permutation_ind_bis P); unfold P; clear P; try clear H l l'; simpl; auto.
(* nil *)
  intros; destruct l1; simpl in *; discriminate.
  (* skip *)
  intros x l l' H IH; intros.
  break_list l1 b l1' H0; break_list l3 c l3' H1.
  auto.
  now rewrite H.
  now rewrite <- H.
  now rewrite (IH a _ _ _ _ eq_refl eq_refl).
  (* contradict *)
  intros x y l l' Hp IH; intros.
  break_list l1 b l1' H; break_list l3 c l3' H0.
  auto.
  break_list l3' b l3'' H.
  auto.
  rewrite <- Permutation_middle in Hp. now rewrite Hp.
  break_list l1' c l1'' H1.
  auto.
  rewrite <- Permutation_middle in Hp. now rewrite Hp.
  break_list l3' d l3'' H; break_list l1' e l1'' H1.
  auto.
  rewrite <- Permutation_middle in Hp. rewrite perm_swap. auto.
  rewrite perm_swap, Permutation_middle. auto.
  now rewrite perm_swap, (IH a _ _ _ _ eq_refl eq_refl).
  (*trans*)
  intros.
  destruct (In_split a l') as (l'1,(l'2,H6)).
  apply (Permutation_in a H).
  subst l.
  apply in_or_app; right; red; auto.
  apply perm_trans with (l'1++l'2).
  apply (H0 _ _ _ _ _ H3 H6).
  apply (H2 _ _ _ _ _ H6 H4).
Qed.

Theorem Permutation_cons_inv :
   forall l l' a, Permutation (a::l) (a::l') -> Permutation l l'.
Proof.
  intros; exact (Permutation_app_inv [] l [] l' a H).
Qed.

Theorem Permutation_cons_app_inv :
   forall l l1 l2 a, Permutation (a :: l) (l1 ++ a :: l2) -> Permutation l (l1 ++ l2).
Proof.
  intros; exact (Permutation_app_inv [] l l1 l2 a H).
Qed.

Theorem Permutation_app_inv_l :
    forall l l1 l2, Permutation (l ++ l1) (l ++ l2) -> Permutation l1 l2.
Proof.
  induction l; simpl; auto.
  intros.
  apply IHl.
  apply Permutation_cons_inv with a; auto.
Qed.

Theorem Permutation_app_inv_r :
   forall l l1 l2, Permutation (l1 ++ l) (l2 ++ l) -> Permutation l1 l2.
Proof.
  induction l.
  intros l1 l2; do 2 rewrite app_nil_r; auto.
  intros.
  apply IHl.
  apply Permutation_app_inv with a; auto.
Qed.

Lemma Permutation_length_1_inv: forall a l, Permutation [a] l -> l = [a].
Proof.
  intros a l H; remember [a] as m in H.
  induction H; try (injection Heqm as -> ->; clear Heqm);
    discriminate || auto.
  apply Permutation_nil in H as ->; trivial.
Qed.

Lemma Permutation_length_1: forall a b, Permutation [a] [b] -> a = b.
Proof.
  intros a b H.
  apply Permutation_length_1_inv in H; injection H as ->; trivial.
Qed.

Lemma Permutation_length_2_inv :
  forall a1 a2 l, Permutation [a1;a2] l -> l = [a1;a2] \/ l = [a2;a1].
Proof.
  intros a1 a2 l H; remember [a1;a2] as m in H.
  revert a1 a2 Heqm.
  induction H; intros; try (injection Heqm; intros; subst; clear Heqm);
    discriminate || (try tauto).
  apply Permutation_length_1_inv in H as ->; left; auto.
  apply IHPermutation1 in Heqm as [H1|H1]; apply IHPermutation2 in H1 as ();
    auto.
Qed.

Lemma Permutation_length_2 :
  forall a1 a2 b1 b2, Permutation [a1;a2] [b1;b2] ->
    a1 = b1 /\ a2 = b2 \/ a1 = b2 /\ a2 = b1.
Proof.
  intros a1 b1 a2 b2 H.
  apply Permutation_length_2_inv in H as [H|H]; injection H as -> ->; auto.
Qed.

Lemma NoDup_Permutation : forall l l',
  NoDup l -> NoDup l' -> (forall x:A, In x l <-> In x l') -> Permutation l l'.
Proof.
  induction l.
  destruct l'; simpl; intros.
  apply perm_nil.
  destruct (H1 a) as (_,H2); destruct H2; auto.
  intros.
  destruct (In_split a l') as (l'1,(l'2,H2)).
  destruct (H1 a) as (H2,H3); simpl in *; auto.
  subst l'.
  apply Permutation_cons_app.
  inversion_clear H.
  apply IHl; auto.
  apply NoDup_remove_1 with a; auto.
  intro x; split; intros.
  assert (In x (l'1++a::l'2)).
   destruct (H1 x); simpl in *; auto.
  apply in_or_app; destruct (in_app_or _ _ _ H4); auto.
  destruct H5; auto.
  subst x; destruct H2; auto.
  assert (In x (l'1++a::l'2)).
    apply in_or_app; destruct (in_app_or _ _ _ H); simpl; auto.
  destruct (H1 x) as (_,H5); destruct H5; auto.
  subst x.
  destruct (NoDup_remove_2 _ _ _ H0 H).
Qed.

End Permutation_properties.

Section Permutation_map.

Variable A B : Type.
Variable f : A -> B.

Add Parametric Morphism : (map f)
  with signature (@Permutation A) ==> (@Permutation B) as Permutation_map_aux.
Proof.
  induction 1; simpl; eauto using Permutation.
Qed.

Lemma Permutation_map :
  forall l l', Permutation l l' -> Permutation (map f l) (map f l').
Proof.
  exact Permutation_map_aux_Proper.
Qed.

End Permutation_map.

(* begin hide *)
Notation Permutation_app_swap := Permutation_app_comm (only parsing).
(* end hide *)


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(* Certified Undecidability of Intuitionistic Linear Logic via Binary Stack Machines and Minsky Machines. Yannick Forster and Dominique Larchey-Wendling. CPP '19. http://uds-psl.github.io/ill-undecidability/ *)

From Coq Require Import List Lia.

From Undecidability.Shared.Libs.DLW
  Require Import Vec.pos Vec.vec Code.sss.

Require Import Undecidability.MinskyMachines.MM.

Set Implicit Arguments.

(** * Halting problem for Minsky machines MM_HALTING  *)

(* * Minsky Machines (MM)

    A Minsky machine has n registers and there are just two instructions

    1/ INC x   : increment register x by 1
    2/ DEC x k : decrement register x by 1 if x > 0
                 or jump to k if x = 0

  *)

(* * Alternate Minsky Machines (MMA) such that two counters are enough for undec

    Minsky machine has n registers and there are just two instructions

    1/ INC x   : increment register x by 1
    2/ DEC x k : if x > 0 then decrement register x by 1 and jump to k

    If no jump occurs, then implicitly, the jump is to the next instruction

    We show that they simulated FRACTRAN
  *)
(*
Inductive mm_instr (X : Set) : Set :=
  | mm_inc : X -> mm_instr X
  | mm_dec : X -> nat -> mm_instr X
  .
 *)
Notation INC := mm_inc.
Notation DEC := mm_dec.

(* ** Semantics for MM, restricted to X = pos n for some n *)

Section Minsky_Machine.

  Variable (n : nat).

  Definition mm_state := (nat*vec nat n)%type.

  Local Notation "e #> x" := (vec_pos e x).
  Local Notation "e [ v / x ]" := (vec_change e x v).

  (* Minsky machine small step semantics *)

  Inductive mm_sss : mm_instr (pos n) -> mm_state -> mm_state -> Prop :=
    | in_mm_sss_inc   : forall i x v,                   INC x   // (i,v) -1> (1+i,v[(S (v#>x))/x])
    | in_mm_sss_dec_0 : forall i x k v,   v#>x = O   -> DEC x k // (i,v) -1> (k,v)
    | in_mm_sss_dec_1 : forall i x k v u, v#>x = S u -> DEC x k // (i,v) -1> (1+i,v[u/x])
  where "i // s -1> t" := (mm_sss i s t).

End Minsky_Machine.

Lemma eval_to_sss_compute n i (P : list (mm_instr (pos n))) c (v : vec nat n) c' v' :
  eval (i, P) (c, v) (c', v') -> sss_compute (@mm_sss _) (i,P) (c, v) (c', v').
Proof.
  generalize (i, P) as iP.
  generalize (c, v) as cv.
  generalize (c', v') as c'v'. clear.
  induction 1 as [ i P c v
                 | i P c v j c' v' H1 H2 H [k IH]
                 | i P c v j c1 c' v' l H1 H2 H3 H [k IH]
                 | i P c v j c1 c' v' H1 H2 H3 H [k IH] ].
  - exists 0. econstructor.
  - exists (1 + k).
    eapply nth_error_split in H2 as (l1 & l2 & -> & Hl).
    repeat econstructor.
    + f_equal. lia.
    + replace (1 + c) with (c + 1) by lia.
      now replace (S (vec_pos v j)) with (vec_pos v j + 1) by lia.
  - exists (1 + k).
    eapply nth_error_split in H2 as (l1 & l2 & -> & Hl).
    econstructor; [ | eauto].
    repeat econstructor.
    + f_equal. lia.
    + replace (c + 1) with (1 + c) by lia. econstructor. eauto.
  - exists (1 + k).
    eapply nth_error_split in H2 as (l1 & l2 & -> & Hl).
    econstructor; [ | eauto].
    repeat econstructor.
    * f_equal. lia.
    * eauto.
Qed.

Lemma eval_to_sss_out_code n i (P : list (mm_instr (pos n))) c (v : vec nat n) c' v' :
  eval (i, P) (c, v) (c', v') -> subcode.out_code (fst (c', v')) (i, P).
Proof.
  generalize (i, P) as iP.
  generalize (c, v) as cv.
  generalize (c', v') as c'v'. clear.
  induction 1 as [ i P c v
                 | i P c v j b c' v' H1 H2 H
                 | i P c v j c1 c2 c' v' l H1 H2 H3 H
                 | i P c v j c1 c2 c' v' H1 H2 H3 H ]; cbn in *.
  all: lia.
Qed.

Lemma sss_output_to_eval n i (P : list (mm_instr (pos n))) c (v : vec nat n) c' v' :
  sss_output (@mm_sss _) (i,P) (c, v) (c', v') -> eval (i, P) (c, v) (c', v').
Proof.
  generalize (i, P) as iP.
  generalize (c, v) as cv.
  generalize (c', v') as c'v'. clear.
  intros ? ? ? [[k H1] H2].
  induction H1 as [cv | n0 st1 st2 (c', v') (k & l & i & r & d & -> & -> & HH) H IH] in * |- *.
  - destruct iP as (i, P), cv as (c, v);
      try destruct c'v' as (c', v').
    econstructor. cbn in *. lia.
  - revert IH H H2.
    inversion_clear HH as [ | | ]; subst; intros IH' HHH IH % IH'; clear IH'.
    + eapply eval_mm_inc; [ lia | | ].
      * rewrite nth_error_app2; [ | lia].
        now replace (k + length l - k - length l) with 0 by lia.
      * replace (k + length l + 1) with (1 + (k + length l)) by lia.
        now replace (vec_pos d x + 1) with (S (vec_pos d x)) by lia.
    + eapply eval_mm_dec_empty; [ lia | | eauto ..].
      rewrite nth_error_app2; [ | lia].
      now replace (k + length l - k - length l) with 0 by lia.
    + eapply eval_mm_dec_S; [ lia | | eauto ..].
      * rewrite nth_error_app2; [ | lia].
        now replace (k + length l - k - length l) with 0 by lia.
      * now replace (k + length l + 1) with (1 + (k + length l)) by lia.
Qed.

Theorem eval_iff n i (P : list (mm_instr (pos n))) c (v : vec nat n) c' v' :
  eval (i, P) (c, v) (c', v') <-> sss_output (@mm_sss _) (i,P) (c, v) (c', v').
Proof.
  split.
  - intros H. split.
    + now eapply eval_to_sss_compute.
    + eapply eval_to_sss_out_code. eassumption.
  - intros H. now eapply sss_output_to_eval.
Qed.

Section MM_problems.

  Notation "P // s ~~> t" := (sss_output (@mm_sss _) P s t).
  Notation "P // s ↓" := (sss_terminates (@mm_sss _) P s).

  Definition MM_PROBLEM := { n : nat & { P : list (mm_instr (pos n)) & vec nat n } }.

  Definition MM_HALTS_ON_ZERO (P : MM_PROBLEM) :=
    match P with existT _ n (existT _ P v) => (1,P) // (1,v) ~~> (0,vec_zero) end.

  Definition MM_HALTING (P : MM_PROBLEM) :=
    match P with existT _ n (existT _ P v) => (1, P) // (1, v) ↓ end.

  Definition Halt_MM (P : MM_PROBLEM) :=
    match P with existT _ n (existT _ P v) => exists c v', eval (1, P) (1, v) (c, v') end.

  Definition MM_2_PROBLEM := { P : list (mm_instr (pos 2)) & vec nat 2 }.

  Definition MM_2_HALTING (P : MM_2_PROBLEM) :=
    match P with existT _ P v => (1, P) // (1, v) ↓ end.

End MM_problems.

Lemma Halt_MM_iff P :
  Halt_MM P <-> MM_HALTING P.
Proof.
  destruct P as (n & P & v); cbn.
  split.
  - intros (c' & v' & H % eval_iff). eexists. eauto.
  - intros [(c', v') H % eval_iff]. eauto.
Qed.


(*
 * Walkthrough of lifting for Section 4
 *)

Add LoadPath "coq/examples".
Require Import Vector.
Require Import List.
Require Import Ornamental.Ornaments.
Require Import Search. (* our ornament *)

(*
 * Our arguments to cons are swapped from Coq's in the paper
 *)
Definition vect_rect {T : Type} p f_nil f_cons (n : nat) (v : vector T n) :=
  Vector.t_rect T p
    f_nil
    (fun (t : T) (n : nat) (v : vector T n) (IH : p n v) =>
      f_cons n t v IH)
    n
    v.

(*
 * Note we have this nice equality between eliminators:
 *)
Example lift_elim_correct:
  forall {T : Type} p_A f_nil f_cons n (v : vector T n),
    list_rect p_A
      f_nil
      f_cons
      (forget (existT _ n v))
    =
    vect_rect (fun n v => p_A (forget (existT _ n v)))
      f_nil
      (fun n t v IH => f_cons t (forget (existT _ n v)) IH)
      n
      v.
Proof.
  induction v.
  - reflexivity.
  - simpl. f_equal. apply IHv.
Qed.

(*
 * So, what does it look like when we lift an eliminator
 * application?
 *)
Definition proof T p_A f_nil f_cons (l : list T) :=
  list_rect p_A
    f_nil
    f_cons
    l.

Lift list vector in proof as proofV_p.
Print proofV_p.

(* --- Lifting constructors --- *)

(*
 * In the base case, we just normalize:
 *)
Lift list vector in @nil as nilV_p.
Print nilV_p.

(*
 * As mentioned in the implementation section,
 * refolding happens here to deal with constants.
 * But the equalities should be clear that way:
 *)
Lift list vector in @cons as consV_p.
Print consV_p.

(* --- Lifting --- *)

(*
 * Let's lift a few simple list functions, now
 *)

Preprocess hd as hd'.
Lift list vector in hd' as hdV_p.
Print hdV_p.

Preprocess tl as tl'.
Lift list vector in tl' as tlV_p.
Print tlV_p.

Preprocess remove as remove'.
Lift list vector in remove' as removeV_p.
Print removeV_p.


Require Export Axioms.

(*** NO AXIOMS AFTER THIS POINT ******************)

Require Import EqdepFacts.

(* From EqdepTh we obtain inj_pair and inj_pairT2 without
   use of excluded middle:
 *)
Module EqdepElim: EqdepElimination.
Lemma eq_rect_eq :
    forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p),
      x = eq_rect p Q x p h.
Proof.
  intros.
  apply Streicher_K__eq_rect_eq.
  apply UIP_refl__Streicher_K.
  unfold UIP_refl_.
  intros.
  apply proof_irr.
Qed.
End EqdepElim.

Module EqdepTh := EqdepTheory EqdepElim.
Export EqdepTh.

(* Generalize the extensionality tactic from the Coq library. *)
Tactic Notation "extensionality" :=
 let x := fresh "x" in extensionality x.

Tactic Notation "extensionality" ident(x) ident(y) :=
    extensionality x; extensionality y.

Tactic Notation "extensionality" ident(x) ident(y) ident(z):=
    extensionality x; extensionality y z.

Lemma imp_ext: forall (A A' B B' : Prop), (A=A') -> (A -> (B=B')) -> ((A->B)=(A'->B')).
Proof.
intros.
subst A'.
apply prop_ext; split; intros; auto.
rewrite <- H0; auto. rewrite H0; auto.
Qed.

Lemma exists_ext: forall (A: Type) F G, (forall x: A, F x = G x) -> (Logic.ex F = Logic.ex G).
Proof.
intros.
apply prop_ext; split; intro; destruct H0; exists x.
rewrite <- H; auto.
rewrite H; auto.
Qed.

Lemma and_ext: forall A B C D, A=B -> C=D -> (A /\ C) = (B /\ D).
Proof.
intros.
rewrite H; rewrite H0; auto.
Qed.

Lemma and_ext': forall (A: Prop) B C D, A=B -> (A -> (C=D)) -> (A /\ C) = (B /\ D).
Proof.
intros.
subst B.
apply prop_ext.
intuition; subst; auto.
Qed.

Lemma or_ext: forall A B C D, A=B -> C=D -> (A \/ C) = (B \/ D).
Proof.
intros.
rewrite H; rewrite H0; auto.
Qed.

Lemma forall_ext: forall (A: Type) (F: A -> Prop) G, (forall x:A, F x = G x) -> (forall x, F x) = (forall x, G x).
Proof.
intros.
apply prop_ext. split; intros. rewrite <- H; auto. rewrite H; auto.
Qed.

Lemma existT_ext:
  forall (A: Type) (P: A -> Prop) (x y: A) (Hx: P x) (Hy: P y),
     x = y -> existT _ x Hx = existT _ y Hy.
Proof.
intros.
subst.
rewrite (proof_irr Hx Hy); auto.
Qed.

Lemma exist_ext:
  forall (A: Type) (P: A -> Prop) (x y: A) (Hx: P x) (Hy: P y),
     x = y -> exist _ x Hx = exist _ y Hy.
Proof.
intros.
subst.
rewrite (proof_irr Hx Hy); auto.
Qed.


Require Import BinPos.
Require Import ZArith.
Require Import FMapPositive.
Require Import String.

Require Import Setoid.

Set Implicit Arguments.

(** * Maps

  Define maps, by making constructors for
  empty and singleton maps and map union,
  and defining a suitable equivalence relation *)

(* TODO:
   define a well-formedness predicate saying keys are not repeated,
   augment language definition with a proof that all evaluation
   steps preserve it
 *)

Inductive Map (Key Elt : Type) : Type :=
| mapEmpty
| mapItem (k : Key) (v : Elt)
| mapJoin (m1 m2 : Map Key Elt)
.
Arguments mapEmpty [Key Elt].

(** ** Map notations
 *)
Delimit Scope Map with Map.
Bind Scope Map with Map.

Open Scope Map.

Infix "|->" := mapItem (at level 50, no associativity) : Map.
Infix ":*" := mapJoin (at level 60, right associativity) : Map.

(** ** Map equivalence

  Map equivalence is axiomatized by
  identitiy, associativity, commutativity, and congruence of union,
  closed under reflexivity, symmetry, and transitivity.
 *)
Inductive MapEquiv {K E : Type} : Map K E -> Map K E -> Prop :=
| equivUnit : forall m, MapEquiv (m :* mapEmpty) m
| equivComm : forall m1 m2, MapEquiv (m1 :* m2) (m2 :* m1)
| equivAssoc : forall m1 m2 m3, MapEquiv ((m1 :* m2) :* m3) (m1 :* (m2 :* m3))

| equivJoin : forall l1 r1 l2 r2, MapEquiv l1 l2 -> MapEquiv r1 r2 -> MapEquiv (l1 :* r1) (l2 :* r2)
| equivTrans : forall m1 m2 m3, MapEquiv m1 m2 -> MapEquiv m2 m3 -> MapEquiv m1 m3
| equivSym : forall m1 m2, MapEquiv m1 m2 -> MapEquiv m2 m1
| equivRefl : forall m, MapEquiv m m
.

Infix "~=" := MapEquiv (at level 70, no associativity) : Map.

(** Registering map equivalence as an equivalence relation *)

Add Parametric Relation (K E : Type) : (Map K E) MapEquiv
  reflexivity proved by equivRefl
  symmetry proved by equivSym
  transitivity proved by equivTrans
  as map_equiv_rel.

Add Parametric Morphism K E : (@mapJoin K E) with
  signature MapEquiv ==> MapEquiv ==> MapEquiv as map_join_mor.
Proof. auto using equivJoin. Qed.

(** Some derived equivalences *)

(** A unit law with the unit on the left *)
Lemma equivUnitL : forall {K V} (m : Map K V), MapEquiv (mapEmpty :* m) m.
intros. rewrite equivComm. apply equivUnit.
Qed.

(** Switching the first two maps in a right-associated sequence *)
Lemma equivComAssoc : forall {K V} (m1 m2 m3 : Map K V), m1 :* m2 :* m3 ~= m2 :* m1 :* m3.
intros. rewrite <- equivAssoc, (equivComm m1 m2), equivAssoc. reflexivity. Qed.

(** ** Map Equality Tactic

  The map equality tactic [equate_maps] tries to solve map equations involving
  at most one map-typed evar.

  The general approach is to put both maps into a standard form,
  as a sequence of singleton items and residual map-typed variables,
  then cancel entries between the sides, until everything that's
  left can be absorbed into the evar (or we're stuck with
  a residual equation).
 *)

(** *** Finding items in a map
    These are the tactics for commuting target items to the
    head of a map *)

(** Specializing congruence for the find tactic *)
Definition equivJoinL {K V} (r : Map K V) l1 l2 pfl : l1 :* r ~= l2 :* r :=
  equivJoin pfl (equivRefl r).
Definition equivJoinR {K V} (l : Map K V) r1 r2 pfr :  l :* r1 ~= l :* r2 :=
  equivJoin (equivRefl l) pfr.

(** Find an entry with key [x] in map [map].
    If found, it calls the continuation tactic [k] on
    an equality of the form [map ~= x |-> _ :* _],
    otherwise it simply fails.
 *)
Ltac find x map k :=
  match map with
    | (x |-> _) => let pf := constr:(equivSym (equivUnit map)) in k pf
    | (x |-> _ :* _) => let pf := constr:(equivRefl map) in k pf
    | (?mapl :* (x |-> ?v)) => let pf := constr:(equivComm mapl (x |-> v)) in k pf
    | ?mapl :* ?mapr =>
           find x mapl ltac:(fun pfl => let pf := constr:(equivTrans (equivJoinL mapr pfl)
                                                                   (equivAssoc (x |-> _) _ mapr))
                                        in k pf)
        || find x mapr ltac:(fun pfr => let pf := constr:(equivTrans (equivJoinR mapl pfr)
                                                                   (equivComAssoc mapl (x |-> _) _))
                                        in k pf)
  end.

(** Find an entire map [submap] appearing exactly all or part of a map [map].
    It's expeted that [submap] be a variable, this tactic makes no attempt
    to search search up to map equality if [submap] is a more complicated
    map expression.
    If found, calls the continuation tactic [k] on an equality of the form
    [map ~= submap :* _]
 *)
Ltac find_submap map submap k :=
  match map with
    | submap => let pf := constr:(equivSym (equivUnit map)) in k pf
    | (submap :* _) => let pf := constr:(equivRefl map) in k pf
    | (?mapl :* submap) => let pf := constr:(equivComm mapl submap) in k pf
    | ?mapl :* ?mapr =>
           find_submap mapl submap

                       ltac:(fun pfl => let pf := constr:(equivTrans (equivJoinL mapr pfl)
                                                                   (equivAssoc submap _ mapr))
                                        in k pf)
        || find_submap mapr submap
                       ltac:(fun pfr => let pf := constr:(equivTrans (equivJoinR mapl pfr)
                                                                   (equivComAssoc mapl submap _))
                                        in k pf)
  end.

(** *** Map well-formedness predicates

    [check_maps] checks that each map is right associated,
    has items before map-typed ordinary variables before
    evars, and that there is at most one evar, on the right side.

    [is_map_exp] is also used elsewhere, and succeeds only if the given
    map is neither an evar nor any of the map constructors.
 *)

Ltac is_map_exp m :=
  match m with
    | (_ |-> _) => fail 1
    | (_ :* _) => fail 1
    | mapEmpty => fail 1
    | _ => try (is_evar m;fail 2)
  end.
Ltac check_left_var_map m :=
  match m with
    | (?l :* ?m') => is_map_exp l;check_left_var_map m'
    | _ => is_map_exp m
  end.
Ltac check_left_map m :=
  match m with
    | mapEmpty => idtac
    | _ |-> _ => idtac
    | (_ |-> _ :* ?m') => check_left_map m'
    | _ => check_left_var_map m
  end.
Ltac check_right_var_map m :=
  match m with
    | (?l :* ?m') => is_map_exp l;check_right_var_map m'
    | _ => first [is_evar m | is_map_exp m]
  end.
Ltac check_right_map m :=
  match m with
    | mapEmpty => idtac
    | _ |-> _ => idtac
    | (_ |-> _ :* ?m') => check_right_map m'
    | _ => check_right_var_map m
  end.
Ltac check_maps :=
  match goal with
    | [|- ?l ~= ?r] => check_left_map l;check_right_map r
  end.

(** *** Preparing maps.

    An equation is prepared by using any map equation hypotheses to
    expand variables in the maps involed,
    then using map equalities to remove empties, right-associate
    unions, and move singleton items to the front.

    This tactic isn't entirely careful about locating evars,
    but they are checked afterwards.
 *)
Ltac expand_map m :=
  match m with
    | ?l :* ?r => expand_map l; expand_map r
    | ?v => is_var v;
           match goal with
             | [H : v ~= ?m |- _] => rewrite !H;clear H;expand_map m
             | [H : ?m ~= v |- _] => rewrite <- !H;clear H;expand_map m
           end
    | _ => idtac
  end.

(* maybe do by reflection? *)
Ltac prepare_maps :=
  match goal with
    | [|- ?l ~= ?r] => expand_map l;expand_map r
  end;
  repeat
    match goal with
        | [|- context [mapEmpty :* ?m]] => rewrite (equivUnitL m)
        | [|- context [?m :* mapEmpty]] => rewrite (equivUnit m)
        | [|- context [(?m1 :* ?m2) :* ?m3]] => rewrite (equivAssoc m1 m2 m3)
  end;
  (* switch if left side has a map evar *)
  match goal with
    | [|- ?l ~= ?r] =>
        match l with
          | context [?v] => is_evar v;
            match type of v with Map _ _  => symmetry end
        end
    | _ => idtac
  end;
  (* Now commute items to the front things *)
  repeat match goal with
           | [|- context [?m1 :* ?m2 :* ?m3]] =>
             match m2 with _ |-> _ => is_map_exp m1; rewrite (equivComAssoc m1 m2 m3)
             end
           | [|- context [?m1 :* ?m2]] =>
             match m2 with _ |-> _ => is_map_exp m1; rewrite (equivComm m1 m2)
             end
         end
  .

Lemma equivJoinItemR {K} (k : K) {V} (v1 v2 : V) r1 r2 :
  v1 = v2 -> r1 ~= r2 -> (k |-> v1 :* r1) ~= (k |-> v2 :* r2).
intros. subst. auto using equivJoinR.
Qed.

Lemma equivItem {K} (k : K) {V} (v1 v2 : V) :
  v1 = v2 -> k |-> v1 ~= k |-> v2.
intros. subst. reflexivity.
Qed.

(* *** Solving the map equation

   After preparing the maps, the left side has no evars, so the non-evar
   part of the RHS must appear as a submap of the left side.

   This tactic proceeds item by item, finding and cancelling identical
   items between sides.
   If this ends with an equation between a map and an evar it is
   instantiated.

   If the equation isn't completely solved, the tactic still succeeds,
   leaving the reduced equation.
 *)
Ltac find_items :=
  match goal with
  | [|- MapEquiv ?map (?x |-> _ :* _)] => find x map
      ltac:(fun pf => apply (equivTrans pf);apply equivJoinItemR)
  | [|- MapEquiv ?map (?submap :* _)] => find_submap map submap
      ltac:(fun pf => apply (equivTrans pf);apply equivJoinItemR)
  | [|- ?x |-> ?v1 ~= ?x |-> ?v2] => apply equivItem
  end;[try reflexivity..|try find_items].

Ltac equate_maps :=
  prepare_maps;
  first[check_maps| fail 1];
  (* Find item or submap when rhs has a join *)
  find_items;
  (* If we're not failing, the rhs is down to a join-free map.
     Because the lhs is still in prepared form, reflexivity
     can handle all the remaining solvable possibilities.
    *)
  [..|try reflexivity].