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

Set Implicit Arguments.

Require Import ZArith Lia.
Require Import BigNumPrelude.
Require Import DoubleType.
Require Import DoubleBase.
Require Import DoubleAdd.
Require Import DoubleSub.
Require Import DoubleMul.
Require Import DoubleSqrt.
Require Import DoubleLift.
Require Import DoubleDivn1.
Require Import DoubleDiv.
Require Import CyclicAxioms.

Local Open Scope Z_scope.

Section Z_2nZ.

 Context {t : univ_of_cycles}{ops : ZnZ.Ops t}.

 Let w_digits      := ZnZ.digits.
 Let w_zdigits      := ZnZ.zdigits.

 Let w_to_Z        := ZnZ.to_Z.
 Let w_of_pos      := ZnZ.of_pos.
 Let w_head0       := ZnZ.head0.
 Let w_tail0       := ZnZ.tail0.

 Let w_0            := ZnZ.zero.
 Let w_1            := ZnZ.one.
 Let w_Bm1          := ZnZ.minus_one.

 Let w_compare     := ZnZ.compare.
 Let w_eq0         := ZnZ.eq0.

 Let w_opp_c       := ZnZ.opp_c.
 Let w_opp         := ZnZ.opp.
 Let w_opp_carry   := ZnZ.opp_carry.

 Let w_succ_c      := ZnZ.succ_c.
 Let w_add_c       := ZnZ.add_c.
 Let w_add_carry_c := ZnZ.add_carry_c.
 Let w_succ        := ZnZ.succ.
 Let w_add         := ZnZ.add.
 Let w_add_carry   := ZnZ.add_carry.

 Let w_pred_c      := ZnZ.pred_c.
 Let w_sub_c       := ZnZ.sub_c.
 Let w_sub_carry_c := ZnZ.sub_carry_c.
 Let w_pred        := ZnZ.pred.
 Let w_sub         := ZnZ.sub.
 Let w_sub_carry   := ZnZ.sub_carry.

 Let w_mul_c       := ZnZ.mul_c.
 Let w_mul         := ZnZ.mul.
 Let w_square_c    := ZnZ.square_c.

 Let w_div21       := ZnZ.div21.
 Let w_div_gt      := ZnZ.div_gt.
 Let w_div         := ZnZ.div.

 Let w_mod_gt      := ZnZ.modulo_gt.
 Let w_mod         := ZnZ.modulo.

 Let w_gcd_gt      := ZnZ.gcd_gt.
 Let w_gcd         := ZnZ.gcd.

 Let w_add_mul_div := ZnZ.add_mul_div.

 Let w_pos_mod := ZnZ.pos_mod.

 Let w_is_even     := ZnZ.is_even.
 Let w_sqrt2       := ZnZ.sqrt2.
 Let w_sqrt        := ZnZ.sqrt.

 Let _zn2z := zn2z t.

 Let wB := base w_digits.

 Let w_Bm2 := w_pred w_Bm1.

 Let ww_1 := ww_1 w_0 w_1.
 Let ww_Bm1 := ww_Bm1 w_Bm1.

 Let w_add2 a b := match w_add_c a b with C0 p => WW w_0 p | C1 p => WW w_1 p end.

 Let _ww_digits := xO w_digits.

 Let _ww_zdigits := w_add2 w_zdigits w_zdigits.

 Let to_Z := zn2z_to_Z wB w_to_Z.

 Let w_W0 := ZnZ.WO.
 Let w_0W := ZnZ.OW.
 Let w_WW := ZnZ.WW.

 Let ww_of_pos p :=
  match w_of_pos p with
  | (N0, l) => (N0, WW w_0 l)
  | (Npos ph,l) =>
    let (n,h) := w_of_pos ph in (n, w_WW h l)
  end.

 Let head0 :=
  Eval lazy beta delta [ww_head0] in
  ww_head0 w_0 w_0W w_compare w_head0 w_add2 w_zdigits _ww_zdigits.

 Let tail0 :=
  Eval lazy beta delta [ww_tail0] in
  ww_tail0 w_0 w_0W w_compare w_tail0 w_add2 w_zdigits _ww_zdigits.

 Let ww_WW := Eval lazy beta delta [ww_WW] in (@ww_WW t).
 Let ww_0W := Eval lazy beta delta [ww_0W] in (@ww_0W t).
 Let ww_W0 := Eval lazy beta delta [ww_W0] in (@ww_W0 t).

 (* ** Comparison ** *)
 Let compare :=
  Eval lazy beta delta[ww_compare] in ww_compare w_0 w_compare.

 Let eq0 (x:zn2z t) :=
  match x with
  | W0 => true
  | _ => false
  end.

 (* ** Opposites ** *)
 Let opp_c :=
  Eval lazy beta delta [ww_opp_c] in ww_opp_c w_0 w_opp_c w_opp_carry.

 Let opp :=
  Eval lazy beta delta [ww_opp] in ww_opp w_0 w_opp_c w_opp_carry w_opp.

 Let opp_carry :=
  Eval lazy beta delta [ww_opp_carry] in ww_opp_carry w_WW ww_Bm1 w_opp_carry.

 (* ** Additions ** *)

 Let succ_c :=
  Eval lazy beta delta [ww_succ_c] in ww_succ_c w_0 ww_1 w_succ_c.

 Let add_c :=
  Eval lazy beta delta [ww_add_c] in ww_add_c w_WW w_add_c w_add_carry_c.

 Let add_carry_c :=
  Eval lazy beta iota delta [ww_add_carry_c ww_succ_c] in
  ww_add_carry_c w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c.

 Let succ :=
  Eval lazy beta delta [ww_succ] in ww_succ w_W0 ww_1 w_succ_c w_succ.

 Let add :=
  Eval lazy beta delta [ww_add] in ww_add w_add_c w_add w_add_carry.

 Let add_carry :=
  Eval lazy beta iota delta [ww_add_carry ww_succ] in
  ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ w_add w_add_carry.

 (* ** Subtractions ** *)

 Let pred_c :=
  Eval lazy beta delta [ww_pred_c] in ww_pred_c w_Bm1 w_WW ww_Bm1 w_pred_c.

 Let sub_c :=
  Eval lazy beta iota delta [ww_sub_c ww_opp_c] in
  ww_sub_c w_0 w_WW w_opp_c w_opp_carry w_sub_c w_sub_carry_c.

 Let sub_carry_c :=
  Eval lazy beta iota delta [ww_sub_carry_c ww_pred_c ww_opp_carry] in
  ww_sub_carry_c w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c w_sub_c w_sub_carry_c.

 Let pred :=
  Eval lazy beta delta [ww_pred] in ww_pred w_Bm1 w_WW ww_Bm1 w_pred_c w_pred.

 Let sub :=
  Eval lazy beta iota delta [ww_sub ww_opp] in
  ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry.

 Let sub_carry :=
  Eval lazy beta iota delta [ww_sub_carry ww_pred ww_opp_carry] in
  ww_sub_carry w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c w_sub_carry_c w_pred
  w_sub w_sub_carry.

 (* ** Multiplication ** *)

 Let mul_c :=
  Eval lazy beta iota delta [ww_mul_c double_mul_c] in
  ww_mul_c w_0 w_1 w_WW w_W0 w_mul_c add_c add add_carry.

 Let karatsuba_c :=
  Eval lazy beta iota delta [ww_karatsuba_c double_mul_c kara_prod] in
  ww_karatsuba_c w_0 w_1 w_WW w_W0 w_compare w_add w_sub w_mul_c
    add_c add add_carry sub_c sub.

 Let mul :=
  Eval lazy beta delta [ww_mul] in
  ww_mul w_W0 w_add w_mul_c w_mul add.

 Let square_c :=
  Eval lazy beta delta [ww_square_c] in
  ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add add_carry.

 (* Division operation *)

 Let div32 :=
   Eval lazy beta iota delta [w_div32] in
   w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c
   w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c.

 Let div21 :=
  Eval lazy beta iota delta [ww_div21] in
   ww_div21 w_0 w_0W div32 ww_1 compare sub.

 Let low (p: zn2z t) := match p with WW _ p1 => p1 | _ => w_0 end.

 Let add_mul_div :=
  Eval lazy beta delta [ww_add_mul_div] in
  ww_add_mul_div w_0 w_WW w_W0 w_0W compare w_add_mul_div sub w_zdigits low.

 Let div_gt :=
  Eval lazy beta delta [ww_div_gt] in
  ww_div_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp
  w_opp_carry w_sub_c w_sub w_sub_carry
  w_div_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits.

 Let div :=
  Eval lazy beta delta [ww_div] in ww_div ww_1 compare div_gt.

 Let mod_gt :=
  Eval lazy beta delta [ww_mod_gt] in
  ww_mod_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry
  w_mod_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits add_mul_div w_zdigits.

 Let mod_ :=
  Eval lazy beta delta [ww_mod] in ww_mod compare mod_gt.

 Let pos_mod :=
  Eval lazy beta delta [ww_pos_mod] in
    ww_pos_mod w_0 w_zdigits w_WW w_pos_mod compare w_0W low sub _ww_zdigits.

 Let is_even :=
  Eval lazy beta delta [ww_is_even] in ww_is_even w_is_even.

 Let sqrt2 :=
  Eval lazy beta delta [ww_sqrt2] in
    ww_sqrt2 w_is_even w_compare w_0 w_1 w_Bm1 w_0W w_sub w_square_c
    w_div21 w_add_mul_div w_zdigits w_add_c w_sqrt2 w_pred pred_c
    pred add_c add sub_c add_mul_div.

 Let sqrt :=
  Eval lazy beta delta [ww_sqrt] in
    ww_sqrt w_is_even w_0 w_sub w_add_mul_div w_zdigits
     _ww_zdigits w_sqrt2 pred add_mul_div head0 compare low.

 Let gcd_gt_fix :=
  Eval cbv beta delta [ww_gcd_gt_aux ww_gcd_gt_body] in
  ww_gcd_gt_aux w_0 w_WW w_0W w_compare w_opp_c w_opp w_opp_carry
      w_sub_c w_sub w_sub_carry w_gcd_gt
      w_add_mul_div w_head0 w_div21 div32 _ww_zdigits add_mul_div
      w_zdigits.

 Let gcd_cont :=
  Eval lazy beta delta [gcd_cont] in gcd_cont ww_1 w_1 w_compare.

 Let gcd_gt :=
  Eval lazy beta delta [ww_gcd_gt] in
  ww_gcd_gt w_0 w_eq0 w_gcd_gt gcd_gt_fix gcd_cont _ww_digits.

 Let gcd :=
  Eval lazy beta delta [ww_gcd] in
  ww_gcd compare w_0 w_eq0 w_gcd_gt gcd_gt_fix gcd_cont _ww_digits.

 Definition lor (x y : zn2z t) :=
  match x, y with
  | W0, _ => y
  | _, W0 => x
  | WW hx lx, WW hy ly => WW (ZnZ.lor hx hy) (ZnZ.lor lx ly)
  end.

 Definition land (x y : zn2z t) :=
  match x, y with
  | W0, _ => W0
  | _, W0 => W0
  | WW hx lx, WW hy ly => WW (ZnZ.land hx hy) (ZnZ.land lx ly)
  end.

 Definition lxor (x y : zn2z t) :=
  match x, y with
  | W0, _ => y
  | _, W0 => x
  | WW hx lx, WW hy ly => WW (ZnZ.lxor hx hy) (ZnZ.lxor lx ly)
  end.

 (* ** Record of operators on 2 words *)

 Global Instance mk_zn2z_ops : ZnZ.Ops (zn2z t) | 1 :=
  ZnZ.MkOps _ww_digits _ww_zdigits
    to_Z ww_of_pos head0 tail0
    W0 ww_1 ww_Bm1
    compare eq0
    opp_c opp opp_carry
    succ_c add_c add_carry_c
    succ add add_carry
    pred_c sub_c sub_carry_c
    pred sub sub_carry
    mul_c mul square_c
    div21 div_gt div
    mod_gt mod_
    gcd_gt gcd
    add_mul_div
    pos_mod
    is_even
    sqrt2
    sqrt
    lor
    land
    lxor.

 Global Instance mk_zn2z_ops_karatsuba : ZnZ.Ops (zn2z t) | 2 :=
   ZnZ.MkOps _ww_digits _ww_zdigits
    to_Z ww_of_pos head0 tail0
    W0 ww_1 ww_Bm1
    compare eq0
    opp_c opp opp_carry
    succ_c add_c add_carry_c
    succ add add_carry
    pred_c sub_c sub_carry_c
    pred sub sub_carry
    karatsuba_c mul square_c
    div21 div_gt div
    mod_gt mod_
    gcd_gt gcd
    add_mul_div
    pos_mod
    is_even
    sqrt2
    sqrt
    lor
    land
    lxor.

 (* Proof *)
 Context {specs : ZnZ.Specs ops}.

 Create HintDb ZnZ.

 Hint Resolve
    ZnZ.spec_to_Z
    ZnZ.spec_of_pos
    ZnZ.spec_0
    ZnZ.spec_1
    ZnZ.spec_m1
    ZnZ.spec_compare
    ZnZ.spec_eq0
    ZnZ.spec_opp_c
    ZnZ.spec_opp
    ZnZ.spec_opp_carry
    ZnZ.spec_succ_c
    ZnZ.spec_add_c
    ZnZ.spec_add_carry_c
    ZnZ.spec_succ
    ZnZ.spec_add
    ZnZ.spec_add_carry
    ZnZ.spec_pred_c
    ZnZ.spec_sub_c
    ZnZ.spec_sub_carry_c
    ZnZ.spec_pred
    ZnZ.spec_sub
    ZnZ.spec_sub_carry
    ZnZ.spec_mul_c
    ZnZ.spec_mul
    ZnZ.spec_square_c
    ZnZ.spec_div21
    ZnZ.spec_div_gt
    ZnZ.spec_div
    ZnZ.spec_modulo_gt
    ZnZ.spec_modulo
    ZnZ.spec_gcd_gt
    ZnZ.spec_gcd
    ZnZ.spec_head0
    ZnZ.spec_tail0
    ZnZ.spec_add_mul_div
    ZnZ.spec_pos_mod
    ZnZ.spec_is_even
    ZnZ.spec_sqrt2
    ZnZ.spec_sqrt
    ZnZ.spec_WO
    ZnZ.spec_OW
    ZnZ.spec_WW : ZnZ.

 Ltac wwauto := unfold ww_to_Z; eauto with ZnZ.

 Let wwB := base _ww_digits.

 Notation "[| x |]" := (to_Z x)  (at level 0, x at level 99).

 Notation "[+| c |]" :=
   (interp_carry 1 wwB to_Z c)  (at level 0, c at level 99).

 Notation "[-| c |]" :=
   (interp_carry (-1) wwB to_Z c)  (at level 0, c at level 99).

 Notation "[[ x ]]" := (zn2z_to_Z wwB to_Z x)  (at level 0, x at level 99).

 Let spec_ww_to_Z   : forall x, 0 <= [| x |] < wwB.
 Proof. refine (spec_ww_to_Z w_digits w_to_Z _); wwauto. Qed.

 Let spec_ww_of_pos : forall p,
     Zpos p = (Z.of_N (fst (ww_of_pos p)))*wwB + [|(snd (ww_of_pos p))|].
 Proof.
  unfold ww_of_pos;intros.
  rewrite (ZnZ.spec_of_pos p). unfold w_of_pos.
  case (ZnZ.of_pos p); intros. simpl.
  destruct n; simpl ZnZ.to_Z.
  simpl;unfold w_to_Z,w_0; rewrite ZnZ.spec_0;trivial.
  unfold Z.of_N.
  rewrite (ZnZ.spec_of_pos p0).
  case (ZnZ.of_pos p0); intros. simpl.
  unfold fst, snd,Z.of_N, to_Z, wB, w_digits, w_to_Z, w_WW.
  rewrite ZnZ.spec_WW.
  replace wwB with (wB*wB).
  unfold wB,w_to_Z,w_digits;destruct n;ring.
  symmetry. rewrite <- Z.pow_2_r; exact (wwB_wBwB w_digits).
 Qed.

 Let spec_ww_0 : [|W0|] = 0.
 Proof. reflexivity. Qed.

 Let spec_ww_1 : [|ww_1|] = 1.
 Proof. refine (spec_ww_1 w_0 w_1 w_digits w_to_Z _ _);wwauto. Qed.

 Let spec_ww_Bm1 : [|ww_Bm1|] = wwB - 1.
 Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);wwauto. Qed.

 Let spec_ww_compare :
  forall x y, compare x y = Z.compare [|x|] [|y|].
 Proof.
  refine (spec_ww_compare w_0 w_digits w_to_Z w_compare _ _ _);wwauto.
 Qed.

 Let spec_ww_eq0 : forall x, eq0 x = true -> [|x|] = 0.
 Proof. destruct x;simpl;intros;trivial;discriminate. Qed.

 Let spec_ww_opp_c : forall x, [-|opp_c x|] = -[|x|].
 Proof.
  refine(spec_ww_opp_c w_0 w_0 W0 w_opp_c w_opp_carry w_digits w_to_Z _ _ _ _);
   wwauto.
 Qed.

 Let spec_ww_opp : forall x, [|opp x|] = (-[|x|]) mod wwB.
 Proof.
  refine(spec_ww_opp w_0 w_0 W0 w_opp_c w_opp_carry w_opp
   w_digits w_to_Z _ _ _ _ _);
  wwauto.
 Qed.

 Let spec_ww_opp_carry : forall x, [|opp_carry x|] = wwB - [|x|] - 1.
 Proof.
  refine (spec_ww_opp_carry w_WW ww_Bm1 w_opp_carry w_digits w_to_Z _ _ _);
  wwauto.
 Qed.

 Let spec_ww_succ_c : forall x, [+|succ_c x|] = [|x|] + 1.
 Proof.
  refine (spec_ww_succ_c w_0 w_0 ww_1 w_succ_c w_digits w_to_Z _ _ _ _);wwauto.
 Qed.

 Let spec_ww_add_c  : forall x y, [+|add_c x y|] = [|x|] + [|y|].
 Proof.
  refine (spec_ww_add_c w_WW w_add_c w_add_carry_c w_digits w_to_Z _ _ _);wwauto.
 Qed.

 Let spec_ww_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|]+[|y|]+1.
 Proof.
  refine (spec_ww_add_carry_c w_0 w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c
   w_digits w_to_Z _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_succ : forall x, [|succ x|] = ([|x|] + 1) mod wwB.
 Proof.
  refine (spec_ww_succ w_W0 ww_1 w_succ_c w_succ w_digits w_to_Z _ _ _ _ _);
  wwauto.
 Qed.

 Let spec_ww_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wwB.
 Proof.
  refine (spec_ww_add w_add_c w_add w_add_carry w_digits w_to_Z _ _ _ _);wwauto.
 Qed.

 Let spec_ww_add_carry : forall x y, [|add_carry x y|]=([|x|]+[|y|]+1)mod wwB.
 Proof.
  refine (spec_ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ
  w_add w_add_carry w_digits w_to_Z _ _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_pred_c : forall x, [-|pred_c x|] = [|x|] - 1.
 Proof.
  refine (spec_ww_pred_c w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_digits w_to_Z
   _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|].
 Proof.
  refine (spec_ww_sub_c w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c
   w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|]-[|y|]-1.
 Proof.
  refine (spec_ww_sub_carry_c w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c
   w_sub_c w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_pred : forall x, [|pred x|] = ([|x|] - 1) mod wwB.
 Proof.
  refine (spec_ww_pred w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_pred w_digits w_to_Z
   _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wwB.
 Proof.
  refine (spec_ww_sub w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c w_opp
   w_sub w_sub_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_sub_carry : forall x y, [|sub_carry x y|]=([|x|]-[|y|]-1) mod wwB.
 Proof.
  refine (spec_ww_sub_carry w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c
   w_sub_carry_c w_pred w_sub w_sub_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _);
  wwauto.
 Qed.

 Let spec_ww_mul_c : forall x y, [[mul_c x y ]] = [|x|] * [|y|].
 Proof.
  refine (spec_ww_mul_c w_0 w_1 w_WW w_W0 w_mul_c add_c add add_carry w_digits
   w_to_Z _ _ _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_karatsuba_c : forall x y, [[karatsuba_c x y ]] = [|x|] * [|y|].
 Proof.
 refine (spec_ww_karatsuba_c _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
          _ _ _ _ _ _ _ _ _ _ _ _); wwauto.
  unfold w_digits; apply ZnZ.spec_more_than_1_digit; auto.
 Qed.

 Let spec_ww_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wwB.
 Proof.
  refine (spec_ww_mul w_W0 w_add w_mul_c w_mul add w_digits w_to_Z _ _ _ _ _);
  wwauto.
 Qed.

 Let spec_ww_square_c : forall x, [[square_c x]] = [|x|] * [|x|].
 Proof.
  refine (spec_ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add
   add_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_w_div32 : forall a1 a2 a3 b1 b2,
       wB / 2 <= (w_to_Z b1) ->
       [|WW a1 a2|] < [|WW b1 b2|] ->
       let (q, r) := div32 a1 a2 a3 b1 b2 in
       (w_to_Z a1) * wwB + (w_to_Z a2) * wB + (w_to_Z a3) =
       (w_to_Z q) * ((w_to_Z b1)*wB + (w_to_Z b2)) + [|r|] /\
       0 <= [|r|] < (w_to_Z b1)*wB + w_to_Z b2.
 Proof.
  refine (spec_w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c
   w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c w_digits w_to_Z
   _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto.
  unfold w_Bm2, w_to_Z, w_pred, w_Bm1.
  rewrite ZnZ.spec_pred, ZnZ.spec_m1.
  unfold w_digits;rewrite Zmod_small. ring.
  assert (H:= wB_pos(ZnZ.digits)). lia.
  exact ZnZ.spec_div21.
 Qed.

 Let spec_ww_div21 : forall a1 a2 b,
      wwB/2 <= [|b|] ->
      [|a1|] < [|b|] ->
      let (q,r) := div21 a1 a2 b in
      [|a1|] *wwB+ [|a2|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|].
 Proof.
  refine (spec_ww_div21 w_0 w_0W div32 ww_1 compare sub w_digits w_to_Z
   _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_add2: forall x y,
  [|w_add2 x y|] = w_to_Z x + w_to_Z y.
  unfold w_add2.
  intros xh xl; generalize (ZnZ.spec_add_c xh xl).
  unfold w_add_c; case ZnZ.add_c; unfold interp_carry; simpl ww_to_Z.
    intros w0 Hw0; simpl; unfold w_to_Z; rewrite Hw0.
  unfold w_0; rewrite ZnZ.spec_0; simpl; auto with zarith.
  intros w0; rewrite Z.mul_1_l; simpl.
  unfold w_to_Z, w_1; rewrite ZnZ.spec_1; auto with zarith.
  rewrite Z.mul_1_l; auto.
 Qed.

 Let spec_low: forall x,
  w_to_Z (low x) = [|x|] mod wB.
  intros x; case x; simpl low.
    unfold ww_to_Z, w_to_Z, w_0; rewrite ZnZ.spec_0; simpl; wwauto.
  intros xh xl; simpl.
  rewrite Z.add_comm; rewrite Z_mod_plus; auto with zarith.
  rewrite Zmod_small; auto with zarith.
  unfold wB, base; eauto with ZnZ zarith.
  unfold wB, base; eauto with ZnZ zarith.
 Qed.

 Let spec_ww_digits:
  [|_ww_zdigits|] = Zpos (xO w_digits).
 Proof.
 unfold w_to_Z, _ww_zdigits.
 rewrite spec_add2.
 unfold w_to_Z, w_zdigits, w_digits.
 rewrite ZnZ.spec_zdigits; auto.
 rewrite Pos2Z.inj_xO; auto with zarith.
 Qed.

 Let spec_ww_head00  : forall x,  [|x|] = 0 -> [|head0 x|] = Zpos _ww_digits.
 Proof.
 refine (spec_ww_head00 w_0 w_0W
                w_compare w_head0 w_add2 w_zdigits _ww_zdigits
                w_to_Z _ _ _ _ _ _ _ _ ); wwauto.
 exact ZnZ.spec_head00.
 exact ZnZ.spec_zdigits.
 Qed.

 Let spec_ww_head0  : forall x,  0 < [|x|] ->
	 wwB/ 2 <= 2 ^ [|head0 x|] * [|x|] < wwB.
 Proof.
  refine (spec_ww_head0 w_0 w_0W w_compare w_head0
           w_add2 w_zdigits _ww_zdigits
   w_to_Z _ _ _ _ _ _ _);wwauto.
  exact ZnZ.spec_zdigits.
 Qed.

 Let spec_ww_tail00  : forall x,  [|x|] = 0 -> [|tail0 x|] = Zpos _ww_digits.
 Proof.
 refine (spec_ww_tail00 w_0 w_0W
                w_compare w_tail0 w_add2 w_zdigits _ww_zdigits
                w_to_Z _ _ _ _ _ _ _ _); wwauto.
 exact ZnZ.spec_tail00.
 exact ZnZ.spec_zdigits.
 Qed.

 Let spec_ww_tail0  : forall x,  0 < [|x|] ->
  exists y, 0 <= y /\ [|x|] = (2 * y + 1) * 2 ^ [|tail0 x|].
 Proof.
  refine (spec_ww_tail0 (w_digits := w_digits) w_0 w_0W w_compare w_tail0
           w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ _ _ _ _);wwauto.
  exact ZnZ.spec_zdigits.
 Qed.

 Lemma spec_ww_add_mul_div : forall x y p,
       [|p|] <= Zpos _ww_digits ->
       [| add_mul_div p x y |] =
         ([|x|] * (2 ^ [|p|]) +
          [|y|] / (2 ^ ((Zpos _ww_digits) - [|p|]))) mod wwB.
 Proof.
 refine (@spec_ww_add_mul_div t w_0 w_WW w_W0 w_0W compare w_add_mul_div
              sub w_digits w_zdigits low w_to_Z
           _ _ _ _ _ _ _ _ _ _ _);wwauto.
  exact ZnZ.spec_zdigits.
 Qed.

 Let spec_ww_div_gt : forall a b,
      [|a|] > [|b|] -> 0 < [|b|] ->
      let (q,r) := div_gt a b in
      [|a|] = [|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|].
 Proof.
refine
(@spec_ww_div_gt t w_digits w_0 w_WW w_0W w_compare w_eq0
   w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt
   w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z
 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
).
  exact ZnZ.spec_0.
  exact ZnZ.spec_to_Z.
  wwauto.
  wwauto.
  exact ZnZ.spec_compare.
  exact ZnZ.spec_eq0.
  exact ZnZ.spec_opp_c.
  exact ZnZ.spec_opp.
  exact ZnZ.spec_opp_carry.
  exact ZnZ.spec_sub_c.
  exact ZnZ.spec_sub.
  exact ZnZ.spec_sub_carry.
  exact ZnZ.spec_div_gt.
  exact ZnZ.spec_add_mul_div.
  exact ZnZ.spec_head0.
  exact ZnZ.spec_div21.
  exact spec_w_div32.
  exact ZnZ.spec_zdigits.
  exact spec_ww_digits.
  exact spec_ww_1.
  exact spec_ww_add_mul_div.
 Qed.

 Let spec_ww_div : forall a b, 0 < [|b|] ->
      let (q,r) := div a b in
      [|a|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|].
 Proof.
  refine (spec_ww_div w_digits ww_1 compare div_gt w_to_Z _ _ _ _);wwauto.
 Qed.

 Let spec_ww_mod_gt : forall a b,
      [|a|] > [|b|] -> 0 < [|b|] ->
      [|mod_gt a b|] = [|a|] mod [|b|].
 Proof.
  refine (@spec_ww_mod_gt t w_digits w_0 w_WW w_0W w_compare w_eq0
   w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt w_mod_gt
   w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div
   w_zdigits w_to_Z
   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _ _ _);wwauto.
  exact ZnZ.spec_div_gt.
  exact ZnZ.spec_div21.
  exact ZnZ.spec_zdigits.
  exact spec_ww_add_mul_div.
 Qed.

 Let spec_ww_mod :  forall a b, 0 < [|b|] -> [|mod_ a b|] = [|a|] mod [|b|].
 Proof.
  refine (spec_ww_mod w_digits compare mod_gt w_to_Z _ _ _);wwauto.
 Qed.

 Let spec_ww_gcd_gt : forall a b, [|a|] > [|b|] ->
      Zis_gcd [|a|] [|b|] [|gcd_gt a b|].
 Proof.
  refine (@spec_ww_gcd_gt t w_digits w_to_Z _
    w_0 w_eq0 w_gcd_gt
  gcd_gt_fix _ _ _ _ gcd_cont _ _ww_digits _);wwauto.
  refine (@spec_ww_gcd_gt_aux t w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp
   w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0
   w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z
   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _);wwauto.
  exact ZnZ.spec_div21.
  exact ZnZ.spec_zdigits.
  exact spec_ww_add_mul_div.
  refine (@spec_gcd_cont t w_digits ww_1 w_to_Z _ _ w_1 w_compare
   _ _);wwauto.
 Qed.

 Let spec_ww_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|].
 Proof.
  refine (@spec_ww_gcd t w_digits compare w_to_Z _ _ w_0 w_eq0 w_gcd_gt
  gcd_gt_fix _ _ _ _ gcd_cont _ _ww_digits _);wwauto.
  refine (@spec_ww_gcd_gt_aux t w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp
   w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0
   w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z
   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _);wwauto.
  exact ZnZ.spec_div21.
  exact ZnZ.spec_zdigits.
  exact spec_ww_add_mul_div.
  refine (@spec_gcd_cont t w_digits ww_1 w_to_Z _ _ w_1 w_compare
   _ _);wwauto.
 Qed.

 Let spec_ww_is_even : forall x,
      match is_even x with
         true => [|x|] mod 2 = 0
      | false => [|x|] mod 2 = 1
      end.
 Proof.
 refine (@spec_ww_is_even t w_is_even w_digits _ _ ).
 exact ZnZ.spec_is_even.
 Qed.

 Let spec_ww_sqrt2 : forall x y,
       wwB/ 4 <= [|x|] ->
       let (s,r) := sqrt2 x y in
          [[WW x y]] = [|s|] ^ 2 + [+|r|] /\
          [+|r|] <= 2 * [|s|].
 Proof.
 intros x y H.
 refine (@spec_ww_sqrt2 t w_is_even w_compare w_0 w_1 w_Bm1
               w_0W w_sub w_square_c w_div21 w_add_mul_div w_digits w_zdigits
               _ww_zdigits
               w_add_c w_sqrt2 w_pred pred_c pred add_c add sub_c add_mul_div
                _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto.
 exact ZnZ.spec_zdigits.
 exact ZnZ.spec_more_than_1_digit.
 exact ZnZ.spec_is_even.
 exact ZnZ.spec_div21.
 exact spec_ww_add_mul_div.
 exact ZnZ.spec_sqrt2.
 Qed.

 Let spec_ww_sqrt : forall x,
       [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2.
 Proof.
 refine (@spec_ww_sqrt t w_is_even w_0 w_1 w_Bm1
           w_sub w_add_mul_div w_digits w_zdigits _ww_zdigits
               w_sqrt2 pred add_mul_div head0 compare
            _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto.
 exact ZnZ.spec_zdigits.
 exact ZnZ.spec_more_than_1_digit.
 exact ZnZ.spec_is_even.
 exact spec_ww_add_mul_div.
 exact ZnZ.spec_sqrt2.
 Qed.

 Let wB_pos : 0 < wB.
 Proof.
 unfold wB, base; apply Z.pow_pos_nonneg; auto with zarith.
 Qed.

 Hint Transparent ww_to_Z : core.

 Let ww_testbit_high n x y : Z.pos w_digits <= n ->
  Z.testbit [|WW x y|] n =
  Z.testbit (ZnZ.to_Z x) (n - Z.pos w_digits).
 Proof.
  intros Hn.
  assert (E : ZnZ.to_Z x = [|WW x y|] / wB).
  { simpl.
    rewrite Z.div_add_l; eauto with ZnZ zarith.
    now rewrite Z.div_small, Z.add_0_r; wwauto. }
  rewrite E.
  unfold wB, base. rewrite Z.div_pow2_bits.
  - f_equal; auto with zarith.
  - easy.
  - auto with zarith.
 Qed.

 Let ww_testbit_low n x y : 0 <= n < Z.pos w_digits ->
  Z.testbit [|WW x y|] n = Z.testbit (ZnZ.to_Z y) n.
 Proof.
  intros (Hn,Hn').
  assert (E : ZnZ.to_Z y = [|WW x y|] mod wB).
  { simpl; symmetry.
    rewrite Z.add_comm, Z.mod_add; auto with zarith nocore.
    apply Z.mod_small; eauto with ZnZ zarith. }
  rewrite E.
  unfold wB, base. symmetry. apply Z.mod_pow2_bits_low; auto.
 Qed.

 Let spec_lor x y : [|lor x y|] = Z.lor [|x|] [|y|].
 Proof.
  destruct x as [ |hx lx]. trivial.
  destruct y as [ |hy ly]. now rewrite Z.lor_comm.
  change ([|WW (ZnZ.lor hx hy) (ZnZ.lor lx ly)|] =
          Z.lor [|WW hx lx|] [|WW hy ly|]).
  apply Z.bits_inj'; intros n Hn.
  rewrite Z.lor_spec.
  destruct (Z.le_gt_cases (Z.pos w_digits) n) as [LE|GT].
  - now rewrite !ww_testbit_high, ZnZ.spec_lor, Z.lor_spec.
  - rewrite !ww_testbit_low; auto.
    now rewrite ZnZ.spec_lor, Z.lor_spec.
 Qed.

 Let spec_land x y : [|land x y|] = Z.land [|x|] [|y|].
 Proof.
  destruct x as [ |hx lx]. trivial.
  destruct y as [ |hy ly]. now rewrite Z.land_comm.
  change ([|WW (ZnZ.land hx hy) (ZnZ.land lx ly)|] =
          Z.land [|WW hx lx|] [|WW hy ly|]).
  apply Z.bits_inj'; intros n Hn.
  rewrite Z.land_spec.
  destruct (Z.le_gt_cases (Z.pos w_digits) n) as [LE|GT].
  - now rewrite !ww_testbit_high, ZnZ.spec_land, Z.land_spec.
  - rewrite !ww_testbit_low; auto.
    now rewrite ZnZ.spec_land, Z.land_spec.
 Qed.

 Let spec_lxor x y : [|lxor x y|] = Z.lxor [|x|] [|y|].
 Proof.
  destruct x as [ |hx lx]. trivial.
  destruct y as [ |hy ly]. now rewrite Z.lxor_comm.
  change ([|WW (ZnZ.lxor hx hy) (ZnZ.lxor lx ly)|] =
          Z.lxor [|WW hx lx|] [|WW hy ly|]).
  apply Z.bits_inj'; intros n Hn.
  rewrite Z.lxor_spec.
  destruct (Z.le_gt_cases (Z.pos w_digits) n) as [LE|GT].
  - now rewrite !ww_testbit_high, ZnZ.spec_lxor, Z.lxor_spec.
  - rewrite !ww_testbit_low; auto.
    now rewrite ZnZ.spec_lxor, Z.lxor_spec.
 Qed.

 Global Instance mk_zn2z_specs : ZnZ.Specs mk_zn2z_ops.
 Proof.
  apply ZnZ.MkSpecs; auto.
  exact spec_ww_add_mul_div.

  refine (@spec_ww_pos_mod t w_0 w_digits w_zdigits w_WW
           w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z
       _ _ _ _ _ _ _ _ _ _ _ _);wwauto.
  exact ZnZ.spec_zdigits.
  unfold w_to_Z, w_zdigits.
  rewrite ZnZ.spec_zdigits.
  rewrite <- Pos2Z.inj_xO; exact spec_ww_digits.
 Qed.

 Global Instance mk_zn2z_specs_karatsuba : ZnZ.Specs mk_zn2z_ops_karatsuba.
 Proof.
  apply ZnZ.MkSpecs; auto.
  exact spec_ww_add_mul_div.
  refine (@spec_ww_pos_mod t w_0 w_digits w_zdigits w_WW
           w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z
       _ _ _ _ _ _ _ _ _ _ _ _);wwauto.
  exact ZnZ.spec_zdigits.
  unfold w_to_Z, w_zdigits.
  rewrite ZnZ.spec_zdigits.
  rewrite <- Pos2Z.inj_xO; exact spec_ww_digits.
 Qed.

End Z_2nZ.

Section MulAdd.

  Context {t : univ_of_cycles}{ops : ZnZ.Ops t}{specs : ZnZ.Specs ops}.

  Definition mul_add:= w_mul_add ZnZ.zero ZnZ.succ ZnZ.add_c ZnZ.mul_c.

  Notation "[| x |]" := (ZnZ.to_Z x)  (at level 0, x at level 99).

  Notation "[|| x ||]" :=
   (zn2z_to_Z (base ZnZ.digits) ZnZ.to_Z x)  (at level 0, x at level 99).

  Lemma spec_mul_add: forall x y z,
     let (zh, zl) := mul_add x y z in
  [||WW zh zl||] = [|x|] * [|y|] + [|z|].
  Proof.
  intros x y z.
   refine (spec_w_mul_add _ _ _ _ _ _ _ _ _ _ _ _ x y z); auto.
  exact ZnZ.spec_0.
  exact ZnZ.spec_to_Z.
  exact ZnZ.spec_succ.
  exact ZnZ.spec_add_c.
  exact ZnZ.spec_mul_c.
  Qed.

End MulAdd.

(** Modular versions of DoubleCyclic *)

Module DoubleCyclic (C:CyclicType) <: CyclicType.
 Definition t := zn2z C.t.
#[global]
 Instance ops : ZnZ.Ops t := mk_zn2z_ops.
#[global]
 Instance specs : ZnZ.Specs ops := mk_zn2z_specs.
End DoubleCyclic.

Module DoubleCyclicKaratsuba (C:CyclicType) <: CyclicType.
 Definition t := zn2z C.t.
 Definition ops : ZnZ.Ops t := mk_zn2z_ops_karatsuba.
 Definition specs : ZnZ.Specs ops := mk_zn2z_specs_karatsuba.
End DoubleCyclicKaratsuba.


From fae_gtlc_mu.cast_calculus Require Export lang types typing_lemmas.

(** Defines a context of depth 1 *)
Inductive ctx_item :=
  | CTX_Lam
  | CTX_AppL (e2 : expr)
  | CTX_AppR (e1 : expr)
  (* Products *)
  | CTX_PairL (e2 : expr)
  | CTX_PairR (e1 : expr)
  | CTX_Fst
  | CTX_Snd
  (* Sums *)
  | CTX_InjL
  | CTX_InjR
  | CTX_CaseL (e1 : expr) (e2 : expr)
  | CTX_CaseM (e0 : expr) (e2 : expr)
  | CTX_CaseR (e0 : expr) (e1 : expr)
  (* Recursive Types *)
  | CTX_Fold
  | CTX_Unfold
  (* Casts *)
  | CTX_Cast (τi τf : type).

(** Filling in a term in such a context of depth 1 *)
Fixpoint fill_ctx_item (ctx : ctx_item) (e : expr) : expr :=
  match ctx with
  | CTX_Lam => Lam e
  | CTX_AppL e2 => App e e2
  | CTX_AppR e1 => App e1 e
  | CTX_PairL e2 => Pair e e2
  | CTX_PairR e1 => Pair e1 e
  | CTX_Fst => Fst e
  | CTX_Snd => Snd e
  | CTX_InjL => InjL e
  | CTX_InjR => InjR e
  | CTX_CaseL e1 e2 => Case e e1 e2
  | CTX_CaseM e0 e2 => Case e0 e e2
  | CTX_CaseR e0 e1 => Case e0 e1 e
  | CTX_Fold => Fold e
  | CTX_Unfold => Unfold e
  | CTX_Cast τi τf => Cast e τi τf
  end.

(** A general context is now represented by a list of these superficial contexts *)
Definition ctx := list ctx_item.

(** Filling in a term in these general contexts *)
Definition fill_ctx (K : ctx) (e : expr) : expr := foldr fill_ctx_item e K.

(** Typing derivation for contexts of depth 1 *)
Inductive typed_ctx_item : ctx_item → list type → type → list type → type → Prop :=
  | TP_CTX_Lam Γ τ (pτ : Closed τ) τ' :
     typed_ctx_item CTX_Lam (τ :: Γ) τ' Γ (TArrow τ τ')
  | TP_CTX_AppL Γ e2 τ τ' :
     typed Γ e2 τ →
     typed_ctx_item (CTX_AppL e2) Γ (TArrow τ τ') Γ τ'
  | TP_CTX_AppR Γ e1 τ τ' :
     typed Γ e1 (TArrow τ τ') →
     typed_ctx_item (CTX_AppR e1) Γ τ Γ τ'
  | TP_CTX_PairL Γ e2 τ τ' :
     typed Γ e2 τ' →
     typed_ctx_item (CTX_PairL e2) Γ τ Γ (TProd τ τ')
  | TP_CTX_PairR Γ e1 τ τ' :
     typed Γ e1 τ →
     typed_ctx_item (CTX_PairR e1) Γ τ' Γ (TProd τ τ')
  | TP_CTX_Fst Γ τ τ' :
     typed_ctx_item CTX_Fst Γ (TProd τ τ') Γ τ
  | TP_CTX_Snd Γ τ τ' :
     typed_ctx_item CTX_Snd Γ (TProd τ τ') Γ τ'
  | TP_CTX_InjL Γ τ τ' (pτ' : Closed τ') :
     typed_ctx_item CTX_InjL Γ τ Γ (TSum τ τ')
  | TP_CTX_InjR Γ τ (pτ : Closed τ) τ' :
     typed_ctx_item CTX_InjR Γ τ' Γ (TSum τ τ')
  | TP_CTX_CaseL Γ e1 e2 τ1 τ2 τ' :
     typed (τ1 :: Γ) e1 τ' → typed (τ2 :: Γ) e2 τ' →
     typed_ctx_item (CTX_CaseL e1 e2) Γ (TSum τ1 τ2) Γ τ'
  | TP_CTX_CaseM Γ e0 e2 τ1 τ2 τ' :
     typed Γ e0 (TSum τ1 τ2) → typed (τ2 :: Γ) e2 τ' →
     typed_ctx_item (CTX_CaseM e0 e2) (τ1 :: Γ) τ' Γ τ'
  | TP_CTX_CaseR Γ e0 e1 τ1 τ2 τ' :
     typed Γ e0 (TSum τ1 τ2) → typed (τ1 :: Γ) e1 τ' →
     typed_ctx_item (CTX_CaseR e0 e1) (τ2 :: Γ) τ' Γ τ'
  | TP_CTX_Fold Γ τ :
     typed_ctx_item CTX_Fold Γ τ.[(TRec τ)/] Γ (TRec τ)
  | TP_CTX_Unfold Γ τ :
     typed_ctx_item CTX_Unfold Γ (TRec τ) Γ τ.[(TRec τ)/]
  | TP_CTX_Cast Γ τi τf (pτf : Closed τf):
      consistency_open τi τf ->
      typed_ctx_item (CTX_Cast τi τf) Γ τi Γ τf.

(* We don't enforce the hole-type or output-type to be closed *)
(* But we do have that closeness of the hole-type implies closeness of the output type *)
(* We'll only fill in contexts with well-typed terms, so this is sufficient *)

Lemma typed_ctx_item_closedness k Γ τ Γ' τ' :
  Closed τ → typed_ctx_item k Γ τ Γ' τ' → Closed τ'.
Proof.
  intro pτ. destruct 1; try done.
  by apply TArrow_closed.
  by eapply TArrow_closed2.
  eapply TArrow_closed2. by eapply typed_closed.
  apply TProd_closed; auto. by eapply typed_closed.
  apply TProd_closed; auto.
    by eapply typed_closed.
  by eapply TProd_closed1.
  by eapply TProd_closed2.
  by eapply TSum_closed.
  by eapply TSum_closed.
    by eapply typed_closed.
  by apply closed_Fold_typed_help.
  by apply TRec_closed_unfold.
Qed.

Lemma typed_ctx_item_typed k Γ τ Γ' τ' e :
  typed Γ e τ → typed_ctx_item k Γ τ Γ' τ' →
  typed Γ' (fill_ctx_item k e) τ'.
Proof. induction 2; simpl; eauto using typed. Qed.

(** Typing derivation of general contexts *)
Inductive typed_ctx: ctx → list type → type → list type → type → Prop :=
  | TPCTX_nil Γ τ :
     typed_ctx nil Γ τ Γ τ
  | TPCTX_cons Γ1 τ1 Γ2 τ2 Γ3 τ3 k K :
     typed_ctx_item k Γ2 τ2 Γ3 τ3 →
     typed_ctx K Γ1 τ1 Γ2 τ2 →
     typed_ctx (k :: K) Γ1 τ1 Γ3 τ3.

Lemma typed_ctx_closedness K Γ τ Γ' τ' :
  Closed τ → typed_ctx K Γ τ Γ' τ' → Closed τ'.
Proof. induction 2. auto. eauto using typed_ctx_item_closedness. Qed.

Lemma typed_ctx_typed K Γ τ Γ' τ' e :
  typed Γ e τ → typed_ctx K Γ τ Γ' τ' → typed Γ' (fill_ctx K e) τ'.
Proof. induction 2; simpl; eauto using typed_ctx_item_typed. Qed.


Require Export parser.
Require Export refine.

Definition vehicle: IA := parse
"IA [s1,s2,s3,s4] (s1) [start, emrg, far, halt] [pos, reset] []
[s3->(halt)s1, s1->(start)s2, s2->(pos)s3, s3->(far)s2,
s2->(emrg)s4, s3->(emrg)s4, s4->(reset)s1]".

Definition starter: IA := parse
"IA [t1,t2] (t1) [] [start] [] [t1->(start)t2]".

Eval compute in IAutomaton.b_compatible vehicle starter.

Definition vst: IA := IAutomaton.composition vehicle starter.
(*Eval compute in IAutomaton.display vst.
"IA [s1_t2, s3_t2, s4_t2, s1_t1, s2_t2] (s1_t1)
[halt, far, emrg] [reset, pos] [start]
[s1_t1->(start)s2_t2, s2_t2->(emrg)s4_t2, s2_t2->(pos)s3_t2,
s4_t2->(reset)s1_t2, s3_t2->(emrg)s4_t2, s3_t2->(far)s2_t2,
s3_t2->(halt)s1_t2]"*)

(*at m: true*)
Definition vst_m_rep: IA :=
 IAutomaton.hiding
 ( IAutomaton.replacement vst (&"tau") (ASet.GenActs [&"emrg"]) )
 (ASet.GenActs [&"reset",&"pos"]).

Definition vst_m_hid: IA :=
 IAutomaton.hiding vst (ASet.GenActs [&"emrg",&"reset",&"pos"]).

Eval compute in SMENI_refinement vst_m_rep vst_m_hid.

(*at l: true*)
Definition vst_l_rep: IA :=
 IAutomaton.hiding
 ( IAutomaton.replacement vst (&"tau") (ASet.GenActs [&"emrg"]) )
 (ASet.GenActs [&"reset"]).

Definition vst_l_hid: IA :=
 IAutomaton.hiding vst (ASet.GenActs [&"emrg",&"reset"]).

Eval compute in SMENI_refinement vst_l_rep vst_l_hid.


Require Import SystemF.
Require Import Eval.
Require Import Bisimulation.
Require Import List.

Definition Delta :=
  (fun x => match x with
              | O => F 0
              | S n => Unit
            end).

Definition Xi :=
  (fun x => match x with
              | O => Zero
              | S n => One
            end).

Notation "t ~> t'" := (Ev Delta t t') (at level 60).
Notation "t ~>+ t'" := (Evplus Delta t t') (at level 60).
Notation "t ~>* t'" := (Evstar Delta t t') (at level 60).

Notation " a :<: b " := (simulates Delta Xi a b) (at level 90).

Theorem Prog : forall m n l, Derivation Xi [n ; l |= F m @ Xi m] -> Derivation Xi [n ; l |= Delta m @ Xi m].
Proof.
  induction m ; intros n l HF.
  simpl. auto.
  simpl.
  typecheck.
Defined.

Theorem ProgTy : forall m, valid (Xi m) 0.
Proof.
  induction m ; simpl ; auto.
Defined.

(* Example *)
Definition ID1 := (Lam (Abs (TV 0) (V 0))).
Definition ID2 := (Lam (Abs (TV 0) (App (TApp ID1 (TV 0)) (V 0)))).

Lemma ID1_type : Derivation Xi [0 ;nil |= ID1 @ (All (Imp (TV 0) (TV 0)))].
Proof.
  typecheck.
Defined.

Lemma ID2_type : Derivation Xi [0 ;nil |= ID2 @ (All (Imp (TV 0) (TV 0)))].
Proof.
  typecheck.
Defined.

Lemma evalsto : forall t ty, (App (TApp ID1 ty) t) ~>* t.
Proof.
  intros t ty.
  apply compute_eval with (bound:=3).
  compute.
  destruct t ; auto.
  destruct t1 ; auto.
  destruct t ; auto.
Defined.

Ltac termeq_simp :=
  match goal with
    | [ H : Abs _ _ = Lam _ |- _ ] => elimtype False ; inversion H
    | [ H : Lam _ = Abs _ _ |- _ ] => elimtype False ; inversion H
    | [ H : Lam _ = Lam _ |- _ ] => inversion H ; subst ; clear H ; termeq_simp
    | [ H : Abs _ _ = Abs _ _ |- _ ] => inversion H ; subst ; clear H ; termeq_simp
    | [ H : Abs _ _ = _ |- _ ] => progress (simpl in H) ; termeq_simp || idtac
    | [ H : _ = Abs _ _ |- _ ] => progress (simpl in H) ; termeq_simp || idtac
    | [ H : Lam _ = _ |- _ ] => progress (simpl in H) ; termeq_simp || idtac
    | [ H : _ = Lam _ |- _ ] => progress (simpl in H) ; termeq_simp || idtac
    | _ => idtac
  end.

Ltac elimtrans Htrans :=
  let Htrans' := fresh "Htrans" in
    assert (Htrans' := Htrans) ; generalize_eqs Htrans' ; induction Htrans' ; intros ; subst ; termeq_simp ;
      match goal with
        | [
          HD : Derivation Xi (H (ctx _ _) ?e ?ty),
          H : ?e ~>* ?e',
          IH : trans _ _ _ _ _ -> _ = _ -> sigT2 _ _
          |- sigT2 _ _ ] =>
        apply IH ; auto ; apply sym_eq ; apply Value_refl with (Delta:=Delta) (Xi:=Xi) (A:=ty) ; simpl ; auto using Value_Abs, Value_Lam
        | _ => idtac
      end.

Ltac type_dec_simpl :=
  match goal with
    | H : valid ?xty ?n |- context [ valid_dec ?xty ?n ] => case_eq (valid_dec xty n) ; intros ; subst ; simpl ; auto ;
      try (elimtype False ; congruence) ; type_dec_simpl
    | |- context [ ty_eq_dec ?xty ?xty ] => case_eq (ty_eq_dec xty xty) ; intros ; subst ; simpl ; auto ;
      try (elimtype False ; congruence) ; type_dec_simpl
    | _ => idtac
  end.

Ltac typecheck_opaque :=
  let Heq := fresh "Heq" in
    match goal with
      | [ |- Derivation ?Xi (H (ctx ?n ?l) ?t ?ty) ] =>
        cut (typeof Xi n l t = Some ty)  ; [ intro Heq ; apply typeof_has_derivation in Heq; auto |
          simpl ; type_dec_simpl ; auto ]
    end.

Require Import Coq.Logic.JMeq.

Theorem simulates_id1_id2 : (ID1 :<: ID2).
Proof.
  unfold ID1 in *.
  apply simulates_base.
  cut (Derivation Xi [0 ;nil |= (Lam (Abs (TV 0) (V 0))) @ (All (Imp (TV 0) (TV 0)))]) ; [ intros Hid1ty | typecheck ].
  intros a' l Htrans.

  elimtrans Htrans.
  unfold ID2.
  exists (tysubt (Abs (TV 0) (App (TApp ID1 (TV 0)) (V 0))) 0 ty).
  apply trans_tapp with (A:=Imp (TV 0) (TV 0)) ; auto. typecheck.

  apply simulates_base.
  intros a' l Htrans'.
  cut (Derivation Xi [0 ;nil |= Abs ty (V 0) @ (Imp ty ty)]) ; [ intros Hnexty | typecheck_opaque ].

  unfold tysubt in Htrans' ; fold tysubt.
  elimtrans Htrans'. simpl.
  exists (sub (App (TApp (Lam (Abs (TV 0) (V 0))) ty) (V 0)) 0 t2).
  apply trans_app with (B:=ty) ; auto.
  typecheck_opaque.

  apply simulates_base.
  intros a' l Htrans''.

  exists a'. simpl.
  apply trans_next with (t2:=t2).
  apply compute_eval with (bound:=3).
  simpl.
  destruct t2 ; auto. destruct t2_1 ; auto. destruct t2 ; auto. auto.

  apply simulates_refl.
Defined.


(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Cava.Arrow.ArrowExport.

Require Import Coq.Strings.String Coq.Bool.Bvector Coq.Lists.List Coq.NArith.NArith
     Coq.Init.Nat.
Import ListNotations.
Import EqNotations.

Local Open Scope string_scope.

Section notation.
  Import KappaNotation.
  Local Open Scope category_scope.
  Local Open Scope kind_scope.

  Definition unsigned_adder a b c
  : << Vector Bit a, Vector Bit b, Unit >> ~> (Vector Bit c) :=
  <[ \ x y => unsigned_add a b c x y ]>.

  Definition adder3 s1 s2 s3
  : << Vector Bit s1, Vector Bit s2, Vector Bit s3, Unit >> ~> (Vector Bit _) :=
  <[ \ a b c => a + b + c ]>.

  Definition tree_adder a n
  : << Vector (Vector Bit a) (2^n), Unit >> ~> (Vector Bit a) :=
  <[ \ v => !(tree (Vector Bit a) n (unsigned_adder a a a)) v  ]>.

  Lemma max_nn_add_1_is_S_n: forall n, 1 + max n n = S n.
  Proof. intros; rewrite PeanoNat.Nat.max_id; auto. Qed.

  Definition growth_adder n
  : << Vector Bit n, Vector Bit n, Unit >> ~> Vector Bit (S n) :=
  <[ \ a b => typecast (a + b) ]>.

  Definition growth_tree_adder a n
  : << Vector (Vector Bit a) (2^n), Unit >> ~> Vector Bit (n + a) :=
  <[ \ v => !(dt_tree_fold' n a (Vector Bit) (growth_adder)) v  ]>.

  Definition adder445: << Vector Bit 4, Vector Bit 4, Unit >> ~> (Vector Bit 5)
    := unsigned_adder 4 4 5.

  Definition adder88810: << Vector Bit 8, Vector Bit 8, Vector Bit 8, Unit >> ~> (Vector Bit 10)
    := adder3 8 8 8.

  Definition adder444_tree_4: << Vector (Vector Bit 4) 4, Unit >> ~> (Vector Bit 4)
    := tree_adder 4 2.

  Definition adder444_tree_8: << Vector (Vector Bit 4) 8, Unit >> ~> (Vector Bit 4)
    := tree_adder 4 3.

  Definition adder444_tree_64: << Vector (Vector Bit 4) 64, Unit >> ~> (Vector Bit 4)
    := tree_adder 4 6.

  Definition growth_tree_8: << Vector (Vector Bit 4) 8, Unit >> ~> (Vector Bit 7)
    := growth_tree_adder 4 3.
End notation.

Lemma adder445_is_combinational: is_combinational (closure_conversion adder445).
Proof. simply_combinational. Qed.

Lemma adder88810_is_combinational: is_combinational (closure_conversion adder88810).
Proof. simply_combinational. Qed.

Require Import Cava.Netlist.

Definition adder445_interface
  := combinationalInterface "adder445"
     [mkPort "a" (Signal.Vec Signal.Bit 4); mkPort "b" (Signal.Vec Signal.Bit 4)]
     [mkPort "sum" (Signal.Vec Signal.Bit 5)]
     [].
Definition adder88810_interface
  := combinationalInterface "adder88810"
     [mkPort "a" (Signal.Vec Signal.Bit 8); mkPort "b" (Signal.Vec Signal.Bit 8); mkPort "c" (Signal.Vec Signal.Bit 8)]
     [mkPort "sum" (Signal.Vec Signal.Bit 10)]
     [].
Definition adder444_tree_4_interface
  := combinationalInterface "adder444_tree_4"
     [mkPort "vec" (Signal.Vec (Signal.Vec Signal.Bit 4) 4)]
     [mkPort "result" (Signal.Vec Signal.Bit 4)]
     [].
Definition adder444_tree_8_interface
  := combinationalInterface "adder444_tree_8"
     [mkPort "vec" (Signal.Vec (Signal.Vec Signal.Bit 4) 8)]
     [mkPort "result" (Signal.Vec Signal.Bit 4)]
     [].
Definition adder444_tree_64_interface
  := combinationalInterface "adder444_tree_64"
     [mkPort "vec" (Signal.Vec (Signal.Vec Signal.Bit 4) 64)]
     [mkPort "result" (Signal.Vec Signal.Bit 4)]
     [].
Definition growth_tree_8_interface
  := combinationalInterface "growth_tree_8"
     [mkPort "vec" (Signal.Vec (Signal.Vec Signal.Bit 4) 8)]
     [mkPort "result" (Signal.Vec Signal.Bit 7)]
     [].

Definition adder445_netlist :=
  build_netlist (closure_conversion adder445) "adder445" ("a","b") "sum".

Definition adder445_tb_inputs :=
  map (fun '(x, y) => (N2Bv_sized 4 x, N2Bv_sized 4 y))
  [(0, 0); (1, 2); (15, 1); (15, 15)]%N.

Definition adder445_tb_expected_outputs
  := map (fun i => combinational_evaluation (closure_conversion adder445) i) adder445_tb_inputs.

Definition adder445_tb
  := testBench "adder445_tb" adder445_interface
     adder445_tb_inputs adder445_tb_expected_outputs.

Definition adder88810_netlist :=
  build_netlist (closure_conversion adder88810) "adder88810" ("a",("b","c")) "sum".

Definition adder88810_tb_inputs :=
  map (fun '(x, y, z) => (N2Bv_sized 8 x, (N2Bv_sized 8 y, N2Bv_sized 8 z)))
  [(17, 23, 95); (4, 200, 30); (255, 255, 200)]%N.

Definition adder88810_tb_expected_outputs
  := map (fun i => combinational_evaluation (closure_conversion adder88810) i) adder88810_tb_inputs.

Definition adder88810_tb
  := testBench "adder88810_tb" adder88810_interface
     (map (fun '(a,(b,c)) => (a,b,c)) adder88810_tb_inputs) adder88810_tb_expected_outputs.

Definition adder444_tree_4_netlist :=
  build_netlist (closure_conversion adder444_tree_4) "adder444_tree_4" "vec" "result".

Definition adder444_tree_8_netlist :=
  build_netlist (closure_conversion adder444_tree_8) "adder444_tree_8" "vec" "result".

Definition adder444_tree_64_netlist :=
  build_netlist (closure_conversion adder444_tree_64) "adder444_tree_64" "vec" "result".

Definition adder444_tree_4_inputs :=
  map (fun '(x, y, z, w) => [N2Bv_sized 4 x; N2Bv_sized 4 y; N2Bv_sized 4 z; N2Bv_sized 4 w]%vector)
  [(0, 0, 0, 1); (1, 1, 1, 1); (1, 3, 5, 2); (15, 1, 1, 1)]%N.

Lemma adder444_tree_4_is_combinational: is_combinational (closure_conversion adder444_tree_4).
Proof. simply_combinational. Qed.

Definition adder444_tree_4_tb_expected_outputs
  := map (fun i => combinational_evaluation (closure_conversion adder444_tree_4) i) adder444_tree_4_inputs.

Definition adder444_tree_4_tb
  := testBench "adder444_tree_4_tb" adder444_tree_4_interface
     adder444_tree_4_inputs adder444_tree_4_tb_expected_outputs.

Definition growth_tree_8_netlist :=
  build_netlist (closure_conversion growth_tree_8) "growth_tree_8" "vec" "result".

Definition growth_tree_8_inputs :=
  map (Vector.map (N2Bv_sized 4))
  [[0; 0; 0; 0; 0; 0; 0; 1]%vector %N
  ;[1; 1; 1; 1; 1; 1; 1; 1]%vector %N
  ;[1; 2; 3; 4; 5; 6; 7; 8]%vector %N
  ;[15; 15; 15; 15; 15; 15; 15; 15]%vector %N
  ].

Lemma growth_tree_8_is_combinational: is_combinational (closure_conversion growth_tree_8).
Proof. simply_combinational. Qed.

Definition growth_tree_8_tb_expected_outputs
  := map (fun i => combinational_evaluation (closure_conversion growth_tree_8) i) growth_tree_8_inputs.

Definition growth_tree_8_tb
  := testBench "growth_tree_8_tb" growth_tree_8_interface
     growth_tree_8_inputs growth_tree_8_tb_expected_outputs.


Lemma test1 :
forall (v : nat) (f g : nat -> nat),
f v = g v.
intros. f_equal.
(*
Goal in v8.5: f v = g v
Goal in v8.4: v = v -> f v = g v
Expected: f = g
*)
Admitted.

Lemma test2 :
forall (v u : nat) (f g : nat -> nat),
f v = g u.
intros. f_equal.
(*
In both v8.4 And v8.5
Goal 1: v = u -> f v = g u
Goal 2: v = u

Expected Goal 1: f = g
Expected Goal 2: v = u
*)
Admitted.

Lemma test3 :
forall (v : nat) (u : list nat) (f : nat -> nat) (g : list nat -> nat),
f v = g u.
intros. f_equal.
(*
In both v8.4 And v8.5, the goal is unchanged.
*)
Admitted.

Require Import List.
Lemma foo n (l k : list nat) : k ++ skipn n l = skipn n l.
Proof. f_equal.
(*
  8.4: leaves the goal unchanged, i.e. k ++ skipn n l = skipn n l
  8.5: 2 goals, skipn n l = l -> k ++ skipn n l = skipn n l
    and skipn n l = l
*)
Abort.

Require Import List.
Fixpoint replicate {A} (n : nat) (x : A) : list A :=
  match n with 0 => nil | S n => x :: replicate n x end.
Lemma bar {A} n m (x : A) :
  skipn n (replicate m x) = replicate (m - n) x ->
  skipn n (replicate m x) = replicate (m - n) x.
Proof. intros. f_equal.
(* 8.5: one goal, n = m - n *)
Abort.

Variable F : nat -> Set.
Variable X : forall n, F (n + 1).

Definition sequator{X Y: Set}{eq:X=Y}(x:X) : Y := eq_rec _ _ x _ eq.
Definition tequator{X Y}{eq:X=Y}(x:X) : Y := eq_rect _ _ x _ eq.
Polymorphic Definition pequator{X Y}{eq:X=Y}(x:X) : Y := eq_rect _ _ x _ eq.

Goal {n:nat & F (S n)}.
eexists.
unshelve eapply (sequator (X _)).
f_equal. (*behaves*)
Undo 2.
unshelve eapply (pequator (X _)).
f_equal. (*behaves*)
Undo 2.
unshelve eapply (tequator (X _)).
f_equal. (*behaves now *)
Focus 2. exact 0.
simpl.
reflexivity.
Defined.

(* Part 2: modulo casts introduced by refine due to reductions in goals *)

Goal {n:nat & F (S n)}.
eexists.
(*misbehaves, although same goal as above*)
Set Printing All.
unshelve refine (sequator (X _)); revgoals.
2:exact 0. reflexivity.
Undo 3.
unshelve refine (pequator (X _)); revgoals.
f_equal.
Undo 2.
unshelve refine (tequator (X _)); revgoals.
f_equal.
Admitted.

Goal @eq Set nat nat.
congruence.
Qed.

Goal @eq Type nat nat.
congruence.
Qed.

Variable T : Type.

Goal @eq Type T T.
congruence.
Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.Ensembles_ext.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.relation_list.
Require Import CertiGraph.lib.Morphisms_ext.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.path_lemmas. Import CertiGraph.graph.path_lemmas.PathNotation.
Require Import CertiGraph.graph.reachable_ind.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.graph_gen.
Require Import CertiGraph.graph.graph_relation.

Module GraphMorphism.

Section GraphMorphism0.

Context {V V' E E': Type}.
Context {EV: EqDec V eq}.
Context {EE: EqDec E eq}.
Context {EV': EqDec V' eq}.
Context {EE': EqDec E' eq}.

Variables (PV: V -> Prop) (PE: E -> Prop) (vmap: V -> V') (emap: E -> E') (G: PreGraph V E) (G': PreGraph V' E').

Record guarded_morphism: Prop := {
  vvalid_preserved: forall v, PV v -> (vvalid G v <-> vvalid G' (vmap v));
  evalid_preserved: forall e, PE e -> (evalid G e <-> evalid G' (emap e));
  src_preserved: forall e, PE e -> PV (src G e) -> evalid G e ->
                   vmap (src G e) = src G' (emap e);
  dst_preserved: forall e, PE e -> PV (dst G e) -> evalid G e -> vmap (dst G e) = dst G' (emap e)
}.

Record guarded_bij: Prop := {
  vmap_inj: is_guarded_inj PV vmap;
  emap_inj: is_guarded_inj PE emap;
  bij_is_morphism :> guarded_morphism
}.

Lemma guarded_morphsm_evalid:
  guarded_morphism ->
  Included PE (evalid G) ->
  Included (image_set PE emap) (evalid G').
Proof.
  intros.
  unfold Included, Ensembles.In in H0 |- *.
  intros.
  rewrite image_set_spec in H1.
  destruct H1 as [e [? ?]]; subst.
  pose proof evalid_preserved H.
  firstorder.
Qed.

Lemma guarded_morphism_weak_edge_prop:
  guarded_morphism ->
  Included PE (weak_edge_prop PV G) ->
  Included PE (evalid G) ->
  Included (image_set PE emap) (weak_edge_prop (image_set PV vmap) G').
Proof.
  intros.
  unfold Included, Ensembles.In in H0, H1 |- *.
  intros.
  rewrite image_set_spec in H2.
  destruct H2 as [e [? ?]]; subst.
  unfold weak_edge_prop.
  rewrite image_set_spec.
  exists (src G e).
  split.
  + apply H0; auto.
  + symmetry; apply (src_preserved H); auto.
    apply H0; auto.
Qed.

Lemma guarded_morphism_weak'_edge_prop:
  guarded_morphism ->
  Included PE (weak'_edge_prop PV G) ->
  Included PE (evalid G) ->
  Included (image_set PE emap) (weak'_edge_prop (image_set PV vmap) G').
Proof.
  intros.
  unfold Included, Ensembles.In in H0, H1 |- *.
  intros.
  rewrite image_set_spec in H2.
  destruct H2 as [e [? ?]]; subst.
  unfold weak'_edge_prop.
  rewrite image_set_spec.
  exists (dst G e).
  split.
  + apply H0; auto.
  + symmetry; apply (dst_preserved H); auto.
    apply H0; auto.
Qed.

End GraphMorphism0.

Arguments vvalid_preserved {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} g _ _.
Arguments evalid_preserved {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} g _ _.
Arguments src_preserved {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} g _ _ _ _.
Arguments dst_preserved {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} g _ _ _ _.
Arguments vmap_inj {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} g.
Arguments emap_inj {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} g.

Section GraphMorphism1.

Context {V V' E E': Type}.
Context {EV: EqDec V eq}.
Context {EE: EqDec E eq}.
Context {EV': EqDec V' eq}.
Context {EE': EqDec E' eq}.

Lemma guarded_morphism_proper_aux1: forall PV PE vmap emap (G1 G2: PreGraph V E) (G1' G2': PreGraph V' E'),
  guarded_structurally_identical PV PE G1 G2 ->
  guarded_structurally_identical (image_set PV vmap) (image_set PE emap) G1' G2' ->
  guarded_morphism PV PE vmap emap G1 G1' ->
  guarded_morphism PV PE vmap emap G2 G2'.
Proof.
  intros.
  destruct (proj1 (guarded_si_spec _ _ _ _) H) as [? [? [? ?]]].
  destruct (proj1 (guarded_si_spec _ _ _ _) H0) as [? [? [? ?]]].
  assert (forall v : V, PV v -> (vvalid G2 v <-> vvalid G2' (vmap v))).
  1: {
    intros.
    rewrite <- H2 by auto.
    rewrite <- H6 by (constructor; auto).
    apply (vvalid_preserved H1); auto.
  }
  assert (forall e : E, PE e -> (evalid G2 e <-> evalid G2' (emap e))).
  1: {
    intros.
    rewrite <- H3 by auto.
    rewrite <- H7 by (constructor; auto).
    apply (evalid_preserved H1); auto.
  }
  split; auto; intros.
  + assert (evalid G1 e) by (rewrite H3 by auto; auto).
    rewrite <- H8.
    2: constructor; auto.
    2: rewrite <- (evalid_preserved H1), H3 by auto; auto.
    2: rewrite <- H11 by auto; auto.
    rewrite <- H4 by auto.
    apply (src_preserved H1); auto.
    rewrite H4 by auto; auto.
  + assert (evalid G1 e) by (rewrite H3 by auto; auto).
    rewrite <- H9.
    2: constructor; auto.
    2: rewrite <- (evalid_preserved H1), H3 by auto; auto.
    2: rewrite <- H11 by auto; auto.
    rewrite <- H5 by auto.
    apply (dst_preserved H1); auto.
    rewrite H5 by auto; auto.
Qed.

Lemma guarded_morphism_proper_aux2: forall PV PE vmap1 vmap2 emap1 emap2 (G: PreGraph V E) (G': PreGraph V' E'),
  guarded_pointwise_relation PV eq vmap1 vmap2 ->
  guarded_pointwise_relation PE eq emap1 emap2 ->
  guarded_morphism PV PE vmap1 emap1 G G' ->
  guarded_morphism PV PE vmap2 emap2 G G'.
Proof.
  intros.
  rewrite guarded_pointwise_relation_spec in H.
  rewrite guarded_pointwise_relation_spec in H0.
  split; intros.
  + intros.
    rewrite <- H by auto.
    apply (vvalid_preserved H1); auto.
  + intros.
    rewrite <- H0 by auto.
    apply (evalid_preserved H1); auto.
  + rewrite <- H0 by auto.
    rewrite <- H by auto.
    apply (src_preserved H1); auto.
  + rewrite <- H0 by auto.
    rewrite <- H by auto.
    apply (dst_preserved H1); auto.
Qed.

Lemma guarded_morphism_proper_aux3: forall PV1 PV2 PE1 PE2 vmap emap (G: PreGraph V E) (G': PreGraph V' E'),
  Same_set PV1 PV2 ->
  Same_set PE1 PE2 ->
  guarded_morphism PV1 PE1 vmap emap G G' ->
  guarded_morphism PV2 PE2 vmap emap G G'.
Proof.
  intros.
  rewrite Same_set_spec in *.
  split; intros.
  + apply (vvalid_preserved H1), H; auto.
  + apply (evalid_preserved H1), H0; auto.
  + apply (src_preserved H1); auto.
    - apply H0; auto.
    - apply H; auto.
  + apply (dst_preserved H1); auto.
    - apply H0; auto.
    - apply H; auto.
Qed.

Lemma guarded_bij_proper_aux1: forall PV PE vmap emap (G1 G2: PreGraph V E) (G1' G2': PreGraph V' E'),
  guarded_structurally_identical PV PE G1 G2 ->
  guarded_structurally_identical (image_set PV vmap) (image_set PE emap) G1' G2' ->
  guarded_bij PV PE vmap emap G1 G1' ->
  guarded_bij PV PE vmap emap G2 G2'.
Proof.
  intros.
  split; intros.
  + apply (vmap_inj H1); auto.
  + apply (emap_inj H1); auto.
  + eapply guarded_morphism_proper_aux1; eauto.
    apply bij_is_morphism; auto.
Qed.

Lemma guarded_bij_proper_aux2: forall PV PE vmap1 vmap2 emap1 emap2 (G: PreGraph V E) (G': PreGraph V' E'),
  guarded_pointwise_relation PV eq vmap1 vmap2 ->
  guarded_pointwise_relation PE eq emap1 emap2 ->
  guarded_bij PV PE vmap1 emap1 G G' ->
  guarded_bij PV PE vmap2 emap2 G G'.
Proof.
  intros.
  split; intros.
  + rewrite <- H.
    apply (vmap_inj H1); auto.
  + rewrite <- H0.
    apply (emap_inj H1); auto.
  + eapply guarded_morphism_proper_aux2; eauto.
    apply bij_is_morphism; auto.
Qed.

Lemma guarded_bij_proper_aux3: forall PV1 PV2 PE1 PE2 vmap emap (G: PreGraph V E) (G': PreGraph V' E'),
  Same_set PV1 PV2 ->
  Same_set PE1 PE2 ->
  guarded_bij PV1 PE1 vmap emap G G' ->
  guarded_bij PV2 PE2 vmap emap G G'.
Proof.
  intros.
  split; intros.
  + rewrite <- H.
    apply (vmap_inj H1); auto.
  + rewrite <- H0.
    apply (emap_inj H1); auto.
  + eapply guarded_morphism_proper_aux3; eauto.
    apply bij_is_morphism; auto.
Qed.

#[global] Instance guarded_morphism_proper1 (PV: V -> Prop) (PE: E -> Prop) (vmap: V -> V') (emap: E -> E'): Proper (guarded_structurally_identical PV PE ==> guarded_structurally_identical (image_set PV vmap) (image_set PE emap) ==> iff) (guarded_morphism PV PE vmap emap).
Proof.
  intros.
  do 2 (hnf; intros).
  split; apply guarded_morphism_proper_aux1; auto; symmetry; auto.
Defined.

#[global] Instance guarded_morphism_proper2 (PV: V -> Prop) (PE: E -> Prop) : Proper (guarded_pointwise_relation PV eq ==> guarded_pointwise_relation PE eq ==> eq ==> @eq (PreGraph V' E') ==> iff) (guarded_morphism PV PE).
Proof.
  intros.
  do 4 (hnf; intros); subst.
  split; apply guarded_morphism_proper_aux2; auto; symmetry; auto.
Defined.

#[global] Instance guarded_morphism_proper3: Proper (@Same_set V ==> @Same_set E ==> @eq (V -> V') ==> @eq (E -> E') ==> eq ==> eq ==> iff) guarded_morphism.
Proof.
  intros.
  do 6 (hnf; intros).
  subst.
  split; eapply guarded_morphism_proper_aux3; eauto; symmetry; auto.
Defined.

#[global] Instance guarded_bij_proper1 (PV: V -> Prop) (PE: E -> Prop) (vmap: V -> V') (emap: E -> E'): Proper (guarded_structurally_identical PV PE ==> guarded_structurally_identical (image_set PV vmap) (image_set PE emap) ==> iff) (guarded_bij PV PE vmap emap).
Proof.
  intros.
  do 2 (hnf; intros).
  split; apply guarded_bij_proper_aux1; auto; symmetry; auto.
Defined.

#[global] Instance guarded_bij_proper2 (PV: V -> Prop) (PE: E -> Prop) : Proper (guarded_pointwise_relation PV eq ==> guarded_pointwise_relation PE eq ==> eq ==> @eq (PreGraph V' E') ==> iff) (guarded_bij PV PE).
Proof.
  intros.
  do 4 (hnf; intros); subst.
  split; apply guarded_bij_proper_aux2; auto; symmetry; auto.
Defined.

#[global] Instance guarded_bij_proper3: Proper (@Same_set V ==> @Same_set E ==> @eq (V -> V') ==> @eq (E -> E') ==> eq ==> eq ==> iff) guarded_bij.
Proof.
  intros.
  do 6 (hnf; intros).
  subst.
  split; eapply guarded_bij_proper_aux3; eauto; symmetry; auto.
Qed.

Lemma guarded_morphism_step: forall {PV: V -> Prop} {PE: E -> Prop} {vmap emap n m} {g: PreGraph V E} {g': PreGraph V' E'},
  guarded_morphism PV PE vmap emap g g' ->
  Included (Intersection _ (weak_edge_prop PV g) (evalid g)) PE ->
  PV n ->
  PV m ->
  step g n m ->
  step g' (vmap n) (vmap m).
Proof.
  intros.
  rewrite !@step_spec in H3 |- *.
  destruct H3 as [e [? [? ?]]].
  exists (emap e).
  assert (PE e) by
   (apply H0; unfold Ensembles.In; rewrite Intersection_spec; subst; auto).
  split; [| split].
  + eapply (evalid_preserved H); eauto.
  + symmetry; subst; eapply (src_preserved H); eauto.
  + symmetry; subst; eapply (dst_preserved H); eauto.
Qed.

Lemma guarded_morphism_edge: forall {PV: V -> Prop} {PE: E -> Prop} {vmap emap n m} {g: PreGraph V E} {g': PreGraph V' E'},
  guarded_morphism PV PE vmap emap g g' ->
  Included (Intersection _ (weak_edge_prop PV g) (evalid g)) PE ->
  PV n ->
  PV m ->
  edge g n m ->
  edge g' (vmap n) (vmap m).
Proof.
  unfold edge.
  intros.
  destruct H3 as [? [? ?]].
  split; [| split].
  + eapply (vvalid_preserved H); eauto.
  + eapply (vvalid_preserved H); eauto.
  + eapply guarded_morphism_step; eauto.
Qed.

Lemma guarded_morphism_reachable: forall {PV: V -> Prop} {PE: E -> Prop} {vmap emap n m} {g: PreGraph V E} {g': PreGraph V' E'},
  guarded_morphism PV PE vmap emap g g' ->
  Included (Intersection _ (weak_edge_prop PV g) (evalid g)) PE ->
  reachable_by g n PV m ->
  reachable g' (vmap n) (vmap m).
Proof.
  intros.
  rewrite reachable_by_eq_partialgraph_reachable in H1.
  pattern m.
  eapply (@reachable_general_ind V E) with (x := n); [| exact H1 |].
  + intros.
    apply reachable_edge with (vmap x); auto.
    rewrite <- partialgraph_edge_iff in H2.
    destruct H2 as [? [? ?]].
    eapply guarded_morphism_edge; eauto.
  + apply reachable_refl.
    rewrite <- reachable_by_eq_partialgraph_reachable in H1.
    eapply (vvalid_preserved H); eauto.
    - apply reachable_by_head_prop in H1; auto.
    - apply reachable_by_head_valid in H1; auto.
Qed.

End GraphMorphism1.

Lemma disjointed_guard_left_union: forall {V E} (PV1 PV2 PV3: V -> Prop) (PE1 PE2 PE3: E -> Prop),
  disjointed_guard (Union _ PV1 PV2) PV3 (Union _ PE1 PE2) PE3 ->
  disjointed_guard PV1 PV3 PE1 PE3 /\
  disjointed_guard PV2 PV3 PE2 PE3.
Proof.
  intros.
  destruct H.
  rewrite Union_left_Disjoint in H, H0.
  split; split; tauto.
Qed.

Section GraphMorphism2.

Context {V V' E E': Type}.
Context {EV: EqDec V eq}.
Context {EE: EqDec E eq}.
Context {EV': EqDec V' eq}.
Context {EE': EqDec E' eq}.

Definition boundary_src_consistent (PE1: E -> Prop) (PV2: V -> Prop) vmap emap (G: PreGraph V E) (G': PreGraph V' E') :=
  forall e, PE1 e -> PV2 (src G e) -> evalid G e -> vmap (src G e) = src G' (emap e).

Definition boundary_dst_consistent (PE1: E -> Prop) (PV2: V -> Prop) vmap emap (G: PreGraph V E) (G': PreGraph V' E') :=
  forall e, PE1 e -> PV2 (dst G e) -> evalid G e -> vmap (dst G e) = dst G' (emap e).

#[global] Instance boundary_src_consistent_proper: Proper (Same_set ==> Same_set ==> eq ==> eq ==> eq ==> eq ==> iff) boundary_src_consistent.
Proof.
  do 6 (hnf; intros); subst.
  rewrite Same_set_spec in H, H0.
  hnf in H, H0.
  unfold boundary_src_consistent.
  firstorder.
Qed.

#[global] Instance boundary_dst_consistent_proper: Proper (Same_set ==> Same_set ==> eq ==> eq ==> eq ==> eq ==> iff) boundary_dst_consistent.
Proof.
  do 6 (hnf; intros); subst.
  rewrite Same_set_spec in H, H0.
  hnf in H, H0.
  unfold boundary_dst_consistent.
  firstorder.
Qed.

Lemma boundary_dst_consistent_si: forall (PE1: E -> Prop) (PV1 PV2: V -> Prop) vmap emap G G1' G2',
  guarded_morphism PV1 PE1 vmap emap G G1' ->
  guarded_morphism PV1 PE1 vmap emap G G2' ->
  boundary_dst_consistent PE1 PV2 vmap emap G G1' ->
  guarded_structurally_identical (image_set PV1 vmap) (image_set PE1 emap) G1' G2' ->
  boundary_dst_consistent PE1 PV2 vmap emap G G2'.
Proof.
  intros.
  hnf in H |- *.
  intros.
  rewrite (H1 e) by auto; clear H1.
  rewrite guarded_si_spec in H2.
  destruct H2 as [? [? [? ?]]].
  apply H7.
  + constructor; auto.
  + rewrite <- (evalid_preserved H); auto.
  + rewrite <- (evalid_preserved H0); auto.
Qed.

Definition boundary_edge_consistent (PE1: E -> Prop) (PV2: V -> Prop) vmap emap (G: PreGraph V E) (G': PreGraph V' E') :=
  boundary_src_consistent PE1 PV2 vmap emap G G' /\
  boundary_dst_consistent PE1 PV2 vmap emap G G'.

Definition boundary_consistent (PV1 PV2: V -> Prop) (PE1 PE2: E -> Prop) vmap emap (G: PreGraph V E) (G': PreGraph V' E') :=
  boundary_edge_consistent PE1 PV2 vmap emap G G' /\
  boundary_edge_consistent PE2 PV1 vmap emap G G'.

Lemma guarded_bij_vmap_image_dec: forall (PV: V -> Prop) (PE: E -> Prop) vmap emap (G: PreGraph V E) (G': PreGraph V' E'),
  guarded_bij PV PE vmap emap G G' ->
  exists f: forall v, Decidable (image_set PV vmap v), True.
Proof.
  intros.
  pose proof vmap_inj H.
  destruct H0 as [f ?].
  assert (forall v, Decidable (image_set PV vmap v)).
  1: {
    intros.
    specialize (H0 v).
    destruct (f v) eqn:?H; [left | right]; rewrite image_set_spec.
    + exists v0.
      destruct H0; split; auto.
      specialize (H2 _ H0).
      symmetry; apply H2; auto.
    + intros [v0 [? ?]].
      apply (H0 v0 H2).
      symmetry; auto.
  }
  exists X; auto.
Qed.

Lemma guarded_bij_emap_image_dec: forall (PV: V -> Prop) (PE: E -> Prop) vmap emap (G: PreGraph V E) (G': PreGraph V' E'),
  guarded_bij PV PE vmap emap G G' ->
  exists f: forall e, Decidable (image_set PE emap e), True.
Proof.
  intros.
  pose proof emap_inj H.
  destruct H0 as [f ?].
  assert (forall e, Decidable (image_set PE emap e)).
  1: {
    intros.
    specialize (H0 e).
    destruct (f e) eqn:?H; [left | right]; rewrite image_set_spec.
    + exists e0.
      destruct H0; split; auto.
      specialize (H2 _ H0).
      symmetry; apply H2; auto.
    + intros [e0 [? ?]].
      apply (H0 e0 H2).
      symmetry; auto.
  }
  exists X; auto.
Qed.

Lemma guarded_bij_empty_empty: forall vmap emap (G: PreGraph V E) (G': PreGraph V' E'),
  guarded_bij (Empty_set V) (Empty_set E) vmap emap G G'.
Proof.
  intros.
  split; [.. | split].
  + apply is_guarded_inj_empty.
  + apply is_guarded_inj_empty.
  + intros. inversion H.
  + intros. inversion H.
  + intros. inversion H.
  + intros. inversion H.
Qed.

Lemma guarded_morphism_disjointed_union: forall PV1 PE1 PV2 PE2 vmap emap (G: PreGraph V E) (G': PreGraph V' E'),
  guarded_morphism PV1 PE1 vmap emap G G' ->
  guarded_morphism PV2 PE2 vmap emap G G' ->
  boundary_consistent PV1 PV2 PE1 PE2 vmap emap G G' ->
  guarded_morphism (Union _ PV1 PV2) (Union _ PE1 PE2) vmap emap G G'.
Proof.
  intros.
  destruct H1 as [[? ?] [? ?]].
  split; intros.
  + rewrite Union_spec in *.
    destruct H5; [apply (vvalid_preserved H) | apply (vvalid_preserved H0)];
    auto.
  + rewrite Union_spec in *.
    destruct H5; [apply (evalid_preserved H) | apply (evalid_preserved H0)];
    auto.
  + rewrite Union_spec in H5, H6.
    destruct H5, H6;
    [ apply (src_preserved H)
    | apply H1
    | apply H3
    | apply (src_preserved H0)];
    auto.
  + rewrite Union_spec in H5, H6.
    destruct H5, H6;
    [ apply (dst_preserved H)
    | apply H2
    | apply H4
    | apply (dst_preserved H0)];
    auto.
Qed.

Lemma guarded_bij_disjointed_union: forall PV1 PE1 PV2 PE2 vmap emap (G: PreGraph V E) (G': PreGraph V' E'),
  disjointed_guard
    (image_set PV1 vmap) (image_set PV2 vmap)
    (image_set PE1 emap) (image_set PE2 emap) ->
  guarded_bij PV1 PE1 vmap emap G G' ->
  guarded_bij PV2 PE2 vmap emap G G' ->
  boundary_consistent PV1 PV2 PE1 PE2 vmap emap G G' ->
  guarded_bij (Union _ PV1 PV2) (Union _ PE1 PE2) vmap emap G G'.
Proof.
  intros.
  destruct H as [vDISJ eDISJ].
  split; intros.
  + pose proof image_Disjoint_rev _ _  _ vDISJ.
    apply Disjoint_Union_Prop_join in H.
    eapply is_guarded_inj_disjoint_union; eauto.
    - apply (vmap_inj H0); auto.
    - apply (vmap_inj H1); auto.
    - rewrite Disjoint_spec in vDISJ.
      intros v1 v2 ? ? ?.
      apply (vDISJ (vmap v1)).
      * constructor; auto.
      * rewrite H5; constructor; auto.
  + pose proof image_Disjoint_rev _ _  _ eDISJ.
    apply Disjoint_Union_Prop_join in H.
    eapply is_guarded_inj_disjoint_union; eauto.
    - apply (emap_inj H0); auto.
    - apply (emap_inj H1); auto.
    - rewrite Disjoint_spec in eDISJ.
      intros e1 e2 ? ? ?.
      apply (eDISJ (emap e1)).
      * constructor; auto.
      * rewrite H5; constructor; auto.
  + apply guarded_morphism_disjointed_union; auto; apply bij_is_morphism; auto.
Qed.

Lemma guarded_bij_disjointed_weak_edge_prop_union: forall PV1 PV2 vmap emap (G: PreGraph V E) (G': PreGraph V' E'),
  let PE1 := Intersection _ (weak_edge_prop PV1 G) (evalid G) in
  let PE2 := Intersection _ (weak_edge_prop PV2 G) (evalid G) in
  disjointed_guard
    (image_set PV1 vmap) (image_set PV2 vmap)
    (image_set PE1 emap) (image_set PE2 emap) ->
  guarded_bij PV1 PE1 vmap emap G G' ->
  guarded_bij PV2 PE2 vmap emap G G' ->
  boundary_dst_consistent PE1 PV2 vmap emap G G' ->
  boundary_dst_consistent PE2 PV1 vmap emap G G' ->
  guarded_bij (Union _ PV1 PV2) (Union _ PE1 PE2) vmap emap G G'.
Proof.
  intros.
  apply guarded_bij_disjointed_union; auto.
  destruct H.
  assert (Disjoint _ PV1 PV2) by (eapply image_Disjoint_rev; eauto).
  split; split; auto; hnf; intros.
  + rewrite Disjoint_spec in H5.
    unfold PE1, weak_edge_prop in H6; rewrite Intersection_spec in H6.
    pose proof H5 _ (proj1 H6) H7; tauto.
  + rewrite Disjoint_spec in H5.
    unfold PE2, weak_edge_prop in H6; rewrite Intersection_spec in H6.
    pose proof H5 _  H7 (proj1 H6); tauto.
Qed.

Lemma guarded_bij_disjointed_union_strong: forall PV1 PE1 PV2 PE2 vmap emap (G: PreGraph V E) (G1' G2': PreGraph V' E'),
  disjointed_guard
    (image_set PV1 vmap) (image_set PV2 vmap)
    (image_set PE1 emap) (image_set PE2 emap) ->
  guarded_bij PV1 PE1 vmap emap G G1' ->
  guarded_bij PV2 PE2 vmap emap G G2' ->
  boundary_edge_consistent PE1 PV2 vmap emap G G1' ->
  boundary_edge_consistent PE2 PV1 vmap emap G G2' ->
  exists G',
  guarded_bij (Union _ PV1 PV2) (Union _ PE1 PE2) vmap emap G G' /\
  guarded_structurally_identical (image_set PV1 vmap) (image_set PE1 emap) G1' G' /\
  guarded_structurally_identical (image_set PV2 vmap) (image_set PE2 emap) G2' G'.
Proof.
  intros.
  destruct (vmap_inj H0) as [vg1 ?].
  destruct (vmap_inj H1) as [vg2 ?].
  destruct (emap_inj H0) as [eg1 ?].
  destruct (emap_inj H1) as [eg2 ?].
  set (vg := fun v' => match vg1 v' with Some v => Some v | _ => vg2 v' end).
  set (eg := fun e' => match eg1 e' with Some e => Some e | _ => eg2 e' end).
  exists
   (@Build_PreGraph V' E' _ _
    (fun v' => match vg1 v' with Some _ => vvalid G1' v' | _ => vvalid G2' v' end)
    (fun e' => match eg1 e' with Some _ => evalid G1' e' | _ => evalid G2' e' end)
    (fun e' => match eg1 e' with Some _ => src G1' e' | _ => src G2' e' end)
    (fun e' => match eg1 e' with Some _ => dst G1' e' | _ => dst G2' e' end)).
  split; [| split].
  + split; [.. | split].
    - eapply is_guarded_inj_disjoint_union.
      * apply Disjoint_Union_Prop_join.
        clear - H; destruct H.
        apply image_Disjoint_rev in H; auto.
      * apply (vmap_inj H0).
      * apply (vmap_inj H1).
      * clear - H; destruct H.
        rewrite Disjoint_spec in H.
        intros.
        pose proof (H (vmap a1)).
        intro.
        rewrite !image_set_spec in H3.
        spec H3; [exists a1; auto |].
        spec H3; [exists a2; auto |].
        auto.
    - eapply is_guarded_inj_disjoint_union.
      * apply Disjoint_Union_Prop_join.
        clear - H; destruct H.
        apply image_Disjoint_rev in H0; auto.
      * apply (emap_inj H0).
      * apply (emap_inj H1).
      * clear - H; destruct H.
        rewrite Disjoint_spec in H0.
        intros.
        pose proof (H0 (emap a1)).
        intro.
        rewrite !image_set_spec in H3.
        spec H3; [exists a1; auto |].
        spec H3; [exists a2; auto |].
        auto.
    - simpl; intros.
      rewrite Union_spec in H8; destruct H8.
      * rewrite (is_guarded_inj_rev_aux PV1 vmap vg1) by auto.
        apply (vvalid_preserved H0); auto.
      * destruct H.
        rewrite (is_guarded_inj_rev_aux' PV1 PV2 vmap vg1) by auto.
        apply (vvalid_preserved H1); auto.
    - simpl; intros.
      rewrite Union_spec in H8; destruct H8.
      * rewrite (is_guarded_inj_rev_aux PE1 emap eg1) by auto.
        apply (evalid_preserved H0); auto.
      * destruct H.
        rewrite (is_guarded_inj_rev_aux' PE1 PE2 emap eg1) by auto.
        apply (evalid_preserved H1); auto.
    - simpl; intros.
      rewrite Union_spec in H8, H9.
      destruct H8, H9.
      * rewrite (is_guarded_inj_rev_aux PE1 emap eg1) by auto.
        apply (src_preserved H0); auto.
      * rewrite (is_guarded_inj_rev_aux PE1 emap eg1) by auto.
        apply (proj1 H2); auto.
      * rewrite (is_guarded_inj_rev_aux' PE1 PE2 emap eg1) by (destruct H; auto).
        apply (proj1 H3); auto.
      * rewrite (is_guarded_inj_rev_aux' PE1 PE2 emap eg1) by (destruct H; auto).
        apply (src_preserved H1); auto.
    - simpl; intros.
      rewrite Union_spec in H8, H9.
      destruct H8, H9.
      * rewrite (is_guarded_inj_rev_aux PE1 emap eg1) by auto.
        apply (dst_preserved H0); auto.
      * rewrite (is_guarded_inj_rev_aux PE1 emap eg1) by auto.
        apply (proj2 H2); auto.
      * rewrite (is_guarded_inj_rev_aux' PE1 PE2 emap eg1) by (destruct H; auto).
        apply (proj2 H3); auto.
      * rewrite (is_guarded_inj_rev_aux' PE1 PE2 emap eg1) by (destruct H; auto).
        apply (dst_preserved H1); auto.
  + rewrite guarded_si_spec; simpl.
    split; [| split; [| split]].
    - intros v' ?.
      rewrite image_set_spec in H8; destruct H8 as [v [? ?]]; subst v'.
      rewrite (is_guarded_inj_rev_aux PV1 vmap vg1) by auto.
      tauto.
    - intros e' ?.
      rewrite image_set_spec in H8; destruct H8 as [e [? ?]]; subst e'.
      rewrite (is_guarded_inj_rev_aux PE1 emap eg1) by auto.
      tauto.
    - intros e' ? ? ?.
      rewrite image_set_spec in H8; destruct H8 as [e [? ?]]; subst e'.
      rewrite (is_guarded_inj_rev_aux PE1 emap eg1) in H10 |- * by auto.
      auto.
    - intros e' ? ? ?.
      rewrite image_set_spec in H8; destruct H8 as [e [? ?]]; subst e'.
      rewrite (is_guarded_inj_rev_aux PE1 emap eg1) in H10 |- * by auto.
      auto.
  + rewrite guarded_si_spec; simpl.
    split; [| split; [| split]].
    - intros v' ?.
      rewrite image_set_spec in H8; destruct H8 as [v [? ?]]; subst v'.
      rewrite (is_guarded_inj_rev_aux' PV1 PV2 vmap vg1) by (destruct H; auto).
      tauto.
    - intros e' ?.
      rewrite image_set_spec in H8; destruct H8 as [e [? ?]]; subst e'.
      rewrite (is_guarded_inj_rev_aux' PE1 PE2 emap eg1) by (destruct H; auto).
      tauto.
    - intros e' ? ? ?.
      rewrite image_set_spec in H8; destruct H8 as [e [? ?]]; subst e'.
      rewrite (is_guarded_inj_rev_aux' PE1 PE2 emap eg1) by (destruct H; auto).
      auto.
    - intros e' ? ? ?.
      rewrite image_set_spec in H8; destruct H8 as [e [? ?]]; subst e'.
      rewrite (is_guarded_inj_rev_aux' PE1 PE2 emap eg1) by (destruct H; auto).
      auto.
Qed.

Lemma guarded_bij_pregraph_join: forall PV1 PE1 PV2 PE2 vmap emap (G: PreGraph V E) (G1' G2': PreGraph V' E'),
  disjointed_guard
    (image_set PV1 vmap) (image_set PV2 vmap)
    (image_set PE1 emap) (image_set PE2 emap) ->
  guarded_bij PV1 PE1 vmap emap G G1' ->
  guarded_bij PV2 PE2 vmap emap G G2' ->
  boundary_edge_consistent PE1 PV2 vmap emap G G1' ->
  boundary_edge_consistent PE2 PV1 vmap emap G G2' ->
  Same_set (vvalid G1') (image_set PV1 vmap) ->
  Same_set (evalid G1') (image_set PE1 emap) ->
  Same_set (vvalid G2') (image_set PV2 vmap) ->
  Same_set (evalid G2') (image_set PE2 emap) ->
  exists G',
  guarded_bij (Union _ PV1 PV2) (Union _ PE1 PE2) vmap emap G G' /\
  pregraph_join (image_set PV2 vmap) (image_set PE2 emap) G1' G' /\
  pregraph_join (image_set PV1 vmap) (image_set PE1 emap) G2' G'.
Proof.
  intros.
  rename H4 into Hv1, H5 into He1, H6 into Hv2, H7 into He2.
  destruct (vmap_inj H0) as [vg1 ?].
  destruct (vmap_inj H1) as [vg2 ?].
  destruct (emap_inj H0) as [eg1 ?].
  destruct (emap_inj H1) as [eg2 ?].
  set (vg := fun v' => match vg1 v' with Some v => Some v | _ => vg2 v' end).
  set (eg := fun e' => match eg1 e' with Some e => Some e | _ => eg2 e' end).
  exists
   (@Build_PreGraph V' E' _ _
    (fun v' => match vg1 v' with Some _ => vvalid G1' v' | _ => vvalid G2' v' end)
    (fun e' => match eg1 e' with Some _ => evalid G1' e' | _ => evalid G2' e' end)
    (fun e' => match eg1 e' with Some _ => src G1' e' | _ => src G2' e' end)
    (fun e' => match eg1 e' with Some _ => dst G1' e' | _ => dst G2' e' end)).
  split; [| split].
  + split; [.. | split].
    - eapply is_guarded_inj_disjoint_union.
      * apply Disjoint_Union_Prop_join.
        clear - H; destruct H.
        apply image_Disjoint_rev in H; auto.
      * apply (vmap_inj H0).
      * apply (vmap_inj H1).
      * clear - H; destruct H.
        rewrite Disjoint_spec in H.
        intros.
        pose proof (H (vmap a1)).
        intro.
        rewrite !image_set_spec in H3.
        spec H3; [exists a1; auto |].
        spec H3; [exists a2; auto |].
        auto.
    - eapply is_guarded_inj_disjoint_union.
      * apply Disjoint_Union_Prop_join.
        clear - H; destruct H.
        apply image_Disjoint_rev in H0; auto.
      * apply (emap_inj H0).
      * apply (emap_inj H1).
      * clear - H; destruct H.
        rewrite Disjoint_spec in H0.
        intros.
        pose proof (H0 (emap a1)).
        intro.
        rewrite !image_set_spec in H3.
        spec H3; [exists a1; auto |].
        spec H3; [exists a2; auto |].
        auto.
    - simpl; intros.
      rewrite Union_spec in H8; destruct H8.
      * rewrite (is_guarded_inj_rev_aux PV1 vmap vg1) by auto.
        apply (vvalid_preserved H0); auto.
      * destruct H.
        rewrite (is_guarded_inj_rev_aux' PV1 PV2 vmap vg1) by auto.
        apply (vvalid_preserved H1); auto.
    - simpl; intros.
      rewrite Union_spec in H8; destruct H8.
      * rewrite (is_guarded_inj_rev_aux PE1 emap eg1) by auto.
        apply (evalid_preserved H0); auto.
      * destruct H.
        rewrite (is_guarded_inj_rev_aux' PE1 PE2 emap eg1) by auto.
        apply (evalid_preserved H1); auto.
    - simpl; intros.
      rewrite Union_spec in H8, H9.
      destruct H8, H9.
      * rewrite (is_guarded_inj_rev_aux PE1 emap eg1) by auto.
        apply (src_preserved H0); auto.
      * rewrite (is_guarded_inj_rev_aux PE1 emap eg1) by auto.
        apply (proj1 H2); auto.
      * rewrite (is_guarded_inj_rev_aux' PE1 PE2 emap eg1) by (destruct H; auto).
        apply (proj1 H3); auto.
      * rewrite (is_guarded_inj_rev_aux' PE1 PE2 emap eg1) by (destruct H; auto).
        apply (src_preserved H1); auto.
    - simpl; intros.
      rewrite Union_spec in H8, H9.
      destruct H8, H9.
      * rewrite (is_guarded_inj_rev_aux PE1 emap eg1) by auto.
        apply (dst_preserved H0); auto.
      * rewrite (is_guarded_inj_rev_aux PE1 emap eg1) by auto.
        apply (proj2 H2); auto.
      * rewrite (is_guarded_inj_rev_aux' PE1 PE2 emap eg1) by (destruct H; auto).
        apply (proj2 H3); auto.
      * rewrite (is_guarded_inj_rev_aux' PE1 PE2 emap eg1) by (destruct H; auto).
        apply (dst_preserved H1); auto.
  + split; [| split; [| split]]; [split | split | |].
    - intro v'; simpl.
      rewrite <- (Hv2 v').
      split; [destruct (vg1 v'); auto |].
      intros [? | ?].
      * rewrite (Hv1 v') in H8.
        rewrite image_set_spec in H8; destruct H8 as [v [? ?]]; subst v'.
        rewrite (is_guarded_inj_rev_aux PV1 vmap vg1) by auto.
        rewrite (Hv1 (vmap v)).
        constructor; auto.
      * rewrite (Hv2 v') in H8.
        rewrite image_set_spec in H8; destruct H8 as [v [? ?]]; subst v'.
        rewrite (is_guarded_inj_rev_aux' PV1 PV2 vmap vg1) by (destruct H; auto).
        rewrite (Hv2 (vmap v)).
        constructor; auto.
    - intros v' ? ?.
      rewrite (Hv1 v') in H8.
      generalize v', H8, H9.
      apply Disjoint_spec.
      destruct H; auto.
    - intro e'; simpl.
      rewrite <- (He2 e').
      split; [destruct (eg1 e'); auto |].
      intros [? | ?].
      * rewrite (He1 e') in H8.
        rewrite image_set_spec in H8; destruct H8 as [e [? ?]]; subst e'.
        rewrite (is_guarded_inj_rev_aux PE1 emap eg1) by auto.
        rewrite (He1 (emap e)).
        constructor; auto.
      * rewrite (He2 e') in H8.
        rewrite image_set_spec in H8; destruct H8 as [e [? ?]]; subst e'.
        rewrite (is_guarded_inj_rev_aux' PE1 PE2 emap eg1) by (destruct H; auto).
        rewrite (He2 (emap e)).
        constructor; auto.
    - intros e' ? ?.
      rewrite (He1 e') in H8.
      generalize e', H8, H9.
      apply Disjoint_spec.
      destruct H; auto.
    - intros e' ? _; simpl.
      rewrite (He1 e') in H8.
      rewrite image_set_spec in H8; destruct H8 as [e [? ?]]; subst e'.
      rewrite (is_guarded_inj_rev_aux PE1 emap eg1) by auto.
      auto.
    - intros e' ? _; simpl.
      rewrite (He1 e') in H8.
      rewrite image_set_spec in H8; destruct H8 as [e [? ?]]; subst e'.
      rewrite (is_guarded_inj_rev_aux PE1 emap eg1) by auto.
      auto.
  + split; [| split; [| split]]; [split | split | |].
    - intro v'; simpl.
      rewrite <- (Hv1 v').
      split; [destruct (vg1 v'); auto |].
      intros [? | ?].
      * rewrite (Hv2 v') in H8.
        rewrite image_set_spec in H8; destruct H8 as [v [? ?]]; subst v'.
        rewrite (is_guarded_inj_rev_aux' PV1 PV2 vmap vg1) by (destruct H; auto).
        rewrite (Hv2 (vmap v)).
        constructor; auto.
      * rewrite (Hv1 v') in H8.
        rewrite image_set_spec in H8; destruct H8 as [v [? ?]]; subst v'.
        rewrite (is_guarded_inj_rev_aux PV1 vmap vg1) by auto.
        rewrite (Hv1 (vmap v)).
        constructor; auto.
    - intros v' ? ?.
      rewrite (Hv2 v') in H8.
      generalize v', H8, H9.
      apply Disjoint_spec, Disjoint_comm.
      destruct H; auto.
    - intro e'; simpl.
      rewrite <- (He1 e').
      split; [destruct (eg1 e'); auto |].
      intros [? | ?].
      * rewrite (He2 e') in H8.
        rewrite image_set_spec in H8; destruct H8 as [e [? ?]]; subst e'.
        rewrite (is_guarded_inj_rev_aux' PE1 PE2 emap eg1) by (destruct H; auto).
        rewrite (He2 (emap e)).
        constructor; auto.
      * rewrite (He1 e') in H8.
        rewrite image_set_spec in H8; destruct H8 as [e [? ?]]; subst e'.
        rewrite (is_guarded_inj_rev_aux PE1 emap eg1) by auto.
        rewrite (He1 (emap e)).
        constructor; auto.
    - intros e' ? ?.
      rewrite (He2 e') in H8.
      generalize e', H8, H9.
      apply Disjoint_spec, Disjoint_comm.
      destruct H; auto.
    - intros e' ? _; simpl.
      rewrite (He2 e') in H8.
      rewrite image_set_spec in H8; destruct H8 as [e [? ?]]; subst e'.
      rewrite (is_guarded_inj_rev_aux' PE1 PE2 emap eg1) by (destruct H; auto).
      auto.
    - intros e' ? _; simpl.
      rewrite (He2 e') in H8.
      rewrite image_set_spec in H8; destruct H8 as [e [? ?]]; subst e'.
      rewrite (is_guarded_inj_rev_aux' PE1 PE2 emap eg1) by (destruct H; auto).
      auto.
Qed.

Lemma guarded_morphism_weaken: forall PV1 PE1 PV2 PE2 vmap emap (G: PreGraph V E) (G': PreGraph V' E'),
  Included PV2 PV1 ->
  Included PE2 PE1 ->
  guarded_morphism PV1 PE1 vmap emap G G' ->
  guarded_morphism PV2 PE2 vmap emap G G'.
Proof.
  intros.
  split; intros.
  + apply (vvalid_preserved H1), H; auto.
  + apply (evalid_preserved H1), H0; auto.
  + apply (src_preserved H1); auto.
    - apply H0; auto.
    - apply H; auto.
  + apply (dst_preserved H1); auto.
    - apply H0; auto.
    - apply H; auto.
Qed.

Lemma guarded_bij_weak_edge_prop: forall PV PE PV0 PE0 vmap emap (G: PreGraph V E) (G': PreGraph V' E'),
  Included PV0 PV ->
  Included PE0 PE ->
  Included PE0 (Intersection _ (weak_edge_prop PV0 G) (evalid G)) ->
  guarded_morphism PV PE vmap emap G G' ->
  forall e',
    (image_set PE0 emap) e' ->
    (Intersection _ (weak_edge_prop (image_set PV0 vmap) G') (evalid G')) e'.
Proof.
  intros.
  rewrite image_set_spec in H3.
  destruct H3 as [e [? ?]].
  subst e'.
  pose proof H1 _ H3.
  unfold Ensembles.In in H4; rewrite Intersection_spec in H4 |- *.
  destruct H4; split.
  + unfold weak_edge_prop.
    rewrite <- (src_preserved H2).
    - constructor; auto.
    - apply H0; auto.
    - apply H; auto.
    - auto.
  + apply (evalid_preserved H2).
    - apply H0; auto.
    - auto.
Qed.

End GraphMorphism2.

End GraphMorphism.

(*
Require Import Coq.Classes.Morphisms.
Definition respectful {A B : Type}
  (R : relation A) (R' : relation B) : relation (A -> B) :=
  Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R').

PRETTY SURPRISING THAT THIS SYNTAX IS LEGAL!!!!!!!!!!!!!!!!!!!!!!!!!!

*)


Parameter A : Type .

Definition eq_A := @eq A.

Goal forall x, eq_A x x.
intros.
reflexivity.
Qed.


Require Import ZArith.
Local Open Scope Z_scope.
Require Import Integers.
Require Import VST.floyd.proofauto.
Require Import compcert.common.Values.
Require Export List. Export ListNotations.
Require Export aes.list_utils.

Definition partially_filled(i n: Z)(f: Z -> int): list val :=
  (map Vint (fill_list i f)) ++ (repeat_op_table (n-i) Vundef id).

Lemma update_partially_filled: forall (i: Z) (f: Z -> int) (l: Z),
  0 <= i < l ->
  upd_Znth i (partially_filled i l f) (Vint (f i))
  = partially_filled (i+1) l f.
Admitted.

Lemma Znth_partially_filled: forall (i j n: Z) (f: Z -> int),
  0 <= i -> i < j -> j <= n ->
  Znth i (partially_filled j n f) = Vint (f i).
Admitted.


(* Order of imports: import proofmode after utils after robinson *)
From Undecidability.FOL Require Import FullSyntax Utils.FriedmanTranslation.
From Undecidability.FOL.Arithmetics Require Import Signature FA Robinson NatModel.

From Undecidability.FOL.Incompleteness Require Import fol_utils qdec.
From Undecidability.FOL.Proofmode Require Import Theories ProofMode.

Require Import Lia.
Require Import String.

Open Scope string_scope.
(** ** Σ1 completeness *)

Section Sigma1.
  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.
  Context {p : peirce}.

  (* #  #*)
  Inductive Σ1 : form -> Prop :=
  | Sigma_exists : forall α, Σ1 α -> Σ1 (∃ α)
  | Sigma_Delta : forall α, Qdec α -> Σ1 α.
  Inductive Π1 : form -> Prop :=
  | Pi_forall : forall α, Π1 α -> Π1 (∀ α)
  | Pi_Delta : forall α, Qdec α -> Π1 α.

  Lemma Σ1_subst φ ρ : Σ1 φ -> Σ1 φ[ρ].
  Proof.
    induction 1 as [α H IH | α H] in ρ |-*.
    - cbn. constructor. apply IH.
    - constructor. apply Qdec_subst, H.
  Qed.

  Lemma Π1_subst φ ρ : Π1 φ -> Π1 φ[ρ].
  Proof.
    induction 1 as [α H IH | α H] in ρ |-*.
    - cbn. constructor. apply IH.
    - constructor. apply Qdec_subst, H.
  Qed.

  Lemma exist_times_Σ1 n φ :
    Σ1 φ -> Σ1 (exist_times n φ).
  Proof.
    intros H. induction n.
    - easy.
    - now constructor.
  Qed.

  Lemma exists_compression_2 φ n : Qdec φ -> bounded (S (S n)) φ -> exists ψ, Qdec ψ /\ bounded (S n) ψ /\ Qeq ⊢ (∃∃φ) ↔ (∃ψ).
  Proof.
    intros HQ Hb.
    exists (∃ ($0 ⧀= $1) ∧ ∃ ($0 ⧀=' $2) ∧ φ[up (up (S >> var))]).
    repeat split.
    { apply (@Qdec_bounded_exists $0), (@Qdec_bounded_exists_comm $1).
      apply Qdec_subst, HQ. }
    { repeat solve_bounds.
      eapply subst_bounded_max; last eassumption.
      intros n' H'.
      destruct n' as [|[|n']]; cbn; unfold "↑"; cbn; constructor; lia. }
    fstart. fsplit.
    - fintros "[x [y H]]". fexists (x ⊕ y).
      fexists x. fsplit.
      { fexists y. fapply ax_refl. }
      fexists y. fsplit.
      { fexists x. fapply ax_refl. }
      asimpl. ctx.
    - fintros "[z [x [Hx [y [Hy H]]]]]".
      fexists x. fexists y.
      asimpl. ctx.
  Qed.

  Lemma exists_compression φ k n : bounded (n + k) φ -> Qdec φ ->
    exists ψ, Qdec ψ /\ bounded (S k) ψ /\ Qeq ⊢ exist_times n φ ↔ ∃ ψ.
  Proof.
    intros Hb HQ. revert Hb. induction n as [|n IH] in k |-*.
    2: destruct n. all: cbn.
    all: intros Hb.
    - exists φ[↑]. repeat split.
      { now apply Qdec_subst. }
      { eapply subst_bounded_max; last apply Hb. intros n H. constructor. lia. }
      fsplit.
      + fintros. fexists zero. ctx.
      + fintros. fdestruct 0. ctx.
    - exists φ. repeat split.
      + assumption.
      + cbn. replace (k - 0) with k by lia. assumption.
      + fsplit; fintros; ctx.
    - destruct (IH (S k)) as (ψ & HQ' & Hb' & H).
      { now replace (S n + S k) with (S (S n) + k) by lia. }
      edestruct (@exists_compression_2 ψ) as (ψ' & HΔψ & Hbψ' & Hψ).
      1-2: eassumption.
      exists ψ'. repeat split; try easy. cbn in H.
      fsplit; fstart.
      + fintros "[x H]".
        fapply Hψ. fexists x.
        apply subst_Weak  with (xi := x..) in H.
        cbn in H. fapply H. ctx.
      + fintros "H". fapply Hψ in "H".
        fdestruct "H" as "[x H]". fexists x.
        apply subst_Weak  with (xi := x..) in H.
        fapply H. ctx.
  Qed.

  Lemma Σ1_exist_times φ : Σ1 φ -> exists n ψ, Qdec ψ /\ φ = exist_times n ψ.
  Proof.
    induction 1 as [φ H (n & ψ & HΔ & Hψ)|φ H].
    - exists (S n), ψ. now rewrite Hψ.
    - now exists 0, φ.
  Qed.

  Lemma bounded_exist_times φ n k : bounded (n + k) φ <-> bounded k (exist_times n φ).
  Proof.
    induction n in k |-*; split.
    - easy.
    - easy.
    - cbn. intros H. constructor. apply IHn. replace (n + S k) with (S n + k) by lia. apply H.
    - cbn. invert_bounds. replace (S (n + k)) with (n + (S k)) by lia. now apply IHn.
  Qed.
End Sigma1.

Section Sigma1.
  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.

  (* Note that we get the equivalence proof intuitionistically, even though the Sigma 1 proof might be classical *)
  Context {p : peirce}.

  (* #  #*)
  Lemma Σ1_compression φ n : bounded n φ -> Σ1 φ -> exists ψ, Qdec ψ /\ bounded (S n) ψ /\ Qeq ⊢I φ ↔ ∃ψ.
  Proof.
    intros Hb (k & ψ & HΔ & ->)%Σ1_exist_times.
    destruct (@exists_compression intu ψ n k) as (ψ' & HΔ' & Hb' & H').
    all: firstorder using bounded_exist_times.
  Qed.
End Sigma1.

Section Sigma1completeness.
  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.

  Existing Instance intu.

  Lemma Σ1_completeness_intu φ : Σ1 φ -> bounded 0 φ -> interp_nat ⊨= φ -> Qeq ⊢ φ.
  Proof.
    enough (forall ρ, Σ1 φ -> bounded 0 φ[ρ] -> interp_nat ⊨= φ[ρ] -> Qeq ⊢ φ[ρ]).
    { intros HΣ Hb Hsat. rewrite <-subst_var. apply H.
      - easy.
      - now rewrite subst_var.
      - intros ρ'. rewrite subst_var. apply Hsat. }
    intros ρ. induction 1 as [φ H IH|φ H] in ρ |-*.
    - cbn. invert_bounds.
      intros Hnat. destruct (Hnat (fun _ => 0)) as [d Hd].
      fexists (num d). rewrite subst_comp. apply IH.
      + rewrite <-subst_comp. eapply subst_bounded_max; last apply H4.
        intros [|n] Hn; last lia. apply num_bound.
      + intros ρ'. rewrite <-subst_comp.
        rewrite sat_single_nat in Hd.
        eapply sat_closed; last apply Hd.
        eapply subst_bounded_max; last apply H4.
        intros [|n] Hn; last lia. apply num_bound.
    - intros Hb Hnat.
      assert (Qdec φ[ρ]) as H'.
      { apply Qdec_subst, H. }
      destruct (H' intu (fun _ => zero)) as [H1|H1].
      { intros _. solve_bounds. }
      + rewrite bounded_0_subst in H1; assumption.
      + eapply soundness in H1. cbn in H1. unfold valid_ctx in H1.
        specialize (H1 _ interp_nat (fun _ => 0) (nat_is_Q_model _)).
        cbn in H1. destruct H1. rewrite bounded_0_subst; auto.
  Qed.

End Sigma1completeness.

Section conservativity.

  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.

  Lemma Σ1_conservativity ϕ :
    Σ1 ϕ -> bounded 0 ϕ -> Qeq ⊢C ϕ -> Qeq ⊢I ϕ.
  Proof.
    intros S1 Hcl Htc.
    destruct (Σ1_compression Hcl S1) as [α (dec_α & b1_α & Hα)].
    assert (bounded 0 (∃ α)) as b0_α by (now solve_bounds).
    eapply IE with (∃ α).
    1: eapply CE2; apply Hα.
    apply Σ1_completeness_intu; auto.
    1: do 2 constructor; auto.
    assert (Qeq ⊢C ∃ α) as H.
    { eapply IE with ϕ; auto.
      apply prv_intu_peirce.
      eapply CE1. apply Hα. }
    apply Fr_cl_to_min, soundness in H.
    refine (let H' := H nat (extend_interp interp_nat _) (fun _ => 0) _ in _).
    cbn in H'; apply H'. clear H H'.
    intros [n Hn].
    destruct (dec_α intu (fun _ => num n)) as [H|H].
    - intro. apply num_bound.
    - exists n. apply soundness in H.
      eapply sat_single_nat.
      erewrite bounded_subst.
      + apply H, nat_is_Q_model.
      + eauto.
      + intros []; [reflexivity|lia].
    - eapply prv_intu_peirce in H.
      apply Fr_cl_to_min, soundness in H.
      refine (let H' := H nat (extend_interp interp_nat _) (fun _ => 0) _ in _).
      cbn in H'. apply H'; clear H H'.
      rewrite <-subst_Fr. apply sat_comp.
      eapply bound_ext with (N:=1).
      3 : apply Hn.
      { now apply bounded_Fr. }
      intros []; [intros _;cbn|lia].
      apply nat_eval_num.
      Unshelve. all: apply nat_sat_Fr_Q.
  Qed.

  Context `{pei : peirce}.

  Lemma Σ1_soundness ϕ :
    Σ1 ϕ -> bounded 0 ϕ -> Qeq ⊢ ϕ -> interp_nat ⊨= ϕ.
  Proof.
    intros HΣ Hb Hϕ. intros ρ.
    destruct pei eqn:H; eapply soundness.
    - apply Σ1_conservativity.
      * congruence.
      * assumption.
      * assumption.
    - apply nat_is_Q_model.
    - apply Hϕ.
    - apply nat_is_Q_model.
  Qed.

End conservativity.

Section Sigma1completeness.
  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.

  Context `{pei : peirce}.

  (* #  #*)
  Theorem Σ1_completeness φ : Σ1 φ -> bounded 0 φ -> interp_nat ⊨= φ -> Qeq ⊢ φ.
  Proof.
    destruct pei; last apply Σ1_completeness_intu.
    enough (forall ρ, Σ1 φ -> bounded 0 φ[ρ] -> interp_nat ⊨= φ[ρ] -> Qeq ⊢C φ[ρ]).
    { intros HΣ Hb Hsat. rewrite <-subst_var. apply H.
      - easy.
      - now rewrite subst_var.
      - intros ρ'. rewrite subst_var. apply Hsat. }
    intros ρ. induction 1 as [φ H IH|φ H] in ρ |-*.
    - cbn. invert_bounds.
      intros Hnat. destruct (Hnat (fun _ => 0)) as [d Hd].
      remember intu as Hintu. (* for proof mode *)
      fexists (num d). rewrite subst_comp. apply IH.
      + rewrite <-subst_comp. eapply subst_bounded_max; last apply H4.
        intros [|n] Hn; last lia. apply num_bound.
      + intros ρ'. rewrite <-subst_comp.
        rewrite sat_single_nat in Hd.
        eapply sat_closed; last apply Hd.
        eapply subst_bounded_max; last apply H4.
        intros [|n] Hn; last lia. apply num_bound.
    - intros Hb Hnat.
      assert (@Qdec φ[ρ]) as H'.
      { apply Qdec_subst, H. }
      destruct (H' class (fun _ => zero)) as [H1|H1].
      { intros _. solve_bounds. }
      all: rewrite bounded_0_subst in H1; try eassumption.
      contradict Hnat.
      apply Σ1_soundness with (rho := fun _ => 0) in H1.
      + cbn in H1. contradict H1. apply H1.
      + constructor. apply Qdec_impl.
        * assumption.
        * apply Qdec_bot.
      + now solve_bounds.
  Qed.

  (* #  #*)
  Theorem Σ1_witness φ : Σ1 φ -> bounded 1 φ -> Qeq ⊢ ∃φ -> exists x, Qeq ⊢ φ[(num x)..].
  Proof.
    intros Hb HΣ Hφ. eapply Σ1_soundness with (rho := fun _ => 0) in Hφ as [x Hx].
    exists x. eapply Σ1_completeness.
    - now apply Σ1_subst.
    - eapply subst_bounded_max; last eassumption.
      intros [|n] H; last lia. apply num_bound.
    - intros ρ. rewrite sat_single_nat in Hx.
      eapply sat_closed; last eassumption.
      eapply subst_bounded_max; last eassumption.
      intros [|n] H; lia + apply num_bound.
    - now constructor.
    - now constructor.
  Qed.

End Sigma1completeness.