(** * Sequential integer programs *)

From Coq Require Import ZArith.
From mathcomp Require Import ssreflect ssrbool seq eqtype.
From Common Require Import ZAriths Env Var Store.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Delimit Scope iprog_scope with iprog.

Local Open Scope iprog_scope.

(** Syntax *)

Section Syntax.

  Variable E : SEnv.t.
  Notation pvar := (SEnv.pvar E).

  Inductive unop : Set :=
  | INeg.

  Inductive binop : Set :=
  | IAdd
  | ISub
  | IMul
  | IDiv
  | IMod.

  Inductive exp : Set :=
  | IVar : pvar -> exp
  | IConst : Z -> exp
  | IUnop : unop -> exp -> exp
  | IBinop : binop -> exp -> exp -> exp.

  Inductive instr : Set :=
  | IAssign : pvar -> exp -> instr.

  Definition program : Set := seq instr.

End Syntax.

(** Semantics *)

Notation value := Z.

Module State.

  Definition t : Type := VStore.t value.

  Definition empty : t := VStore.empty value.

  Definition acc (x : var) (s : t) : option value :=
    VStore.acc x s.

  Definition upd (x : var) (v : value) (s : t) : t :=
    VStore.upd x v s.

  Definition unset (x : var) (s : t) : t :=
    VStore.unset x s.

  Lemma acc_upd_eq :
    forall x y v (s : t),
      x == y ->
      acc x (upd y v s) = Some v.
  Proof.
    exact: VStore.acc_upd_eq.
  Qed.

  Lemma acc_upd_neq :
    forall x y v (s : t),
      x != y ->
      acc x (upd y v s) = acc x s.
  Proof.
    exact: VStore.acc_upd_neq.
  Qed.

  Lemma acc_empty :
    forall x, acc x empty = None.
  Proof.
    exact: VStore.acc_empty.
  Qed.

  Lemma acc_unset_eq :
    forall x y s,
      x == y ->
      acc x (unset y s) = None.
  Proof.
    exact: VStore.acc_unset_eq.
  Qed.

  Lemma acc_unset_neq :
    forall x y s,
      x != y ->
      acc x (unset y s) = acc x s.
  Proof.
    exact: VStore.acc_unset_neq.
  Qed.

  Definition Upd x v (s1 s2 : t) : Prop :=
    forall y, acc y s2 = acc y (upd x v s1).

  Definition Unset x (s1 s2 : t) : Prop :=
    forall y, acc y s2 = acc y (unset x s1).

  Lemma Upd_upd :
    forall x v s,
      Upd x v s (upd x v s).
  Proof.
    exact: VStore.Upd_upd.
  Qed.

  Lemma Unset_unset :
    forall x s,
      Unset x s (unset x s).
  Proof.
    exact: VStore.Unset_unset.
  Qed.

  Lemma acc_Upd_eq :
    forall x y v s1 s2,
      x == y ->
      Upd y v s1 s2 ->
      acc x s2 = Some v.
  Proof.
    exact: VStore.acc_Upd_eq.
  Qed.

  Lemma acc_Upd_neq :
    forall x y v s1 s2,
      x != y ->
      Upd y v s1 s2 ->
      acc x s2 = acc x s1.
  Proof.
    exact: VStore.acc_Upd_neq.
  Qed.

  Lemma acc_Unset_eq :
    forall x y s1 s2,
      x == y ->
      Unset y s1 s2 ->
      acc x s2 = None.
  Proof.
    exact: VStore.acc_Unset_eq.
  Qed.

  Lemma acc_Unset_neq :
    forall x y s1 s2,
      x != y ->
      Unset y s1 s2 ->
      acc x s2 = acc x s1.
  Proof.
    exact: VStore.acc_Unset_neq.
  Qed.

End State.

Section Semantics.

  Variable E : SEnv.t.
  Notation pvar_var := (SEnv.pvar_var).

  Definition eval_unop (op : unop) (v : value) : value :=
    match op with
    | INeg => (-v)%Z
    end.

  Definition eval_binop (op : binop) (v1 v2 : value) : value :=
    match op with
    | IAdd => (v1 + v2)%Z
    | ISub => (v1 - v2)%Z
    | IMul => (v1 * v2)%Z
    | IDiv => (v1 / v2)%Z
    | IMod => (v1 mod v2)%Z
    end.

  Inductive eval_exp : exp E -> value -> State.t -> Prop :=
  | EIVar :
      forall v n s,
        State.acc (pvar_var v) s = Some n ->
        eval_exp (IVar v) n s
  | EIConst : forall n s, eval_exp (IConst E n) n s
  | EIUnop :
      forall op e n m s,
        eval_exp e n s ->
        eval_unop op n = m ->
        eval_exp (IUnop op e) m s
  | EIBinop :
      forall op e1 e2 v1 v2 n s,
        eval_exp e1 v1 s ->
        eval_exp e2 v2 s ->
        eval_binop op v1 v2 = n ->
        eval_exp (IBinop op e1 e2) n s.

  Inductive eval_instr : State.t -> instr E -> State.t -> Prop :=
  | EIAssign :
      forall v e n s1 s2,
        eval_exp e n s1 ->
        State.Upd (pvar_var v) n s1 s2 ->
        eval_instr s1 (IAssign v e) s2.

  Inductive eval_program : State.t -> program E -> State.t -> Prop :=
  | EIEmpty : forall s, eval_program s nil s
  | EICons :
      forall hd tl s1 s2 s3,
        eval_instr s1 hd s2 ->
        eval_program s2 tl s3 ->
        eval_program s1 (hd::tl) s3.

  Lemma eval_ivar_unique v n m s :
    let e := IVar v in
    eval_exp e n s -> eval_exp e m s -> n == m.
  Proof.
    move=> e Hn Hm.
    inversion_clear Hn.
    inversion_clear Hm.
    move: H H0; case: (State.acc (pvar_var v) s).
    + move=> u [] Hun [] Hum.
      rewrite -Hun -Hum; exact: eqxx.
    + discriminate.
  Qed.

  Lemma eval_iconst_unique v n m s :
    let e := IConst E v in
    eval_exp e n s -> eval_exp e m s -> n == m.
  Proof.
    move=> e Hn Hm.
    have: (v = n /\ v = m).
    - split.
      + inversion_clear Hn.
        reflexivity.
      + inversion_clear Hm.
        reflexivity.
    - move=> [] Hvn Hvm; rewrite -Hvn -Hvm; exact: eqxx.
  Qed.

  Lemma eval_iunop_unique :
    forall (op : unop) (e : exp E),
      (forall (n m : value) (s : State.t),
          eval_exp e n s -> eval_exp e m s -> n == m) ->
      forall (n m : value) (s : State.t),
        eval_exp (IUnop op e) n s ->
        eval_exp (IUnop op e) m s ->
        n == m.
  Proof.
    move=> op e Hind n m s Hn Hm.
    inversion_clear Hn.
    inversion_clear Hm.
    move: (Hind _ _ _ H H1) => {H H1} H01.
    rewrite -H0 -H2 (eqP H01).
    exact: eqxx.
  Qed.

  Lemma eval_ibinop_unique :
    forall (op : binop) (e1 : exp E),
      (forall (n m : value) (s : State.t),
          eval_exp e1 n s -> eval_exp e1 m s -> n == m) ->
      forall e2 : exp E,
        (forall (n m : value) (s : State.t),
            eval_exp e2 n s -> eval_exp e2 m s -> n == m) ->
        forall (n m : value) (s : State.t),
          eval_exp (IBinop op e1 e2) n s ->
          eval_exp (IBinop op e1 e2) m s ->
          n == m.
  Proof.
    move=> op e1 Hind1 e2 Hind2 n m s Hn Hm.
    inversion_clear Hn.
    inversion_clear Hm.
    move: (Hind1 _ _ _ H H2) => {H H2} => H10.
    move: (Hind2 _ _ _ H0 H3) => {H0 H3} => H23.
    rewrite -H1 -H4 (eqP H10) (eqP H23).
    exact: eqxx.
  Qed.

  Lemma eval_exp_unique :
    forall e n m s, eval_exp e n s -> eval_exp e m s -> n == m.
  Proof.
    move=> e; elim: e.
    - exact: eval_ivar_unique.
    - exact: eval_iconst_unique.
    - exact: eval_iunop_unique.
    - exact: eval_ibinop_unique.
  Qed.

  Lemma eval_program_empty :
    forall (s1 s2 : State.t),
      eval_program s1 [::] s2 -> s1 = s2.
  Proof.
    move=> s1 s2 H; by inversion_clear H.
  Qed.

  Lemma eval_program_singleton :
    forall (i : instr E) (s1 s2 : State.t),
      eval_program s1 ([:: i]) s2 ->
      eval_instr s1 i s2.
  Proof.
    move=> i s1 s2 H; inversion_clear H.
    move: (eval_program_empty H1) => {H1} H1.
    rewrite -H1.
    exact: H0.
  Qed.

  Lemma eval_program_cons :
    forall (hd : instr E) (tl : program E) (s1 s2 : State.t),
      eval_program s1 (hd::tl) s2 ->
      exists s3 : State.t,
        eval_instr s1 hd s3 /\ eval_program s3 tl s2.
  Proof.
    move=> hd tl s1 s2 H.
    inversion_clear H.
    exists s3; split; assumption.
  Qed.

  Lemma eval_program_concat :
    forall (p1 p2 : program E) (s1 s2 s3 : State.t),
      eval_program s1 p1 s2 ->
      eval_program s2 p2 s3 ->
      eval_program s1 (p1 ++ p2) s3.
  Proof.
    move=> p1; elim: p1.
    - move=> p2 s1 s2 s3 He1 He2.
      move: (eval_program_empty He1) => {He1} He1.
      rewrite He1.
      exact: He2.
    - move=> hd tl H p2 s1 s2 s3 He1 He2.
      move: (eval_program_cons He1) => {He1} [s4 [He1 He4]].
      apply: (EICons He1).
      apply: (H _ _ _ _ He4).
      exact: He2.
  Qed.

  Lemma eval_program_split :
    forall (p1 p2 : program E) (s1 s2 : State.t),
      eval_program s1 (p1 ++ p2) s2 ->
      exists s3 : State.t,
        eval_program s1 p1 s3 /\ eval_program s3 p2 s2.
  Proof.
    move=> p1; elim: p1.
    - move=> p2 s1 s2 H1.
      exists s1; split.
      + exact: EIEmpty.
      + exact: H1.
    - move=> hd tl H p2 s1 s2 He1.
      move: (eval_program_cons He1) => {He1} [s3 [He13 He32]].
      move: (H _ _ _ He32) => {H} [s4 [He34 He42]].
      exists s4; split.
      + exact: (EICons He13 He34).
      + exact: He42.
  Qed.

End Semantics.

(** Specification *)

Section Specification.

  Variable E : SEnv.t.

  Inductive cop : Set :=
  | IEq
  | ILt
  | ILe
  | IGt
  | IGe.

  Inductive bexp : Set :=
  | IComp : cop -> exp E -> exp E -> bexp
  | INot : bexp -> bexp
  | IAnd : bexp -> bexp -> bexp
  | IOr : bexp -> bexp -> bexp.

  Definition eval_cop op (v1 v2 : value) : bool :=
    match op with
    | IEq => v1 == v2
    | ILt => (v1 <? v2)%Z
    | ILe => (v1 <=? v2)%Z
    | IGt => (v1 >? v2)%Z
    | IGe => (v1 >=? v2)%Z
    end.

  Inductive eval_bexp : bexp -> bool -> State.t -> Prop :=
  | EIComp :
      forall op e1 e2 n1 n2 s,
        eval_exp e1 n1 s ->
        eval_exp e2 n2 s ->
        eval_bexp (IComp op e1 e2) (eval_cop op n1 n2) s
  | EINot :
      forall e b s,
        eval_bexp e b s ->
        eval_bexp (INot e) (~~b) s
  | EIAnd :
      forall e1 e2 b1 b2 s,
        eval_bexp e1 b1 s ->
        eval_bexp e2 b2 s ->
        eval_bexp (IAnd e1 e2) (b1 && b2) s
  | EIOr :
      forall e1 e2 b1 b2 s,
        eval_bexp e1 b1 s ->
        eval_bexp e2 b2 s ->
        eval_bexp (IOr e1 e2) (b1 || b2) s.

  Definition valid (f : bexp) : Prop :=
    forall s : State.t, eval_bexp f true s.

  Definition entails (f g : bexp) : Prop :=
    forall s : State.t,
      eval_bexp f true s -> eval_bexp g true s.

  Definition spec (f : bexp) (p : program E) (g : bexp) : Prop :=
    forall s1 s2,
      eval_bexp f true s1 ->
      eval_program s1 p s2 ->
      eval_bexp g true s2.

  Definition counterexample (f : bexp) (p : program E) (g : bexp) (s : State.t) : Prop :=
    eval_bexp f true s /\
    exists s' : State.t, eval_program s p s' /\ eval_bexp g false s'.

  Lemma spec_empty :
    forall f g,
      spec f [::] g -> entails f g.
  Proof.
    move=> f g He s Hf.
    apply: (He s _ Hf).
    apply: EIEmpty.
  Qed.

  Lemma spec_strengthing :
    forall f g h p,
      entails f g -> spec g p h -> spec f p h.
  Proof.
    move=> f g h p Hfg Hgh s1 s2 Hf Hp.
    apply: (Hgh _ _ _ Hp).
    exact: (Hfg _ Hf).
  Qed.

  Lemma spec_weakening :
    forall f g h p,
      spec f p g -> entails g h -> spec f p h.
  Proof.
    move=> f g h p Hfg Hgh s1 s2 Hf Hp.
    apply: Hgh.
    exact: (Hfg _ _ Hf Hp).
  Qed.

  Lemma spec_cons :
    forall f g h hd tl,
      spec f [::hd] g -> spec g tl h ->
      spec f (hd::tl) h.
  Proof.
    move=> f g h hd tl Hhd Htl s1 s2 Hf Hp.
    inversion_clear Hp.
    apply: (Htl s3 _ _ H0).
    apply: (Hhd s1 _ Hf).
    apply: (EICons H).
    exact: EIEmpty.
  Qed.

End Specification.

Notation "s |= f" := (eval_bexp f true s) (at level 74, no associativity) : iprog_scope.
Notation "f ===> g" := (entails f g) (at level 82, no associativity) : iprog_scope.
Notation "{{ f }} p {{ g }}" := (spec f p g) (at level 82, no associativity) : iprog_scope.

(*
Fixpoint eval_exp E (e : exp E) (s : State.t) : value :=
  match e with
  | SVar v => State.acc (pvar_var v) s
  | SConst n => Some n
  | SUnop op e' => eval_unop op (eval_exp e' s)
  | SBinop op e1 e2 => eval_binop op (eval_exp e1 s) (eval_exp e2 s)
  end.

Definition eval_instr (i : instr) (s : State.t) : State.t :=
  match i with
  | SAssign v e => State.upd v (eval_exp e s) s
  end.

Fixpoint eval_program (p : program) (s : State.t) : State.t :=
  match p with
  | nil => s
  | hd::tl => eval_program tl (eval_instr hd s)
  end.
*)


Require Coq.Program.Tactics.
Require Import ssreflect ssrfun ssrbool.
From Groups Require Import groups module vectorspace.
Require Import Coq.Bool.Bool.
Require Import Field.
Require Import Field_theory.

Module Type EncryptionScheme.

 Parameter KGR : Set.

 Parameter PublicKey : Set.
 Parameter SecretKey : Set.

 Parameter Message : Set.
 Parameter Ciphertext : Set.
 Parameter Randomness : Set.

 Parameter keygen : KGR -> PublicKey*SecretKey.
 Parameter enc : PublicKey -> Message -> Randomness -> Ciphertext.
 Parameter dec : PublicKey -> SecretKey -> Ciphertext -> Message.
End EncryptionScheme.

Module Type DistributedDecryption (ES : EncryptionScheme).
 Import ES.

 Parameter SecretKeyShare : Set.
 Parameter AuxData : Set.

 Parameter DecryptionShare : Set.

 Parameter DR : Set.

 Parameter Deal : PublicKey -> SecretKey -> DR -> SecretKeyShare*SecretKeyShare*AuxData.
 Parameter Verify : PublicKey -> AuxData -> bool -> SecretKeyShare -> bool.
 Parameter Play : SecretKeyShare -> Ciphertext -> DecryptionShare.
 Parameter Reconstruct : Ciphertext -> DecryptionShare -> DecryptionShare -> Message.

 Axiom Correctness : forall (m: Message)(kgr : KGR)(r : Randomness)(dr : DR),
   let '(pk,sk) := keygen kgr in
   let c := enc pk m r in
   let '(sk0, sk1, aux) := Deal pk sk dr in
   Verify pk aux false sk0 = true /\ Verify pk aux true sk1 = true /\
  Reconstruct c (Play sk0 c) (Play sk1 c) = m.

 Axiom Integrity : forall (m: Message)(pk : PublicKey)(sk0 sk1 : SecretKeyShare)
   (aux : AuxData)(r : Randomness),
    let c := enc pk m r in
    Verify pk aux false sk0 = true ->
    Verify pk aux true sk1 = true ->
    Reconstruct c (Play sk0 c) (Play sk1 c) = m.

 Parameter DealSim : PublicKey -> DR -> bool -> SecretKeyShare*AuxData.
 Parameter PlaySim : PublicKey -> SecretKeyShare -> Ciphertext -> Message ->
   DecryptionShare.
 Parameter DealSimMap : PublicKey -> SecretKey -> DR -> bool -> DR.
 Parameter DealSimMapInv : PublicKey -> SecretKey -> DR -> bool -> DR.

 Axiom Simulatability : forall (kgr : KGR)(i : bool)(c : Ciphertext)(m : Message)(dr : DR),
    let '(pk,sk) := keygen kgr in
    dec pk sk c = m ->
    let '(sk0, sk1, aux) := Deal pk sk dr in
    if i then (sk1,aux) = DealSim pk (DealSimMap pk sk dr i) i /\
                              Play sk0 c = PlaySim pk sk1 c m
    else (sk0,aux) = DealSim pk (DealSimMap pk sk dr i) i /\ Play sk1 c =
      PlaySim pk sk0 c m.

 Axiom SimMapBijection : forall (kgr : KGR)(dr : DR)(i : bool),
    let '(pk,sk) := keygen kgr in
    DealSimMapInv pk sk (DealSimMap pk sk dr i) i = dr /\
          DealSimMap pk sk (DealSimMapInv pk sk dr i) i = dr.

End DistributedDecryption.

Module Type ElGamal (Group : GroupSig)(Field : FieldSig)(VS : VectorSpaceSig Group Field) <: EncryptionScheme.
  Import Field.
  Import Group.
  Import VS.

 Definition KGR := prod G F.

 Definition PublicKey := prod G G.
 Definition SecretKey := F.

 Definition Message := G.
 Definition Ciphertext := prod G G.
 Definition Randomness := F.

 Definition keygen (kgr : KGR) := ((kgr.1,kgr.1^kgr.2),kgr.2).
 Definition enc (pk : PublicKey)(m : Message)(r : Randomness) := (pk.1^r,pk.2^r o m).
 Definition dec (pk : PublicKey)(sk : SecretKey)(c : Ciphertext) := (c.2 o - c.1^sk).
End ElGamal.

Module DDElGamal (Group : GroupSig)(Field : FieldSig)(VS : VectorSpaceSig Group Field)
  (EG : ElGamal Group Field VS) <: DistributedDecryption EG.
  Import Group.
  Import Field.
  Import VS.
  Import EG.
  Module VSAL := VectorSpaceAddationalLemmas Group Field VS.
  Import VSAL.

  Definition SecretKeyShare := F.
  Definition AuxData := prod G G.
  Definition DecryptionShare := G.
  Definition DR := F.

  Definition Deal (pk : PublicKey)(sk : SecretKey)(dr : DR) :=
   (dr,sk-dr,(pk.1^dr,pk.1^(sk-dr))).

  Definition Verify (pk : PublicKey)(aux : AuxData)(l : bool)(sk : SecretKeyShare) :=
    Gbool_eq pk.2 (aux.1 o aux.2) &&
      if l then Gbool_eq aux.2 (pk.1^sk) else Gbool_eq aux.1 (pk.1^sk).
  Definition Play (sk : SecretKeyShare)(c : Ciphertext) := c.1^sk.
  Definition Reconstruct (c : Ciphertext)(ds0 : DecryptionShare)
    (ds1 : DecryptionShare) := c.2 o -(ds0 o ds1).

 Lemma Correctness : forall (m: Message)(kgr : KGR)(r : Randomness)(dr : DR),
   let '(pk,sk) := keygen kgr in
   let c := enc pk m r in
   let '(sk0, sk1, aux) := Deal pk sk dr in
   Verify pk aux false sk0 = true /\ Verify pk aux true sk1 = true /\
  Reconstruct c (Play sk0 c) (Play sk1 c) = m.
 Proof.
  pose Group.module_abegrp. intros. unfold Verify, Reconstruct, Play. split.
  simpl. apply andb_true_iff. split. apply bool_eq_corr. rewrite <- mod_dist_Fadd.
  apply f_equal.  field; auto. apply bool_eq_corr. trivial. split. simpl.
  apply andb_true_iff. split. apply bool_eq_corr. rewrite <- mod_dist_Fadd.
  apply f_equal. field; auto. apply bool_eq_corr. trivial.
  (* Reconstruct *) simpl.
  rewrite <- mod_dist_Fadd. replace (dr + (kgr.2 - dr)) with kgr.2.
  rewrite <- mod_dist_Fmul. rewrite <- mod_dist_FMul2. rewrite comm.
  rewrite dot_assoc. rewrite <- inv_left. rewrite one_left. trivial.
  field; auto.
 Qed.

 Lemma Integrity : forall (m: Message)(pk : PublicKey)(sk0 sk1 : SecretKeyShare)
   (aux : AuxData)(r : Randomness),
    let c := enc pk m r in
    Verify pk aux false sk0 = true ->
    Verify pk aux true sk1 = true ->
    Reconstruct c (Play sk0 c) (Play sk1 c) = m.
 Proof.
  pose Group.module_abegrp.
  intros. unfold Reconstruct, Play, Verify in *. simpl in *.
  apply andb_true_iff in H. apply andb_true_iff in H0. destruct H. destruct H0.
  apply bool_eq_corr in H2. apply bool_eq_corr in H0. apply bool_eq_corr in H1.
  do 2 rewrite <- mod_dist_Fmul. do 2 rewrite mod_dist_FMul2. rewrite <- mod_dist_Gdot.
  rewrite <- H1. rewrite <- H2. rewrite <- H0. rewrite comm.
  rewrite dot_assoc. rewrite <- inv_left. rewrite one_left. trivial.
 Qed.

 Definition DealSim (pk : PublicKey)(dr : DR)(l : bool) :=
  (dr,if l then (pk.2 o - pk.1^dr,pk.1^dr) else (pk.1^dr, pk.2 o - pk.1^dr)).
 Definition PlaySim (pk : PublicKey)(sk : SecretKeyShare)(c : Ciphertext)(m : Message)
     := c.2 o - (c.1^sk o m).
 Definition DealSimMap (pk : PublicKey)(sk : SecretKey)(dr : DR)(l : bool)
    := if l then sk-dr else dr.
 Definition DealSimMapInv (pk : PublicKey)(sk : SecretKey)(dr : DR)(l : bool) :=
    if l then sk-dr else dr.

 Lemma Simulatability : forall (kgr : KGR)(i : bool)(c : Ciphertext)(m : Message)(dr : DR),
    let '(pk,sk) := keygen kgr in
    dec pk sk c = m ->
    let '(sk0, sk1, aux) := Deal pk sk dr in
    if i then (sk1,aux) = DealSim pk (DealSimMap pk sk dr i) i /\
                              Play sk0 c = PlaySim pk sk1 c m
    else (sk0,aux) = DealSim pk (DealSimMap pk sk dr i) i /\
                              Play sk1 c = PlaySim pk sk0 c m.
 Proof.
  pose Group.module_abegrp.
  intros. simpl. intros. unfold DealSim, DealSimMap, Play, PlaySim. destruct i.
  (* left *)
  split. apply injective_projections; simpl. trivial. apply injective_projections;
  simpl. rewrite neg_eq. rewrite <- mod_dist_Fadd. apply f_equal. unfold DR in *.
  field; auto. trivial. unfold dec in H. rewrite <- H. pose inv_dist. symmetry in e.
  rewrite e. rewrite dot_assoc. rewrite comm. rewrite e. rewrite <- dob_neg.
  rewrite (comm (- c.2) (c.1 ^ kgr.2)). rewrite dot_assoc. rewrite comm.
  do 2 rewrite dot_assoc. rewrite neg_eq. rewrite <- mod_dist_Fadd. rewrite <- dot_assoc.
  rewrite <- inv_left. rewrite one_right. apply f_equal. unfold DR in *. field; auto.
  (* right *)
  split. apply injective_projections; simpl. trivial. apply injective_projections;
  simpl. trivial. rewrite neg_eq. rewrite <- mod_dist_Fadd. apply f_equal.
  unfold DR in *. field; auto. unfold dec in H. rewrite <- H. pose inv_dist.
  symmetry in e. rewrite e. rewrite dot_assoc. rewrite comm. rewrite e.
  rewrite <- dob_neg. rewrite (comm (- c.2) (c.1 ^ kgr.2)). rewrite dot_assoc.
  rewrite comm. do 2 rewrite dot_assoc. rewrite neg_eq. rewrite <- mod_dist_Fadd.
  rewrite <- dot_assoc. rewrite <- inv_left. rewrite one_right. apply f_equal.
  unfold DR in *. field; auto.
 Qed.

 Lemma SimMapBijection : forall (kgr : KGR)(dr : DR)(i : bool),
    let '(pk,sk) := keygen kgr in
    DealSimMapInv pk sk (DealSimMap pk sk dr i) i = dr /\
          DealSimMap pk sk (DealSimMapInv pk sk dr i) i = dr.
  Proof.
    intros. unfold DealSimMap, DealSimMapInv. simpl. destruct i; split; trivial.
    field; auto. field; auto.
  Qed.

End DDElGamal.


(***************************************************************************)
(*   This is part of FA_Completeness, it is distributed under the terms    *)
(*           of the GNU Lesser General Public License version 3            *)
(*                (see file LICENSE for more details)                      *)
(*                                                                         *)
(*           Copyright 2020-2022: Yaoshun Fu and Wensheng Yu.              *)
(***************************************************************************)

Require Import t6.
Require Export Seq.

Definition CauchySeq (a :Seq) := ∀ ε, ε > O ->
  ∃ N, ∀ m n, (IGT_N m N) -> (IGT_N n N) -> |(a m) - (a n)| < ε.

Inductive RelCauchy N (a :Seq) x y :Prop :=
  | RelCauchy_in : ILT_N x N -> y = |a x| -> RelCauchy N a x y.

Theorem CCT : ∀ a, (∃ ξ, Limit a ξ) <-> CauchySeq a.
Proof.
  split; try red; intros.
  - destruct H as [ξ H]; red in H. apply Pr_2a in H0.
    destruct (H _ H0) as [N H1]. exists N; intros.
    apply H1 in H2; apply H1 in H3.
    rewrite <- Theorem178, Theorem181 in H3.
    pose proof (Theorem189 H2 H3); Simpl_Rin H4.
    pose proof (Ab2 ((a m)- ξ) (ξ - (a n))).
    unfold Minus_R in H5; rewrite <- Theorem186 in H5; Simpl_Rin H5.
    eapply Theorem172; eauto.
  - destruct H with 1 as [N H0]; simpl; auto.
    assert (∀ n, IGT_N n N` -> |a n| < |a N`| + 1); intros.
    { pose proof (Theorem18 N 1); Simpl_Nin H2.
      eapply Theorem15 in H1; eauto.
      pose proof (H0 _ _ H1 H2); pose proof (Ab2' (a n) (a N`)).
      assert ((|a n| - |a N`|) < 1). { eapply Theorem172; left; eauto. }
      apply Theorem188_1' with (Θ:=|a N`|) in H5; Simpl_Rin H5.
      rewrite Theorem175; auto. }
    set (R:= /{ z| ∃ m, ILE_N m N` /\ z = |a m| /}).
    assert (fin R).
    { exists (N`)`, (RelCauchy (N`)` a); repeat split;
      try red; intros.
      - destruct H2, H3; subst y; auto.
      - destruct H2; exists (|a x|); constructor; auto.
      - destruct H2, H2, H2; exists x; constructor; auto.
        apply Theorem26'; auto.
      - destruct H2; auto.
      - destruct H2; apply Theorem26 in H2; eauto. }
    assert (No_Empty R).
    { red; exists (|a N`|); constructor; unfold ILE_N; eauto. }
    apply FinMax in H3; auto; destruct H3 as [M1 H3], H3.
    set (M := (R2max M1 (|a N`| + 1))).
    assert (∀ n, |a n| ≦ M); intros.
    { destruct (Theorem10 n N`) as [H5| [H5 |H5]].
       - assert (|a N`| ∈ R). { split; exists N`; split; auto; red; auto. }
         subst n; apply H4 in H6.
         eapply Theorem173; eauto; apply Pr_max2.
      - apply H1 in H5. pose proof (Pr_max3 M1 (|a N`| +1)).
        left; eapply Theorem172; eauto.
      - assert (|a n| ∈ R).
        { constructor; exists n; split; try red; auto. }
        apply H4 in H6. eapply Theorem173; eauto; apply Pr_max2. }
    assert (Bounddown_Seq (-M) a).
    { red; intros. pose proof (H5 n); apply Ab1' in H6; tauto. }
    assert (Boundup_Seq M a).
    { red; intros. pose proof (H5 n); apply Ab1' in H7; tauto. }
    assert (M > - M).
    { assert (M > O).
      { pose proof (Pr_max3 M1 (|a N`| +1)).
        eapply Theorem172; right; split; eauto.
        destruct (a N`); simpl; auto. }
      destruct M; simpl; tauto. }
    destruct (SCT _ _ _ H8 H6 H7) as [a' H9].
    destruct H9, H9 as [s H9], H9, H10 as [ξ H10].
    exists ξ; red; intros. apply Pr_2a in H12.
    destruct (H _ H12) as [N1 H13], (H10 _ H12) as [N2 H14].
    exists (Plus_N N1 N2); intros.
    pose proof (Theorem18 N2 N1); rewrite Theorem6 in H16.
    apply (Theorem15 _ _ n) in H16; auto.
    apply H14 in H16; rewrite H11 in H16.
    pose proof (Theorem18 N1 N2).
    apply (Theorem15 _ _ n) in H17; auto.
    pose proof (SubSeq_P _ _ _ H9 H11 n).
    assert (IGT_N (s n) N1).
    { apply Theorem13 in H18. eapply Theorem16; eauto. }
    pose proof (H13 _ _ H17 H19).
    pose proof (Theorem189 H20 H16); Simpl_Rin H21.
    pose proof (Ab2 ((a n) - (a (s n))) ((a (s n)) - ξ)).
    unfold Minus_R at 2 in H22; rewrite <- Theorem186 in H22;
    Simpl_Rin H22. eapply Theorem172; eauto.
Qed.


Require Import Setoid.
Require Import Omega.
Set Implicit Arguments.
Set Universe Polymorphism.

Parameter IsProvableOutside : Prop -> Prop.
Parameter IsBoundedlyProvableOutside : nat -> Prop -> Prop.
Parameter IsBoundedlyProvable : nat -> Prop -> Prop.

(* The metalogical statement that p is provable in the logic *)
Notation "|- p" := (IsProvableOutside p) (at level 105, no associativity).

(* The metalogical statement that p is provable in n steps in the logic *)
Notation "|-( n ) p" := (IsBoundedlyProvableOutside n p) (at level 105, no associativity).

(* Encoded within the logic, the statement that p is provable in n steps in the logic *)
Notation "[[ p ]]_ n" := (IsBoundedlyProvable n p) (at level 50).

Axiom ProofsAreBounded : forall P : Prop, |- P -> exists N, |-(N) P.
Axiom BoundedProofsAreProofs : forall (P : Prop) N, (|-(N) P) -> |- P.
Axiom OutsideProofBoundsAreLoose : forall (P : Prop) N N', N' > N -> (|-(N) P) -> (|-(N') P).
Axiom ProofBoundsAreLoose : forall (P : Prop) N N', N' >= N -> [[ P ]]_N -> [[ P ]]_N'.

Parameter Log : nat -> nat.
Axiom LogPos : forall n, 1 <= Log n. (* The sort of "log" useful in big-O notation... *)

(* Property 1 - ModusPonensT *)
Axiom ImplicationDistribution : exists c : nat, forall (P Q : Prop), forall a b, |- [[ P -> Q ]]_a -> [[ P ]]_b -> [[ Q ]]_(a+b+c).

(* Property 2 *)
Axiom QuantifierDistribution :
  exists c : nat, forall (phi : nat -> Prop) N, |- [[ forall k, phi k ]]_ N -> forall k, [[ phi k ]]_(c * Log k).
(* TODO: this is a little sketchy. There should be an additive constant dependent on N.
   See Section 4.2 in the paper. *)

(* Property 2, for quantification restricted to numbers bounded below. TODO: verify that this is
   reasonable. *)
Axiom RestrictedQuantifierDistribution :
  exists c : nat, forall (phi : nat -> Prop) N k0, |- [[ forall k, k > k0 -> phi k ]]_ N -> forall k, k > k0 -> [[ phi k ]]_(c * Log k).

(* Epsilon - proof expansion bound *)
Parameter Epsilon : nat -> nat.

(* Property 3 *)
Axiom BoundedNecessitation :
  forall p k, ( |-(k) p ) -> ( |-(Epsilon k) [[ p ]]_k ).

(* Property 4 *)
Axiom BoundedInnerNecessitation :
  forall p k, |- [[ p ]]_ k -> [[ [[ p ]]_k ]]_(Epsilon k).

(* Proposition 1 *)
Parameter ParametricDiagonalLemmaPsi :
  forall G : (nat -> Prop) -> nat -> Prop, nat -> Prop.
Axiom ParametricDiagonalLemma :
  forall G : (nat -> Prop) -> nat -> Prop,
      forall k, |- (ParametricDiagonalLemmaPsi G) k <-> G (ParametricDiagonalLemmaPsi G) k.

Definition dominates (g : nat -> nat) (f : nat -> nat) :=
  forall M, exists N, forall n, n > N -> M * f n < g n.
Notation "f ≻ g" := (dominates f g) (at level 65, no associativity).

Axiom Epsilon_dom : forall f g, f ≻ (fun n => Epsilon (g n)) -> f ≻ g.
(* i.e. [Epsilon] is [Omega(n)] *)

Lemma dom_sum : forall f g h, f ≻ g -> f ≻ h -> f ≻ (fun n => g n + h n).
Proof.
  unfold dominates; intros.
  destruct (H (2 * M)) as [ Ng Hg ].
  destruct (H0 (2 * M)) as [ Nh Hh ].
  exists (max Ng Nh); intros.
  assert (n > Ng) by (pose proof (Nat.le_max_l Ng Nh); omega).
  assert (n > Nh) by (pose proof (Nat.le_max_r Ng Nh); omega).
  specialize (Hg n); specialize (Hh n); intuition idtac.
  clear H H0 H1.
  rewrite <-Nat.double_twice in *.
  unfold Nat.double in *.
  rewrite Nat.mul_add_distr_l in *.
  rewrite Nat.mul_add_distr_r in *.
  omega.
Qed.

Lemma dom_const : forall c f g, f ≻ g -> f ≻ (fun n => c * g n).
Proof.
  unfold dominates; intros.
  destruct (H (M * c)) as [ N Hd ].
  exists N.
  intros.
  rewrite Nat.mul_assoc.
  auto.
Qed.

Section BoundedLob.

  Variable p : nat -> Prop.

  Variable f : nat -> nat.
  Hypothesis f_bound_below : f ≻ (fun k => Epsilon (Log k)).

  Hypothesis Hyp : forall k, |- [[ p k ]]_(f k) -> p k.

  Parameter g : nat -> nat.
  Axiom g_bound_below : g ≻ Log.
  Axiom g_bound_above : f ≻ (fun k => Epsilon (g k)).

  (* [G phi k] represents what is written as G(⌜φ⌝,k) in the paper. (The quasi-quoting is elided.) *)
  Definition G (phi : nat -> Prop) (k : nat) : Prop := [[ phi k ]]_(g k) -> p k.

  (* Differences from the paper:
     - to avoid fiddling around inside boxes inside quantifiers, we split up Step1a and Step1b
       (forward and reverse directions of the iff which defines G).
     - we don't use Big-O notation, instead doing explicit existential quantification
       over constants. the assumptions are currently slightly sketchy. *)

  Definition psi := ParametricDiagonalLemmaPsi G.

  (* The forward direction of Equation 5.3 *)
  Lemma Step1a : exists n, |-(n) forall k, psi k -> G psi k.
  Proof.
    apply ProofsAreBounded.
    pose proof (ParametricDiagonalLemma G).
    firstorder.
  Qed.

  Lemma Step2a : exists n, [[ forall k, psi k -> G psi k ]]_ n.
  Proof.
    destruct Step1a as [ n H ]; exists n.
    eapply BoundedProofsAreProofs.
    apply BoundedNecessitation.
    exact H.
  Qed.

  Lemma Step4 : exists c0, forall k, [[ psi k -> G psi k ]]_ (c0 * Log k).
  Proof.
    destruct QuantifierDistribution as [ c QD ].
    destruct Step2a as [ n H ]; eexists.
    exact (QD _ n H).
  Qed.

  Lemma Step5 : exists c1, forall k a, [[ psi k ]]_a -> [[ G psi k ]]_(a + c1 * Log k).
  Proof.
    destruct ImplicationDistribution as [c ID].
    destruct Step4 as [ c0 H ]; eexists; intros.
    eapply ProofBoundsAreLoose.
    shelve.
    eapply ID.
    apply H.
    apply H0.
    Unshelve.
    exact (c0 + c).
    {
      replace (c0 * Log k + a + c) with (a + (c0 * Log k + c)) by omega.
      unfold ge.
      apply plus_le_compat_l.
      rewrite ?Nat.mul_add_distr_r.
      apply plus_le_compat_l.
      replace c with (c * 1) at 1 by (apply Nat.mul_1_r).
      apply Nat.mul_le_mono_l.
      apply LogPos.
    }
  Qed.

  Lemma Step6 : exists c2, forall k a b, [[ psi k ]]_a -> [[ [[ psi k ]]_(g k) ]]_b -> [[ p k ]]_(a + b + c2 * Log k).
  Proof.
    destruct ImplicationDistribution as [c ID].
    destruct Step5 as [ c1 H ]; eexists; intros.
    eapply ProofBoundsAreLoose. shelve.
    eapply ID.
    apply H.
    apply H0.
    apply H1.
    Unshelve.
    exact (c1 + c).
    {
      rewrite <-?Nat.add_assoc.
      unfold ge.
      apply plus_le_compat_l.
      rewrite ?Nat.mul_add_distr_r.
      replace (c1 * Log k + (b + c)) with (b + (c1 * Log k + c)) by omega.
      repeat apply plus_le_compat_l.
      replace c with (c * 1) at 1 by (apply Nat.mul_1_r).
      apply Nat.mul_le_mono_l.
      apply LogPos.
    }
  Qed.

  Parameter h : nat -> nat.
  Axiom h_bound_above : f ≻ h.
  Axiom h_bound_below : h ≻ (fun k => Epsilon (g k)).

  Lemma Step7 : exists c2, forall k, [[ psi k ]]_(g k) -> [[ [[ psi k ]]_(g k) ]]_(h k) -> [[ p k ]]_(g k +  h k + c2 * Log k).
  Proof.
    destruct Step6 as [c2 H]; exists c2.
    auto.
  Qed.

  Lemma Step8 : exists k1, forall k, k > k1 -> [[ psi k ]]_(g k) -> [[ [[ psi k ]]_(g k) ]]_(h k) -> [[ p k ]]_(f k).
  Proof.
    destruct Step7 as [c2 S7].
    assert (f ≻ (fun k => g k + h k + c2 * Log k)).
    {
      repeat apply dom_sum.
      apply Epsilon_dom.
      apply g_bound_above.
      apply h_bound_above.
      apply dom_const.
      apply Epsilon_dom.
      apply f_bound_below.
    }
    assert (exists k1, forall k, k > k1 -> f k >= g k + h k + c2 * Log k).
    {
      destruct (H 1); exists x.
      simpl in H0.
      intros.
      specialize (H0 k).
      omega.
    }
    destruct H0 as [k1 Hk]; exists k1.
    intros; specialize (S7 k); specialize (Hk k); intuition idtac.
    eapply ProofBoundsAreLoose; eassumption.
  Qed.

  (* Equation 5.4 *)
  Lemma Step9 : exists k1, forall k, k > k1 -> [[ psi k ]]_(g k) -> [[ [[ psi k ]]_(g k) ]]_(h k) -> p k.
  Proof.
    destruct Step8 as [k1 S8]; exists k1.
    intros.
    apply Hyp.
    apply S8; assumption.
  Qed.

  (* Without any previous steps, by bounded necessitation on [psi k] *)
  Lemma Step10 : forall k a, [[ psi k ]]_a -> [[ [[ psi k ]]_a ]]_(Epsilon a).
  Proof.
    intros k a.
    apply BoundedInnerNecessitation.
  Qed.

  (* Specialize Step10 to a := g k *)
  Lemma Step11 : forall k, [[ psi k ]]_(g k) -> [[ [[ psi k ]]_(g k) ]]_(Epsilon (g k)).
  Proof.
    intros.
    apply Step10; assumption.
  Qed.

  (* Equation 5.5 *)
  (* Since [Epsilon g(k) < h k] after some bound [k > k2] *)
  Lemma Step12 : exists k2, forall k, k > k2 -> [[ psi k ]]_(g k) -> [[ [[ psi k ]]_(g k) ]]_(h k).
  Proof.
    assert (exists k2, forall k, k > k2 -> h k > Epsilon (g k)).
    {
      destruct (h_bound_below 1). exists x.
      intros.
      specialize (H k).
      omega.
    }
    intros.
    destruct H as [k2 Hd]; exists k2.
    intros.
    eapply ProofBoundsAreLoose.
    apply Nat.lt_le_incl.
    apply Hd; assumption.
    apply Step11; assumption.
  Qed.

  (* Equation 5.6 *)
  (* Combining Equations 5.4 and 5.5 *)
  Lemma Step13 : exists k2, forall k, k > k2 -> [[ psi k ]]_(g k) -> p k.
  Proof.
    destruct Step9 as [k1 S9].
    destruct Step12 as [k2 S12].
    exists (max k1 k2).
    intros.
    assert (k > k1) by (pose proof (Nat.le_max_l k1 k2); omega).
    assert (k > k2) by (pose proof (Nat.le_max_r k1 k2); omega).
    auto.
  Qed.

  (* The reverse direction of Equation 5.3 *)
  Lemma Step1b : exists n, |-(n) forall k, G psi k -> psi k.
  Proof.
    apply ProofsAreBounded.
    pose proof (ParametricDiagonalLemma G).
    firstorder.
  Qed.

  (* By Step1b and the definition of G: *)
  Lemma Step14 : exists k2 N, |-(N) forall k, k > k2 -> psi k.
  Proof.
    destruct Step13 as [k2 S13].
    destruct Step1b as [n S1].
    exists k2.
    apply BoundedProofsAreProofs in S1.
    apply ProofsAreBounded.
    intros; specialize (S13 k); specialize (S1 k); intuition idtac.
  Qed.

  Lemma Step15 : exists k2 N, [[ forall k, k > k2 -> psi k ]]_ N.
  Proof.
    destruct Step14 as [k2 [N S14]].
    exists k2; exists N.
    eapply BoundedProofsAreProofs.
    apply BoundedNecessitation.
    assumption.
  Qed.

  Lemma TakeOutHyp : forall (P Q : Prop) n1, [[ P -> Q ]]_n1 -> (P -> exists n2, [[ Q ]]_(n1 + n2)).
  Proof.
    destruct ImplicationDistribution as [c0 ID].
    intros.
    destruct (ProofsAreBounded H0) as [c1 PB].
    eexists.
    eapply ProofBoundsAreLoose.
    shelve.
    eapply ID.
    eassumption.
    eapply BoundedProofsAreProofs.
    eapply BoundedNecessitation.
    eassumption.
    Unshelve.
    exact (c1 + c0).
    omega.
  Qed.

  Lemma Step16 : exists k2 c, forall k, k > k2 -> [[ psi k ]]_(c * Log k).
  Proof.
    destruct Step15 as [k2 [N S15]].
    destruct RestrictedQuantifierDistribution as [c RQD].
    destruct ImplicationDistribution as [c0 ID].
    exists k2; eexists.

    intros.
    apply RQD with (k := k) in S15; eassumption.
  Qed.

  (* Equation 5.7 *)
  Lemma Step17 : exists k_hat, forall k, k > k_hat -> [[ psi k ]]_(g k).
  Proof.
    destruct Step16 as [k2 [c S16]].
    destruct (g_bound_below c) as [k3 Hgb].
    exists (max k2 k3); intros.
    assert (k > k2) by (pose proof (Nat.le_max_l k2 k3); omega).
    assert (k > k3) by (pose proof (Nat.le_max_r k2 k3); omega).
    eapply ProofBoundsAreLoose; [ | apply S16; assumption ].
    apply Nat.lt_le_incl.
    apply Hgb.
    assumption.
  Qed.

  Lemma TheoremStatement : exists k_hat, forall k, k > k_hat -> p k.
  Proof.
    destruct Step13 as [k2 S13].
    destruct Step17 as [k_hat S17].
    (* a bit silly to max in k2 again since we know [k_hat >= k2], but whatever *)
    exists (max k2 k_hat).
    intros.
    assert (k > k2) by (pose proof (Nat.le_max_l k2 k_hat); omega).
    assert (k > k_hat) by (pose proof (Nat.le_max_r k2 k_hat); omega).
    auto.
  Qed.

  (* Done! *)

End BoundedLob.

Check TheoremStatement. (* Reads very literally like Theorem 3 in the paper! *)


Set Implicit Arguments.
Require Import List Morphisms FinFun.
From Undecidability.HOU Require Import std.tactics std.ars.basic std.ars.confluence.
Import ListNotations ArsInstances.
Section ListRelations.

  Variable (X : Type) (R: X -> X -> Prop).
  Inductive lstep: list X -> list X -> Prop :=
  | stepHead s s' A: R s s' -> lstep (s :: A) (s' :: A)
  | stepTail s A A': lstep A A' -> lstep (s :: A) (s :: A').

  Hint Constructors lstep : core.

  Lemma lstep_cons_nil S:
    lstep S nil -> False.
  Proof.
    intros. inv H.
  Qed.

  Lemma lsteps_cons_nil s S:
    star lstep (s :: S) nil -> False.
  Proof.
    intros. remember (s :: S) as S'. remember nil as T.  revert S s HeqS' HeqT.
    induction H.
    - intros; subst; discriminate.
    - intros; subst. inv H; eapply IHstar; eauto.
  Qed.

  Lemma lstep_nil_cons S:
    lstep nil S -> False.
  Proof.
    intros H. inv H.
  Qed.

  Lemma lsteps_nil_cons s S:
    star lstep nil (s :: S) -> False.
  Proof.
    intros H. inv H.
    eapply lstep_nil_cons; eauto.
  Qed.

  Lemma lsteps_cons_inv s t S T:
    star lstep (s :: S) (t :: T) -> star R s t /\ star lstep S T.
  Proof.
    intros H. remember (s :: S) as S'. remember (t :: T) as T'.
    revert s t S T HeqS' HeqT'.
    induction H; intros.
    - subst. injection HeqT' as ??; subst. intuition.
    - subst. inv H.
      + destruct (IHstar s' t S T); eauto.
      + destruct (IHstar s t A' T); eauto.
  Qed.

  #[export] Instance lsteps_cons :
    Proper (star R ++> star lstep ++> star lstep) cons.
  Proof.
    intros ??; induction 1; intros ??; induction 1; eauto.
  Qed.

  Lemma confluence_lstep:
    confluent R -> confluent lstep.
  Proof.
    intros conf ?. induction x; intros.
    - inv H. inv H0. exists nil; eauto. inv H. inv H1.
    - destruct y, z; try solve [exfalso; eapply lsteps_cons_nil; eassumption].
      eapply lsteps_cons_inv in H; eapply lsteps_cons_inv in H0.
      intuition idtac; destruct (IHx _ _ H2 H3) as [V].
      destruct (conf _ _ _ H1 H) as [v].
      exists (v :: V).
      now rewrite H5, H0. now rewrite H6, H4.
  Qed.

  Hint Resolve confluence_lstep : core.

  Lemma normal_lstep_in A:
    Normal lstep A -> forall x, In x A  -> Normal R x.
  Proof.
    induction A; cbn; intuition idtac; subst; trivial.
    intros ? H1. eapply H. constructor. eassumption.
    eapply IHA; trivial. intros ? H2. eapply H.
    econstructor 2; eauto.
  Qed.

  Lemma normal_in_lstep A:
    (forall x, In x A  -> Normal R x) -> Normal lstep A.
  Proof.
    induction A; cbn; intuition idtac.
    - intros ? H1. inv H1.
    - intros ? H1. inv H1.
      eapply H; eauto.
      eapply IHA; eauto.
  Qed.

  Lemma lstep_normal_cons_l a A:
    Normal lstep (a :: A) -> Normal R a.
  Proof. intros ? ? ?. eapply H; econstructor; eauto. Qed.

  Lemma lstep_normal_cons_r a A:
    Normal lstep (a :: A) -> Normal lstep A.
  Proof. intros ? ? ?. eapply H; econstructor 2; eauto. Qed.

  Lemma lstep_normal_cons a A:
    Normal R a -> Normal lstep A -> Normal lstep (a :: A).
  Proof. intros ? ? ? ?. inv H1; firstorder.  Qed.

  Lemma lstep_normal_nil:
    Normal lstep nil.
  Proof. intros ? H; inv H. Qed.

  Hint Resolve
       lstep_normal_nil
       lstep_normal_cons_l
       lstep_normal_cons_r
       lstep_normal_cons : core.

  Hint Resolve normal_lstep_in normal_in_lstep : core.

  Lemma equiv_lstep_cons_inv s t S T:
    equiv lstep (s :: S) (t :: T) -> equiv R s t /\ equiv lstep S T.
  Proof.
    intros H. remember (s :: S) as S'. remember (t :: T) as T'.
    revert s t S T HeqS' HeqT'.
    induction H; intros.
    - subst. injection HeqT' as ??; subst; intuition.
    - subst. inv H.
      + destruct x'. eapply lstep_cons_nil in H1 as [].
        edestruct IHstar; trivial. inv H1.
        * intuition idtac.
          transitivity x; eauto.
        * intuition idtac. transitivity x'; eauto.
      + destruct x'. eapply lstep_nil_cons in H1 as [].
        edestruct IHstar; trivial. inv H1; intuition idtac.
        * transitivity x; eauto.
        * transitivity x'; eauto.
  Qed.

  #[export] Instance equiv_lstep_cons_proper:
    Proper (equiv R ++> equiv lstep ++> equiv lstep) cons.
  Proof.
    intros ??; induction 1; intros ??; induction 1; [eauto|..].
    - rewrite <-IHstar. destruct H.
      eauto. symmetry. eauto.
    - rewrite <-(IHstar x0 x0); try reflexivity.
      destruct H. eauto. symmetry. eauto.
    - rewrite <-IHstar0.
      destruct H1. eauto. symmetry. eauto.
  Qed.

  Lemma not_equiv_lstep_nil_cons a A:
    ~ equiv lstep nil (a :: A).
  Proof.
    intros H; inv H; inv H0; inv H.
  Qed.

  Lemma list_equiv_ind (P: list X -> list X -> Prop):
    P nil nil ->
    (forall s t S T, equiv R s t -> equiv lstep S T -> P S T -> P (s :: S) (t :: T)) ->
    forall S T, equiv lstep S T -> P S T.
  Proof.
    intros B IH S T H; induction S in T, H |-*; destruct T; trivial.
    - exfalso; eapply not_equiv_lstep_nil_cons; eauto.
    - exfalso; eapply not_equiv_lstep_nil_cons; symmetry; eauto.
    - eapply equiv_lstep_cons_inv in H as (? & ?).
      eapply IH; eauto.
  Qed.

End ListRelations.

#[export] Hint Constructors lstep : core.

#[export] Hint Resolve
     lstep_normal_nil
     lstep_normal_cons_l
     lstep_normal_cons_r
     lstep_normal_cons : core.

#[export] Hint Resolve confluence_lstep : core.
#[export] Hint Resolve normal_lstep_in normal_in_lstep : core.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e137m13_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


(**
Given is a displayed bicategory on C. Then we have a total category E of which the objects are objects in C with some additional structure.
In this file, we give a method for adding 2-cells to the structure, which represents an equation on the structure in the total category.
The equation has two endpoints, l and r. These are given as natural maps in the underlying bicategory.
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection.

Local Open Scope cat.

Section Add2Cell.
  Context {C : bicat}.
  Variable (D : disp_bicat C).

  Local Notation E := (total_bicat D).
  Local Notation F := (pr1_psfunctor D).

  Variable (S T : psfunctor C C)
           (l r : pstrans
                    (@comp_psfunctor E C C S F)
                    (@comp_psfunctor E C C T F)).

  Definition add_cell_disp_cat_data : disp_cat_ob_mor E.
  Proof.
    use make_disp_cat_ob_mor.
    - exact (λ X, l X ==> r X).
    - exact (λ X Y α β f,
             (α ▹ #T(#F f))
               • psnaturality_of r f
             =
             (psnaturality_of l f)
               • (#S(#F f) ◃ β)).
  Defined.

  Definition add_cell_disp_cat_id_comp : disp_cat_id_comp E add_cell_disp_cat_data.
  Proof.
    split.
    - intros x xx.
      pose (pstrans_id_alt l x) as p.
      simpl.
      cbn in p.
      rewrite !psfunctor_id2 in p.
      rewrite id2_left, id2_right in p.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        exact p.
      }
      clear p.
      refine (!_).
      pose (pstrans_id_alt r x) as p.
      cbn in p.
      rewrite !psfunctor_id2 in p.
      rewrite id2_left, id2_right in p.
      etrans.
      {
        apply maponpaths.
        exact p.
      }
      clear p.
      rewrite !vassocr.
      rewrite vcomp_whisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite vcomp_runitor.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite linvunitor_natural.
      rewrite <- lwhisker_hcomp.
      rewrite !vassocl.
      rewrite vcomp_whisker.
      apply idpath.
    - intros x y z f g xx yy zz Hf Hg ; cbn.
      pose (pstrans_comp_alt l f g) as pl.
      pose (pstrans_comp_alt r f g) as pr.
      cbn in pl, pr ; rewrite pl, pr ; clear pl pr.
      rewrite !vassocr.
      rewrite vcomp_whisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite vcomp_whisker.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite <- rwhisker_rwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite <- lwhisker_lwhisker.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite rwhisker_vcomp.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths_2.
        apply maponpaths.
        apply Hf.
      }
      rewrite <- rwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- rwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite lwhisker_vcomp.
      etrans.
      {
        apply maponpaths.
        apply Hg.
      }
      rewrite <- lwhisker_vcomp.
      reflexivity.
  Qed.

  Definition add_cell_disp_cat : disp_bicat E.
  Proof.
    use disp_cell_unit_bicat.
    use tpair.
    - exact add_cell_disp_cat_data.
    - exact add_cell_disp_cat_id_comp.
  Defined.

  Definition add_cell_disp_cat_univalent_2_1
    : disp_univalent_2_1 add_cell_disp_cat.
  Proof.
    apply disp_cell_unit_bicat_univalent_2_1.
    intros.
    apply C.
  Defined.

  Definition add_cell_disp_cat_univalent_2_0
             (HC : is_univalent_2_1 C)
             (HD : disp_univalent_2_1 D)
    : disp_univalent_2_0 add_cell_disp_cat.
  Proof.
    use disp_cell_unit_bicat_univalent_2_0.
    - apply total_is_univalent_2_1.
      + exact HC.
      + exact HD.
    - intros.
      apply C.
    - intros x xx yy.
      simpl in *.
      apply C.
    - abstract
        (intros x xx yy;
         intros p;
         induction p as [p q];
         cbn;
         cbn in p, q;
         pose (pstrans_id_alt l) as pl;
         cbn in pl ; rewrite pl in p ; clear pl;
         pose (pstrans_id_alt r) as pr;
         cbn in pr ; rewrite pr in p ; clear pr;
         cbn in p;
         rewrite !psfunctor_id2 in p;
         rewrite !id2_right, !id2_left in p;
         rewrite !vassocr in p;
         rewrite vcomp_whisker in p;
         rewrite !vassocl in p;
         assert (is_invertible_2cell (l x ◃ ((pr122 T) (pr1 x)) ^-1)) as H;
         try is_iso ;
         pose (vcomp_lcancel _ H p) as p';
         rewrite !vassocr in p';
         rewrite vcomp_runitor in p';
         rewrite !vassocl in p';
         pose (vcomp_lcancel _ (is_invertible_2cell_runitor _) p') as p'';
         use (vcomp_rcancel (linvunitor (r x))) ; try is_iso;
         use (vcomp_rcancel  (psfunctor_id S (pr1 x) ▹ r x))
         ; try (is_iso ; exact (psfunctor_id S (pr1 x)));
         rewrite !vassocl;
         refine (p'' @ _);
         rewrite vcomp_whisker;
         rewrite !vassocr;
         apply maponpaths_2;
         rewrite lwhisker_hcomp;
         exact (!(linvunitor_natural _))).
  Defined.

  Definition add_cell_disp_cat_univalent_2
             (HC : is_univalent_2_1 C)
             (HD : disp_univalent_2_1 D)
    : disp_univalent_2 add_cell_disp_cat.
  Proof.
    apply make_disp_univalent_2.
    - apply add_cell_disp_cat_univalent_2_0; assumption.
    - apply add_cell_disp_cat_univalent_2_1.
  Defined.

  Definition disp_2cells_isaprop_add_cell
    : disp_2cells_isaprop add_cell_disp_cat.
  Proof.
    intro; intros; exact isapropunit.
  Qed.

  Definition disp_locally_groupoid_add_cell
    : disp_locally_groupoid add_cell_disp_cat.
  Proof.
    use make_disp_locally_groupoid.
    - intro; intros. exact tt.
    - exact disp_2cells_isaprop_add_cell.
  Qed.

End Add2Cell.


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

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

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

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

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

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Lemma lem: forall n1 n2 l, drop (Succ n1) (drop n2 l) = drop n1 (drop (Succ n2) l).
Proof.
intros. generalize dependent n1. generalize dependent n2. induction l.
- intros. assert (forall n x l, drop (Succ n) (Cons x l) = drop n l).
   + intros. reflexivity.
   + destruct n2.
   * rewrite H. rewrite H. rewrite <- IHl. reflexivity.
   * simpl. destruct l. reflexivity. reflexivity.
- intros. assert (forall n, drop n Nil = Nil).
   + intros. destruct n. reflexivity. reflexivity.
   + rewrite H. rewrite H. rewrite H. reflexivity.
Qed.

(* It's possible this can be proven without a helper lemma but I couldn't figure it out. *)
Theorem theorem0 : forall (w : natural) (x : natural) (y : natural) (z : lst), eq (drop (Succ w) (drop x (Cons y z))) (drop w (drop x z)).
Proof.
intros. lfind. Admitted.


Inductive Ty : Type :=
| B : Ty
| N : Ty
| Imp : Ty -> Ty -> Ty.

Inductive Term : Type :=
| V : nat -> Term
| App : Term -> Term -> Term
| Lam : Term -> Term
| Rec : forall a, (a -> a) -> Term.
Implicit Arguments Rec [a].

Check Rec (fun a => (App a a)).


From mathcomp.ssreflect Require Import ssreflect ssrnat seq.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Module Problem.
  CoInductive itree A := C : A -> seq (itree A) -> itree A.

  Fail CoFixpoint example (n : nat) : itree nat :=
    C n ((fix build_branches m : seq (itree nat) :=
            match m with
            | 0 => [::]
            | t.+1 => example m :: build_branches t
            end) n).
End Problem.