(** This file provides an "unbounded" version of the fractional camera whose
elements are in the interval (0,..) instead of (0,1]. *)
From Coq.QArith Require Import Qcanon.
From iris.algebra Require Export cmra.
From iris.algebra Require Import proofmode_classes.
From iris Require Import options.

(** Since the standard (0,1] fractional camera [frac] is used more often, we
define [ufrac] through a [Definition] instead of a [Notation]. That way, Coq
infers the [frac] camera by default when using the [Qp] type. *)
Definition ufrac := Qp.

Section ufrac.
Canonical Structure ufracO := leibnizO ufrac.

Instance ufrac_valid : Valid ufrac := λ x, True.
Instance ufrac_pcore : PCore ufrac := λ _, None.
Instance ufrac_op : Op ufrac := λ x y, (x + y)%Qp.

Lemma ufrac_included (x y : ufrac) : x ≼ y ↔ (x < y)%Qc.
Proof. by rewrite Qp_lt_sum. Qed.

Corollary ufrac_included_weak (x y : ufrac) : x ≼ y → (x ≤ y)%Qc.
Proof. intros ?%ufrac_included. auto using Qclt_le_weak. Qed.

Definition ufrac_ra_mixin : RAMixin ufrac.
Proof. split; try apply _; try done. Qed.
Canonical Structure ufracR := discreteR ufrac ufrac_ra_mixin.

Global Instance ufrac_cmra_discrete : CmraDiscrete ufracR.
Proof. apply discrete_cmra_discrete. Qed.
End ufrac.

Global Instance ufrac_cancelable (q : ufrac) : Cancelable q.
Proof. intros ?????. by apply Qp_eq, (inj (Qcplus q)), (Qp_eq (q+y) (q+z))%Qp. Qed.

Global Instance ufrac_id_free (q : ufrac) : IdFree q.
Proof.
  intros [q0 Hq0] ? EQ%Qp_eq. rewrite -{1}(Qcplus_0_r q) in EQ.
  eapply Qclt_not_eq; first done. by apply (inj (Qcplus q)).
Qed.

Lemma ufrac_op' (q p : ufrac) : (p ⋅ q) = (p + q)%Qp.
Proof. done. Qed.

Global Instance ufrac_is_op (q : ufrac) : IsOp' q (q/2)%Qp (q/2)%Qp.
Proof. by rewrite /IsOp' /IsOp ufrac_op' Qp_div_2. Qed.


(** ** Weak Head Normalisation *)

Require Import core core_axioms fintype fintype_axioms.
Import ScopedNotations.
From Chapter9 Require Export preservation.

Definition E_ {m} (L: tm m -> Prop)  (s : tm m) : Prop :=
  exists v, star step s v /\ L v.

Fixpoint L {m} (A : ty): tm m -> Prop :=
  match A with
  | Base => fun s => exists v, star step s v /\ value v
  | Fun A1 A2 => fun e => match e with
                      | (lam B s) => forall k (xi: fin m -> fin k) v, L A1 v -> E_ (L A2) (subst_tm (scons v (xi >> var_tm)) s)
                      | _ => False
                      end
  end.

Lemma L_ren {m n} s A (xi: fin m -> fin n) :
  L A s -> L A (ren_tm xi s).
Proof.
  revert m n s xi. induction A; eauto; intros m n s xi.
  - intros (?&?&?).
    exists (x⟨xi⟩). split.
    + substify. eauto using mstep_inst.
    + destruct x; eauto.
  - intros.
    destruct s; try contradiction.
    intros k zeta v H''. cbn in H. specialize (H _ (xi >> zeta) _ H'').
    destruct H as (?&?&?).
    exists x. split; eauto. asimpl. eauto.
Qed.

Definition G {m k} (Gamma : ctx m) : (fin m -> tm k)  -> Prop :=
  fun σ => forall (x : fin m), L (Gamma x) (σ x) .

Definition has_ty_sem {m} (Gamma : ctx m) (s: tm m) (A: ty) : Prop :=
  forall k (sigma: fin m -> tm k), G Gamma sigma -> E_ (L A) (subst_tm sigma s).

Lemma val_inclusion {m} A (e: tm m) :
  L A e -> E_ (L A) e.
Proof. intros. unfold E_. exists e. split; eauto. Qed.

Lemma wn_fundamental_lam {m} Gamma (s: tm m) A:
  has_type Gamma s A -> has_ty_sem Gamma s A.
Proof.
  intros C. unfold has_ty_sem, E_. induction C; subst; intros.
  - eauto.
  - apply val_inclusion. asimpl.
    intros m. intros.
    assert (G (S1 .: Gamma) (v .: (sigma >> ren_tm xi))).     { unfold G. intros [|]; cbn; eauto.
      - cbn in *. specialize (H f). now apply L_ren. }
    (* TODO here we don't apply ext_tm because the goal is not an equality. How do we solve this?
     1. waybe write another tactic that does something like
     assert (H: s[sigma] = ?x) by now asimpl.
     rewrite H
     which would take the instantiation as an argument (or somehow infer it maybe with `match Goal with _ |- context[ subst_tm ... ])

    2. don't use simple apply in asimpl' but rather rewrite so that the normal asimpl tactic works here. But then we have the problem that ext_tm is much too general since we can rewrite every substitution with it. Maybe setoid rewriting can do it. We should somehow say that we can only rewrite with ext_tm if the substitution contains something that would be rewritten by renComp' (i.e. the one with funext)
    To do that we could form a predicate on subsitutions P : (nat -> tm) -> Prop
    with constructors for the atomic cases for renComp', renRen', etc. (so <xi> >> [sigma] / [sigma] >> [sigma], etc.)
    and other congruence constructors.
    Then declare a Proper instance to rewrite with ext_tm if the substitution fulfills the predicate.
    This might work but to build the proof of the predicate we probably need typeclasses which will probably lead to pain.

     *)
    (* assert (M[(@var_tm (S k) var_zero) .: sigma >> (ren_tm shift)][v .: xi >> (@var_tm m)] = M[_]) by (now asimpl). *)
    asimpl.
    (* rewrite renComp'_tm. *)
    specialize (IHC _ _ H1).
    destruct (IHC) as (v'&?&?).
    exists v'; split; eauto.
    revert H2.
    unfold funcomp.
    setoid_rewrite rinstInst_tm'. eauto using mstep_inst.
  - destruct (IHC1 _ _  H) as (v1&?&?).
    destruct (IHC2  _ _ H) as (v2&?&?).
    destruct v1; try contradiction.
    cbn in H1.
    destruct (H1 _ id _ H3) as (v&?&?).
    exists v; split; eauto. asimpl.
    enough (star step (app  (lam t v1) v2) v).
    + eapply star_trans.
      eapply mstep_app; eauto. assumption.
    + eapply star_trans.
      * eright. econstructor; eauto. constructor.
      * now asimpl in H4.
Qed.


(** * Initial and terminal categories *)
(** ** Definitions *)
Require InitialTerminalCategory.Core.
Include InitialTerminalCategory.Core.

(** We want to have the following as subdirectories/modules, not at top level.  Unfortunately, namespacing in Coq is kind-of broken (see, e.g., https://coq.inria.fr/bugs/show_bug.cgi?id=3676), so we don't get the ability to rename subfolders by [Including] into other modules. *)
(** ** Functors to and from initial and terminal categories *)
Require InitialTerminalCategory.Functors.
(** ** Natural transformations between functors from initial categories and to terminal categories *)
Require InitialTerminalCategory.NaturalTransformations.
(** ** Pseudounctors from initial and terminal categories *)
Require InitialTerminalCategory.Pseudofunctors.

Require Export InitialTerminalCategory.Notations.


(* week-02_polymorphism.v *)
(* FPP 2020 - YSC3236 2020-2011, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 24 Aug 2020 *)
(* was: *)
(* Version of 23 Aug 2020 *)

(* ********** *)

Require Import Arith Bool.

(* ********** *)

Definition make_pair_v0 : forall (A : Type) (B : Type), A -> B -> A * B :=
  fun A B a b => (a, b).

Definition make_pair_v1 (A : Type) : forall B : Type, A -> B -> A * B :=
  fun B a b => (a, b).

Definition make_pair_v2 (A : Type) (B : Type) : A -> B -> A * B :=
  fun a b => (a, b).

Definition make_pair_v3 (A : Type) (B : Type) (a : A) : B -> A * B :=
  fun b => (a, b).

Definition make_pair_v4 (A : Type) (B : Type) (a : A) (b : B) : A * B :=
  (a, b).

(* ***** *)

Compute (make_pair_v4 nat bool 1 true).
(* = (1, true) : nat * bool *)

Definition dupl (V : Type) (v : V) : V * V :=
  make_pair_v4 V V v v.

(* ********** *)

Inductive polymorphic_binary_tree (V : Type) : Type :=
| PLeaf : V -> polymorphic_binary_tree V
| PNode : polymorphic_binary_tree V -> polymorphic_binary_tree V -> polymorphic_binary_tree V.

Definition test_number_of_leaves (candidate : forall V : Type, polymorphic_binary_tree V -> nat) :=
  (candidate bool (PLeaf bool true) =? 1) &&
  (candidate nat (PNode nat (PLeaf nat 0) (PLeaf nat 1)) =? 2).

Fixpoint number_of_leaves (V : Type) (t : polymorphic_binary_tree V) : nat :=
  match t with
  | PLeaf _ v =>
    1
  | PNode _ t1 t2 =>
    number_of_leaves V t1 + number_of_leaves V t2
  end.

Compute (test_number_of_leaves number_of_leaves).

(* ********** *)

Fixpoint eqb_polymorphic_binary_tree (V : Type) (eqb_V : V -> V -> bool) (t1 t2 : polymorphic_binary_tree V) : bool :=
  match t1 with
  | PLeaf _ v1 =>
    match t2 with
    | PLeaf _ v2 =>
      eqb_V v1 v2
    | PNode _ t11 t12 =>
      false
    end
  | PNode _ t11 t12 =>
    match t2 with
    | PLeaf _ v2 =>
      false
    | PNode _ t21 t22 =>
      eqb_polymorphic_binary_tree V eqb_V t11 t21
      &&
      eqb_polymorphic_binary_tree V eqb_V t12 t22
    end
  end.

(* ********** *)

Definition eqb_binary_tree_of_nats (t1 t2 : polymorphic_binary_tree nat) : bool :=
  eqb_polymorphic_binary_tree nat beq_nat t1 t2.

(* ********** *)

Inductive option' (V : Type) : Type :=
| Some' : V -> option' V
| None' : option' V.

Print option'.

Set Implicit Arguments.

Inductive option'' (V : Type) : Type :=
| Some'' : V -> option'' V
| None'' : option'' V.

Print option''.

Check (Some 10, Some true).
Check (Some' nat 10, Some' bool true).
Check (Some'' 10, Some'' true).

Check None.
Check None'.
Check None''.
Check (@None nat).
Check (@None' nat).
Check (@None'' nat).

(* ********** *)

(* end of week-02_polymorphism.v *)


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

Set Implicit Arguments.

Require Import DoubleBase DoubleSub DoubleMul DoubleSqrt DoubleLift DoubleDivn1 DoubleDiv.
Require Import CyclicAxioms DoubleCyclic BigN Cyclic31.
Require Import ZArith ZCAux.
Import CyclicAxioms DoubleType DoubleBase.

Theorem Zpos_pos: forall x, 0 < Zpos x.
red; simpl; auto.
Qed.
Hint Resolve Zpos_pos: zarith.

Section Mod_op.

 Variable w : Type.

 Record mod_op : Type := mk_mod_op {
   succ_mod   : w -> w;
   add_mod    : w -> w -> w;
   pred_mod   : w -> w;
   sub_mod    : w -> w -> w;
   mul_mod    : w -> w -> w;
   square_mod : w -> w;
   power_mod  : w -> positive -> w
 }.

 Variable w_op : znz_op w.

 Let w_digits      := w_op.(znz_digits).
 Let w_zdigits     := w_op.(znz_zdigits).
 Let w_to_Z        := w_op.(znz_to_Z).
 Let w_of_pos      := w_op.(znz_of_pos).
 Let w_head0       := w_op.(znz_head0).

 Let w0            := w_op.(znz_0).
 Let w1            := w_op.(znz_1).
 Let wBm1          := w_op.(znz_Bm1).

 Let wWW           := znz_WW w_op.
 Let wW0           := znz_W0 w_op.
 Let w0W           := znz_0W w_op.

 Let w_compare     := w_op.(znz_compare).
 Let w_opp_c       := w_op.(znz_opp_c).
 Let w_opp         := w_op.(znz_opp).
 Let w_opp_carry   := w_op.(znz_opp_carry).

 Let w_succ        := w_op.(znz_succ).
 Let w_succ_c      := w_op.(znz_succ_c).
 Let w_add_c       := w_op.(znz_add_c).
 Let w_add_carry_c := w_op.(znz_add_carry_c).
 Let w_add         := w_op.(znz_add).

 Let w_pred_c      := w_op.(znz_pred_c).
 Let w_sub_c       := w_op.(znz_sub_c).
 Let w_sub_carry   := w_op.(znz_sub_carry).
 Let w_sub_carry_c := w_op.(znz_sub_carry_c).
 Let w_sub         := w_op.(znz_sub).
 Let w_pred        := w_op.(znz_pred).

 Let w_mul_c       := w_op.(znz_mul_c).
 Let w_mul         := w_op.(znz_mul).
 Let w_square_c    := w_op.(znz_square_c).

 Let w_div21       := w_op.(znz_div21).
 Let w_add_mul_div := w_op.(znz_add_mul_div).

 Variable b : w.
    (* b should be > 1 *)
 Let n := w_head0 b.

 Let b2n := w_add_mul_div n b w0.

 Let bm1 := w_sub b w1.

 Let mb := w_opp b.

 Let wwb := WW w0 b.

 Let low x := match x with WW _ x => x | W0 => w0 end.

 Let w_add2 x y := match w_add_c x y with
                     C0 n => WW w0 n
                    |C1 n => WW w1 n
                    end.
 Let ww_zdigits := w_add2 w_zdigits w_zdigits.

 Let ww_compare :=
  Eval lazy beta delta [ww_compare] in ww_compare w0 w_compare.

 Let ww_sub :=
 Eval lazy beta delta [ww_sub] in
   ww_sub w0 wWW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry.

 Let ww_add_mul_div :=
 Eval lazy beta delta [ww_add_mul_div] in
   ww_add_mul_div w0 wWW wW0 w0W
              ww_compare w_add_mul_div
              ww_sub w_zdigits low (w0W n).

 Let ww_lsl_n :=
   Eval lazy beta delta [ww_add_mul_div] in
    fun ww => ww_add_mul_div  ww W0.

 Let w_lsr_n w :=
     w_add_mul_div (w_sub w_zdigits n) w0 w.

 Open Scope Z_scope.
 Notation "[| x |]" :=
   (znz_to_Z w_op x)  (at level 0, x at level 99).

Notation "[[ x ]]" :=
   (ww_to_Z w_digits w_to_Z x)  (at level 0, x at level 99).

 Section Mod_spec.

   Variable m_op : mod_op.

   Record mod_spec : Prop := mk_mod_spec {
      succ_mod_spec     :
                forall w t, [|w|]= t mod [|b|] ->
                          [|succ_mod m_op w|] = ([|w|] + 1) mod [|b|];
      add_mod_spec      :
            forall w1 w2 t1 t2, [|w1|]= t1 mod [|b|] -> [|w2|]= t2 mod [|b|] ->
                          [|add_mod m_op w1 w2|] = ([|w1|] + [|w2|]) mod [|b|];
      pred_mod_spec     :
                forall w t, [|w|]= t mod [|b|] ->
                          [|pred_mod m_op w|] = ([|w|] - 1) mod [|b|];
      sub_mod_spec      :
            forall w1 w2 t1 t2, [|w1|]= t1 mod [|b|] -> [|w2|]= t2 mod [|b|] ->
                          [|sub_mod m_op w1 w2|] = ([|w1|] - [|w2|]) mod [|b|];
      mul_mod_spec      :
            forall w1 w2 t1 t2, [|w1|]= t1 mod [|b|] -> [|w2|]= t2 mod [|b|] ->
                          [|mul_mod m_op w1 w2|] = ([|w1|] * [|w2|]) mod [|b|];
      square_mod_spec   :
                forall w t, [|w|]= t mod [|b|] ->
                          [|square_mod m_op w|] = ([|w|] * [|w|]) mod [|b|];
      power_mod_spec    :
              forall w t p, [|w|]= t mod [|b|] ->
                          [|power_mod m_op w p|] = (Zpower_pos [|w|] p) mod [|b|]
(*
      shift_spec        :
              forall w p, wf w ->
                          [|shift m_op w p|] = ([|w|] / (Zpower_pos 2 p)) mod [|b|];
      trunc_spec        :
              forall w p, wf w ->
                          [|power_mod m_op w p|] = ([|w1|] mod (Zpower_pos 2 p)) mod [|b|]
*)
    }.

  End Mod_spec.

 Hypothesis b_pos: 1 < [|b|].
 Variable op_spec: znz_spec w_op.

 Lemma Zpower_n: 0 < 2 ^ [|n|].
 apply Zpower_gt_0; auto with zarith.
 case (spec_to_Z op_spec n); auto with zarith.
 Qed.

 Hint Resolve Zpower_n Zmult_lt_0_compat Zpower_gt_0.

 Variable m_op : mod_op.

 Hint Rewrite
    (spec_0 op_spec)
    (spec_1 op_spec)
    (spec_Bm1 op_spec)
    (spec_WW op_spec)
    (spec_opp_c op_spec)
    (spec_opp op_spec)
    (spec_opp_carry op_spec)
    (spec_succ_c op_spec)
    (spec_add_c op_spec)
    (spec_add_carry_c op_spec)
    (spec_add op_spec)
    (spec_pred_c op_spec)
    (spec_sub_c op_spec)
    (spec_sub_carry_c op_spec)
    (spec_sub op_spec)
    (spec_mul_c op_spec)
    (spec_mul op_spec)
    : w_rewrite.

 Let _succ_mod x :=
  let res :=w_succ x in
  match w_compare res b with
  | Lt => res
  | _ => w0
  end.

 Let split x :=
  match x with
  | W0 => (w0,w0)
  | WW h l => (h,l)
  end.

 Let _w0_is_0: [|w0|] = 0.
 unfold znz_to_Z; rewrite <- (spec_0 op_spec); auto.
 Qed.

 Let _w1_is_1: [|w1|] = 1.
 unfold znz_to_Z; rewrite <- (spec_1 op_spec); auto.
 Qed.

 Theorem Zmod_plus_one: forall a1 b1, 0 < b1 -> (a1 + b1) mod b1 = a1 mod b1.
 intros a1 b1 H; rewrite Zplus_mod; auto with zarith.
 rewrite Z_mod_same; try rewrite Zplus_0_r; auto with zarith.
 apply Zmod_mod; auto.
 Qed.

 Theorem Zmod_minus_one: forall a1 b1, 0 < b1 -> (a1 - b1) mod b1 = a1 mod b1.
 intros a1 b1 H; rewrite Zminus_mod; auto with zarith.
 rewrite Z_mod_same; try rewrite Zminus_0_r; auto with zarith.
 apply Zmod_mod; auto.
 Qed.

 Lemma without_c_b: forall w2, [|w2|] < [|b|] ->
    [|w_succ w2|] = [|w2|] + 1.
 intros w2 H.
 unfold w_succ;rewrite (spec_succ op_spec w2).
 rewrite Zmod_small;auto.
 assert (HH := spec_to_Z op_spec w2).
 assert (HH' := spec_to_Z op_spec b);auto with zarith.
 Qed.

 Lemma _succ_mod_spec: forall w t, [|w|]= t mod [|b|] ->
    [|_succ_mod w|] = ([|w|] + 1) mod [|b|].
 intros w2 t H; unfold _succ_mod, w_compare; simpl.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t [|b|]); auto with zarith.
 match goal with |- context[znz_compare _ ?x ?y] =>
   generalize (spec_compare op_spec x y);
   case (znz_compare w_op x y); autorewrite with w_rewrite
 end; try rewrite _w0_is_0; auto with zarith.
 rewrite without_c_b; auto with zarith.
 intros H1; rewrite H1.
 apply sym_equal; apply Z_mod_same; auto with zarith.
 rewrite without_c_b; auto with zarith.
 intros H1; rewrite Zmod_small; auto with zarith.
 case (spec_to_Z op_spec w2); auto with zarith.
 rewrite without_c_b; auto with zarith.
 Qed.

 Let _add_mod x y :=
  match w_add_c x y with
  | C0 z =>
    match w_compare z b with
    | Lt => z
    | Eq => w0
    | Gt => w_sub z b
    end
  | C1 z => w_add mb z
  end.

 Lemma _add_mod_correct: forall w1 w2, [|w1|] + [|w2|] < 2 * [|b|] ->
     [|_add_mod w1 w2|] = ([|w1|] + [|w2|]) mod [|b|].
 intros w2 w3; unfold _add_mod, w_compare, w_add_c; intros H.
 match goal with |- context[znz_add_c _ ?x ?y] =>
   generalize (spec_add_c op_spec x y); unfold interp_carry;
   case (znz_add_c w_op x y); autorewrite with w_rewrite
 end; auto with zarith.
 intros w4 H2.
 match goal with |- context[znz_compare _ ?x ?y] =>
   generalize (spec_compare op_spec x y); unfold interp_carry;
   case (znz_compare w_op x y); autorewrite with w_rewrite
 end; auto with zarith.
 intros H3; rewrite <- H2; rewrite H3.
 rewrite Z_mod_same; auto with zarith.
 intros H3; rewrite <- H2.
 apply sym_equal; apply Zmod_small; auto with zarith.
 case (spec_to_Z op_spec w4); unfold base; auto with zarith.
 intros H3; rewrite <- H2.
 assert (F1: 0 < [|w4|] - [|b|]); auto with zarith.
 assert (F2: [|w4|] < [|b|] + [|b|]); auto with zarith.
 rewrite (fun x y => Zmod_small (x - y)); auto with zarith.
 rewrite <- (Zmod_minus_one [|w4|]); auto with zarith.
 apply sym_equal; apply Zmod_small; auto with zarith.
 split; auto with zarith.
 apply Zlt_trans with [|b|]; auto with zarith.
 case (spec_to_Z op_spec b); unfold base; auto with zarith.
 rewrite Zmult_1_l; intros w4 H2; rewrite <- H2.
 unfold mb, w_add; rewrite spec_add; auto with zarith.

 assert (F1: [|w4|] < [|b|]).
 assert (F2: base (znz_digits w_op) + [|w4|] < base (znz_digits w_op) + [|b|]);
   auto with zarith.
 rewrite H2.
 apply Zlt_trans with ([|b|] +[|b|]); auto with zarith.
 apply Zplus_lt_compat_r; auto with zarith.
 case (spec_to_Z op_spec b); auto with zarith.
 assert (F2: [|b|] < base (znz_digits w_op) + [|w4|]); auto with zarith.
 apply Zlt_le_trans with (base (znz_digits w_op)); auto with zarith.
 case (spec_to_Z op_spec b); auto with zarith.
 case (spec_to_Z op_spec w4); auto with zarith.
 assert (F3: base (znz_digits w_op) + [|w4|] < [|b|] + [|b|]); auto with zarith.
 rewrite <- (fun x => Zmod_minus_one (base x + [|w4|])); auto with zarith.
 rewrite (fun x y => Zmod_small (x - y)); auto with zarith.
 unfold w_opp;rewrite (spec_opp op_spec b).
 rewrite <- (fun x => Zmod_plus_one (-x)); auto with zarith.
 rewrite (Zmod_small (- [|b|] + base (znz_digits w_op)));auto with zarith.
 2 : assert (HHH := spec_to_Z op_spec b);auto with zarith.
 repeat rewrite Zmod_small; auto with zarith.
 Qed.

 Lemma _add_mod_spec: forall w1 w2 t1 t2, [|w1|] = t1 mod [|b|] -> [|w2|] = t2 mod [|b|] ->
     [|_add_mod w1 w2|] = ([|w1|] + [|w2|]) mod [|b|].
 intros w2 w3 t1 t2 H H1.
 apply _add_mod_correct; auto with zarith.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t1 [|b|]); auto with zarith.
 assert (F': [|w3|] < [|b|]).
 case (Z_mod_lt t2 [|b|]); auto with zarith.
 assert (tmp: forall x, 2 * x = x + x); auto with zarith.
 Qed.

 Let _pred_mod x :=
  match w_compare w0 x with
  | Eq => bm1
  | _ => w_pred x
  end.

 Lemma _pred_mod_spec: forall w t, [|w|] = t mod [|b|] ->
   [|_pred_mod w|] = ([|w|] - 1) mod [|b|].
 intros w2 t H; unfold _pred_mod, w_compare, bm1; simpl.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t [|b|]); auto with zarith.
 match goal with |- context[znz_compare _ ?x ?y] =>
   generalize (spec_compare op_spec x y);
   case (znz_compare w_op x y); autorewrite with w_rewrite
 end; try rewrite _w0_is_0; try rewrite _w1_is_1; auto with zarith.
 intros H1; rewrite <- H1; simpl.
 rewrite <- (Zmod_plus_one (-1)); auto with zarith.
 repeat rewrite Zmod_small; auto with zarith.
 case (spec_to_Z op_spec b); auto with zarith.
 intros H1.
 unfold w_pred;rewrite (spec_pred op_spec).
 assert (HHH := spec_to_Z op_spec b);repeat rewrite Zmod_small;auto with
 zarith.
 intros;assert (HHH := spec_to_Z op_spec w2);auto with zarith.
 Qed.

 Let _sub_mod x y :=
  match w_sub_c x y with
  | C0 z => z
  | C1 z => w_add z b
  end.

 Lemma _sub_mod_spec: forall w1 w2 t1 t2, [|w1|] = t1 mod [|b|] -> [|w2|] = t2 mod [|b|] ->
   [|_sub_mod w1 w2|] = ([|w1|] - [|w2|]) mod [|b|].
 intros w2 w3 t1 t2; unfold _sub_mod, w_compare, w_sub_c; intros H H1.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t1 [|b|]); auto with zarith.
 assert (F': [|w3|] < [|b|]).
 case (Z_mod_lt t2 [|b|]); auto with zarith.
 match goal with |- context[znz_sub_c _ ?x ?y] =>
   generalize (spec_sub_c op_spec x y); unfold interp_carry;
   case (znz_sub_c w_op x y); autorewrite with w_rewrite
 end; auto with zarith.
 intros w4 H2.
 rewrite Zmod_small; auto with zarith.
 split; auto with zarith.
 rewrite <- H2; case (spec_to_Z op_spec w4); auto with zarith.
 apply Zle_lt_trans with [|w2|]; auto with zarith.
 case (spec_to_Z op_spec w3); auto with zarith.
 intros w4 H2; rewrite <- H2.
 unfold w_add; rewrite spec_add; auto with zarith.
 case (spec_to_Z op_spec w4); intros F1 F2.
 assert (F3: 0 <= - 1 *  base (znz_digits w_op) + [|w4|] + [|b|]); auto with zarith.
 rewrite H2.
 case (spec_to_Z op_spec w3); case (spec_to_Z op_spec w2); auto with zarith.
 rewrite <- (fun x => Zmod_minus_one ([|w4|] + x)); auto with zarith.
 rewrite <- (fun x y => Zmod_plus_one (-y + x)); auto with zarith.
 repeat rewrite Zmod_small; auto with zarith.
 case (spec_to_Z op_spec b); auto with zarith.
 Qed.

 Let _mul_mod x y :=
  let xy := w_mul_c x y in
  match ww_compare xy wwb with
  | Lt => snd (split xy)
  | Eq => w0
  | Gt =>
    let xy2n := ww_lsl_n xy in
    let (h,l) := split xy2n in
    let (q,r) := w_div21 h l b2n in
    w_lsr_n r
  end.

 Theorem high_zero:forall x, [[x]] < base w_digits -> [|fst (split x)|] = 0.
  intros x; case x; simpl; auto.
 intros xh xl H; case (Zle_lt_or_eq 0 [|xh|]); auto with zarith.
 case (spec_to_Z op_spec xh); auto with zarith.
 intros H1; contradict H; apply Zle_not_lt.
 assert (HHHH := wB_pos w_digits).
 unfold w_to_Z.
 match goal with |- ?X <= ?Y + ?Z =>
  pattern X at 1; rewrite <- (Zmult_1_l X); auto with zarith;
  apply Zle_trans with Y; auto with zarith
 end.
 case (spec_to_Z op_spec xl); auto with zarith.
 Qed.

 Theorem n_spec: base (znz_digits w_op) / 2 <= 2 ^ [|n|] * [|b|]
                        < base (znz_digits w_op).
 unfold n, w_head0; apply (spec_head0 op_spec); auto with zarith.
 Qed.

 Theorem b2n_spec: [|b2n|] = 2 ^ [|n|] * [|b|].
 unfold b2n, w_add_mul_div; case n_spec; intros Hp Hp1.
 assert (F1: [|n|] < Zpos (znz_digits w_op)).
 case (Zle_or_lt (Zpos (znz_digits w_op)) [|n|]); auto with zarith.
 intros H1; contradict Hp1; apply Zle_not_lt; unfold base.
 apply Zle_trans with (2 ^ [|n|] * 1); auto with zarith.
 rewrite Zmult_1_r; apply Zpower_le_monotone; auto with zarith.
 rewrite (spec_add_mul_div op_spec); auto with zarith.
 rewrite _w0_is_0; rewrite Zdiv_0_l; auto with zarith.
 rewrite Zplus_0_r; rewrite Zmult_comm; apply Zmod_small; auto with zarith.
 Qed.

 Theorem ww_lsl_n_spec: forall w, [[w]] < [|b|] * [|b|] ->
   [[ww_lsl_n w]] = 2 ^ [|n|] * [[w]].
 intros w2 H; unfold ww_lsl_n.
 case n_spec; intros Hp Hp1.
 assert (F0: forall x, 2 * x = x + x); auto with zarith.
 assert (F1: [|n|] < Zpos (znz_digits w_op)).
 case (Zle_or_lt (Zpos (znz_digits w_op)) [|n|]); auto.
 intros H1; contradict Hp1; apply Zle_not_lt; unfold base.
 apply Zle_trans with (2 ^ [|n|] * 1); auto with zarith.
 rewrite Zmult_1_r; apply Zpower_le_monotone; auto with zarith.
 assert (F2: [|n|] < Zpos (xO (znz_digits w_op))).
 rewrite (Zpos_xO (znz_digits w_op)); rewrite F0; auto with zarith.
 pattern [|n|]; rewrite <- Zplus_0_r; auto with zarith.
 apply Zplus_lt_compat; auto with zarith.
 change
  ([[DoubleLift.ww_add_mul_div w0 wWW wW0 w0W
              ww_compare w_add_mul_div
              ww_sub w_zdigits low (w0W n) w2 W0]] = 2 ^ [|n|] * [[w2]]).
 rewrite (DoubleLift.spec_ww_add_mul_div ); auto with zarith.
 2: exact (spec_to_Z op_spec).
 2: refine (spec_ww_to_Z _ _ _); auto.
 2: exact (spec_to_Z op_spec).
 2: exact (spec_WW op_spec).
 2: exact (spec_W0 op_spec).
 2: exact (spec_0W op_spec).
 2: refine (spec_ww_compare _ _ _ _ _ _ _); auto.
 2: exact (spec_to_Z op_spec).
 2: exact (spec_compare op_spec).
 2: exact (spec_add_mul_div op_spec).
 2: refine (spec_ww_sub _ _ _ _ _ _ _ _ _ _
                _ _ _ _ _ _ _ _ _ _ _); auto.
 2: exact (spec_to_Z op_spec).
 2: exact (spec_WW op_spec).
 2: exact (spec_opp_c op_spec).
 2: exact (spec_opp op_spec).
 2: exact (spec_opp_carry op_spec).
 2: exact (spec_sub_c op_spec).
 2: exact (spec_sub op_spec).
 2: exact (spec_sub_carry op_spec).
 2: exact (spec_zdigits op_spec).
 replace ([[w0W n]]) with  [|n|].
 change [[W0]] with 0. rewrite Zdiv_0_l; auto with zarith.
 rewrite Zplus_0_r; rewrite Zmod_small; auto with zarith.
 split; auto with zarith.
 case spec_ww_to_Z with (w_digits := w_digits) (w_to_Z := w_to_Z) (x:=w2); auto with zarith. exact (spec_to_Z op_spec).
 apply Zlt_trans with ([|b|] * [|b|] * 2 ^ [|n|]); auto with zarith.
 apply Zmult_lt_compat_r; auto with zarith.
 rewrite <- Zmult_assoc.
 unfold base; unfold base in Hp.
 unfold ww_digits,w_digits;rewrite (Zpos_xO (znz_digits w_op)); rewrite F0; auto with zarith.
 rewrite Zpower_exp; auto with zarith.
 apply Zmult_lt_compat; auto with zarith.
 case (spec_to_Z op_spec b); auto with zarith.
 split; auto with zarith.
 rewrite Zmult_comm; auto with zarith.
 unfold w_digits;auto with zarith.
 generalize (spec_0W op_spec n).
 unfold ww_to_Z, w_digits; auto.
 intros x; case x; simpl.
 unfold w_to_Z, w_digits, w0; rewrite spec_0; auto.
 intros w3 w4; rewrite Zplus_comm.
 rewrite Z_mod_plus; auto with zarith.
 rewrite Zmod_small; auto with zarith.
 case (spec_to_Z op_spec w4); auto with zarith.
 unfold base; auto with zarith.
 unfold ww_to_Z, w_digits; auto.
 rewrite (spec_0W op_spec); auto with zarith.
 Qed.

 Theorem w_lsr_n_spec: forall w, [|w|] < 2 ^ [|n|] *  [|b|]->
   [|w_lsr_n w|] = [|w|] / 2 ^ [|n|].
 intros w2 H.
 case (spec_to_Z op_spec w2); intros U1 U2.
 unfold w_lsr_n.
 rewrite (spec_add_mul_div op_spec); auto with zarith.
 rewrite _w0_is_0; rewrite Zmult_0_l; auto with zarith.
 rewrite Zplus_0_l.
 rewrite (spec_sub op_spec); auto with zarith.
 rewrite (fun x y => Zmod_small (x - y)); auto with zarith.
 unfold w_zdigits; rewrite (spec_zdigits op_spec).
 assert (tmp: forall p q, p - (p - q) = q); intros; try ring;
  rewrite tmp; clear tmp; auto.
 rewrite Zmod_small; auto with zarith.
 split; auto with zarith.
 apply Zle_lt_trans with (2 := U2); auto with zarith.
 apply Zdiv_le_upper_bound; auto with zarith.
 apply Zle_trans with ([|w2|] * (2 ^ 0)); auto with zarith.
 simpl Zpower; rewrite Zmult_1_r; auto with zarith.
 apply Zmult_le_compat_l; auto with zarith.
 apply Zpower_le_monotone; auto with zarith.
 case (spec_to_Z op_spec n); auto with zarith.
 unfold n.
 assert (HH: 0 < [|b|]); auto with zarith.
 split.
   case (Zle_or_lt [|w_head0 b|] [|w_zdigits|]); auto with zarith.
   unfold w_zdigits; rewrite (spec_zdigits op_spec); intros H1.
   case (spec_head0 op_spec b HH); intros _ H2; contradict H2.
   apply Zle_not_lt; unfold base.
   apply Zle_trans with (2^[|znz_head0 w_op b|] * 1); auto with zarith.
   rewrite Zmult_1_r; apply Zpower_le_monotone; auto with zarith.
 unfold w_zdigits; rewrite (spec_zdigits op_spec).
 apply Zle_lt_trans with (Zpos (znz_digits w_op)); auto with zarith.
    case (spec_to_Z op_spec (w_head0 b)); auto with zarith.
 unfold base; apply Zpower2_lt_lin; auto with zarith.
 rewrite (spec_sub op_spec); auto with zarith.
 rewrite Zmod_small; auto with zarith.
 unfold w_zdigits; rewrite (spec_zdigits op_spec); auto with zarith.
 case (spec_to_Z op_spec n); auto with zarith.
 unfold w_zdigits; rewrite (spec_zdigits op_spec).
 split; auto with zarith.
 case (Zle_or_lt [|n|] (Zpos (znz_digits w_op))); auto with zarith; intros H1.
 case (spec_head0 op_spec b); auto with zarith; intros _ H2.
 contradict H2; apply Zle_not_lt; auto with zarith.
 unfold base; apply Zle_trans with (2 ^ [|znz_head0 w_op b|] * 1);
   auto with zarith.
 rewrite Zmult_1_r; unfold base; apply Zpower_le_monotone; auto with zarith.
 apply Zle_lt_trans with (Zpos (znz_digits w_op)); auto with zarith.
 case (spec_to_Z op_spec n); auto with zarith.
 unfold base; apply Zpower2_lt_lin; auto with zarith.
 Qed.

 Lemma split_correct: forall x, let (xh, xl) := split x in [[WW xh xl]] = [[x]].
 intros x; case x; simpl; unfold w0, w_to_Z;try rewrite (spec_0 op_spec); auto with zarith.
 Qed.

 Lemma _mul_mod_spec: forall w1 w2 t1 t2, [|w1|] = t1 mod [|b|] -> [|w2|] = t2 mod [|b|] ->
   [|_mul_mod w1 w2|] = ([|w1|] * [|w2|]) mod [|b|].
 intros w2 w3 t1 t2 H H1; unfold _mul_mod, wwb.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t1 [|b|]); auto with zarith.
 assert (F': [|w3|] < [|b|]).
 case (Z_mod_lt t2 [|b|]); auto with zarith.
 match goal with |- context[ww_compare ?x ?y] =>
   generalize (@spec_ww_compare w w0 w_digits w_to_Z w_compare
    (spec_0 op_spec) (spec_to_Z op_spec) (spec_compare op_spec)
   x y); simpl ww_to_Z; unfold w_to_Z;
   change (DoubleBase.ww_compare w0 w_compare x y) with (ww_compare x y);
   case (ww_compare x y); autorewrite with w_rewrite
 end; try rewrite _w0_is_0; try rewrite _w1_is_1; auto with zarith.
 unfold w_mul_c, ww_to_Z,w_digits; rewrite spec_mul_c; auto with zarith.
 rewrite Zmult_0_l;rewrite Zplus_0_l;intros H2; rewrite H2; simpl.
 rewrite Z_mod_same; auto with zarith.
 generalize (high_zero (w_mul_c w2 w3)).
 unfold w_mul_c; generalize (spec_mul_c op_spec w2 w3);
  case (znz_mul_c w_op w2 w3); simpl; auto with zarith.
 intros H3 _  _; rewrite <- H3; autorewrite with w_rewrite.
 rewrite Zmod_small; auto with zarith.
 intros w4 w5.
 intros H2 H3 H4.
 assert (E1: [|w4|] = 0).
 apply H3; auto with zarith.
 apply Zlt_trans with (1 := H4).
 case (spec_to_Z op_spec b); auto with zarith.
 generalize H4 H2; rewrite E1; rewrite Zmult_0_l; rewrite Zplus_0_l;
   clear H4 H2; intros H4 H2.
 rewrite <- H2; rewrite Zmod_small; auto with zarith.
 case (spec_to_Z op_spec w5); auto with zarith.
 intros H2.
 match goal with |- context[split ?x] =>
 generalize (split_correct x);
  case (split x); auto with zarith
 end.
 assert (F1: [[w_mul_c w2 w3]] < [|b|] * [|b|]).
 unfold w_to_Z, w_mul_c, ww_to_Z,w_digits;
   rewrite spec_mul_c; auto with zarith.
 apply Zmult_lt_compat; auto with zarith.
 case (spec_to_Z op_spec w2); auto with zarith.
 case (spec_to_Z op_spec w3); auto with zarith.
 intros w4 w5; rewrite ww_lsl_n_spec; auto with zarith.
 intros H3.
 unfold w_div21; match goal with |- context[znz_div21 ?x ?y ?z ?t] =>
   generalize (spec_div21 op_spec y z t);
   case (znz_div21 x y z t)
 end.
 rewrite b2n_spec; case (n_spec); auto.
 intros H4 H5 w6 w7 H6.
 case H6; auto with zarith.
 case (Zle_or_lt (2 ^ [|n|] * [|b|]) [|w4|]); auto; intros H7.
 match type of H3 with ?X = ?Y =>
    absurd (Y < X)
 end.
 apply Zle_not_lt; rewrite H3; auto with zarith.
 simpl ww_to_Z.
 match goal with |- ?X < ?Y + _ =>
    apply Zlt_le_trans with Y; auto with zarith
 end.
 apply Zlt_trans with (2 ^ [|n|] * ([|b|] * [|b|]));
   auto with zarith.
 apply Zmult_lt_compat_l; auto with zarith.
 rewrite Zmult_assoc.
 apply Zmult_lt_compat2; auto with zarith.
 case (spec_to_Z op_spec b); auto with zarith.
 case (spec_to_Z op_spec w5); unfold w_to_Z;auto with zarith.
 clear H6; intros H7 H8.
 rewrite w_lsr_n_spec; auto with zarith.
 rewrite <- (Z_div_mult ([|w2|] * [|w3|]) (2 ^ [|n|]));
  auto with zarith; rewrite Zmult_comm.
 rewrite <- spec_mul_c; auto with zarith.
 unfold w_mul_c in H3; unfold ww_to_Z in H3;simpl H3.
 unfold w_digits,w_to_Z in H3. rewrite <- H3; simpl.
 rewrite H7; rewrite (fun x => Zmult_comm (2 ^ x));
   rewrite Zmult_assoc; rewrite  BigNumPrelude.Z_div_plus_l; auto with zarith.
 rewrite Zplus_mod; auto with zarith.
 rewrite Z_mod_mult; auto with zarith.
 rewrite Zplus_0_l; auto with zarith.
 rewrite Zmod_mod; auto with zarith.
 rewrite Zmod_small; auto with zarith.
 split; auto with zarith.
 apply Zdiv_lt_upper_bound; auto with zarith.
 rewrite Zmult_comm; auto with zarith.
 Qed.

 Let _square_mod x :=
  let x2 := w_square_c x in
  match ww_compare x2 wwb with
  | Lt => snd (split x2)
  | Eq => w0
  | Gt =>
    let x2_2n := ww_lsl_n x2 in
    let (h,l) := split x2_2n in
    let (q,r) := w_div21 h l b2n in
    w_lsr_n r
  end.

 Lemma _square_mod_spec: forall w t, [|w|] = t mod [|b|] ->
    [|_square_mod w|] = ([|w|] * [|w|]) mod [|b|].
 intros w2 t2 H; unfold _square_mod, wwb.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t2 [|b|]); auto with zarith.
 match goal with |- context[ww_compare ?x ?y] =>
   generalize (@spec_ww_compare w w0 w_digits w_to_Z w_compare
    (spec_0 op_spec) (spec_to_Z op_spec) (spec_compare op_spec)
   x y); simpl ww_to_Z; unfold w_to_Z;
   change (DoubleBase.ww_compare w0 w_compare x y) with (ww_compare x y);
   case (ww_compare x y); autorewrite with w_rewrite
 end; try rewrite _w0_is_0; try rewrite _w1_is_1; auto with zarith.
 unfold w_square_c, ww_to_Z,w_digits; rewrite spec_square_c; auto with zarith.
 intros H2;rewrite H2; simpl.
 rewrite Z_mod_same; auto with zarith.
 generalize (high_zero (w_square_c w2)).
 unfold w_square_c; generalize (spec_square_c op_spec w2);
  case (znz_square_c w_op w2); simpl; auto with zarith.
 intros H3 _  _; rewrite <- H3; autorewrite with w_rewrite.
 rewrite Zmod_small; auto with zarith.
 intros w4 w5.
 intros H2 H3 H4.
 assert (E1: [|w4|] = 0).
 apply H3; auto with zarith.
 apply Zlt_trans with (1 := H4).
 case (spec_to_Z op_spec b); auto with zarith.
 generalize H4 H2; rewrite E1; rewrite Zmult_0_l; rewrite Zplus_0_l;
   clear H4 H2; intros H4 H2.
 rewrite <- H2; rewrite Zmod_small; auto with zarith.
 case (spec_to_Z op_spec w5); auto with zarith.
 intros H2.
 match goal with |- context[split ?x] =>
 generalize (split_correct x);
  case (split x); auto with zarith
 end.
 assert (F1: [[w_square_c w2]] < [|b|] * [|b|]).
 unfold w_square_c, ww_to_Z, w_digits, w_to_Z.
 rewrite spec_square_c; auto with zarith.
 apply Zmult_lt_compat; auto with zarith.
 case (spec_to_Z op_spec w2); auto with zarith.
 case (spec_to_Z op_spec w2); auto with zarith.
 intros w4 w5; rewrite ww_lsl_n_spec; auto with zarith.
 intros H3.
 unfold w_div21; match goal with |- context[znz_div21 ?x ?y ?z ?t] =>
   generalize (spec_div21 op_spec y z t);
   case (znz_div21 x y z t)
 end.
 rewrite b2n_spec; case (n_spec); auto.
 intros H4 H5 w6 w7 H6.
 case H6; auto with zarith.
 case (Zle_or_lt (2 ^ [|n|] * [|b|]) [|w4|]); auto; intros H7.
 match type of H3 with ?X = ?Y =>
    absurd (Y < X)
 end.
 apply Zle_not_lt; rewrite H3; auto with zarith.
 simpl ww_to_Z.
 match goal with |- ?X < ?Y + _ =>
    apply Zlt_le_trans with Y; auto with zarith
 end.
 apply Zlt_trans with (2 ^ [|n|] * ([|b|] * [|b|]));
   auto with zarith.
 apply Zmult_lt_compat_l; auto with zarith.
 rewrite Zmult_assoc.
 apply Zmult_lt_compat2; auto with zarith.
 case (spec_to_Z op_spec b); auto with zarith.
 unfold w_to_Z,w_digits;case (spec_to_Z op_spec w5); auto with zarith.
 clear H6; intros H7 H8.
 rewrite w_lsr_n_spec; auto with zarith.
 rewrite <- (Z_div_mult ([|w2|] * [|w2|]) (2 ^ [|n|]));
  auto with zarith; rewrite Zmult_comm.
 rewrite <- spec_square_c; auto with zarith.
 unfold w_square_c, ww_to_Z in H3;  unfold w_digits,w_to_Z in H3.
 rewrite <- H3; simpl.
 rewrite H7; rewrite (fun x => Zmult_comm (2 ^ x));
   rewrite Zmult_assoc; rewrite BigNumPrelude.Z_div_plus_l; auto with zarith.
 rewrite Zplus_mod; auto with zarith.
 rewrite Z_mod_mult; auto with zarith.
 rewrite Zplus_0_l; auto with zarith.
 rewrite Zmod_mod; auto with zarith.
 rewrite Zmod_small; auto with zarith.
 split; auto with zarith.
 apply Zdiv_lt_upper_bound; auto with zarith.
 rewrite Zmult_comm; auto with zarith.
 Qed.

 Let _power_mod :=
   fix pow_mod (x:w) (p:positive) {struct p} : w :=
     match p with
     | xH => x
     | xO p' =>
       let pow := pow_mod x p' in
       _square_mod pow
     | xI p' =>
       let pow := pow_mod x p' in
       _mul_mod (_square_mod pow) x
     end.

 Lemma _power_mod_spec: forall w t p, [|w|] = t mod [|b|] ->
   [|_power_mod w p|] = (Zpower_pos [|w|] p) mod [|b|].
 intros w2 t p; elim p; simpl; auto with zarith.
 intros p' Rec H.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t [|b|]); auto with zarith.
 replace (xI p') with (p' + p' + 1)%positive.
 repeat rewrite Zpower_pos_is_exp; auto with zarith.
 pose (t1 := [|_power_mod w2 p'|]).
 rewrite _mul_mod_spec with (t1 := t1 * t1)
                            (t2 := t); auto with zarith.
 rewrite _square_mod_spec with (t := Zpower_pos [|w2|] p'); auto with zarith.
 rewrite Rec; auto with zarith.
 assert (tmp: forall p, Zpower_pos p 1 = p); try (rewrite tmp; clear tmp).
 intros p1; unfold Zpower_pos; simpl; ring.
 rewrite <- Zmult_mod; auto with zarith.
 rewrite Zmult_mod; auto with zarith.
 rewrite Zmod_mod; auto with zarith.
 rewrite <- Zmult_mod; auto with zarith.
 simpl; unfold t1; apply _square_mod_spec with (t := Zpower_pos [|w2|] p'); auto with zarith.
 rewrite xI_succ_xO; rewrite <- Pplus_diag.
 rewrite Pplus_one_succ_r; auto.
 intros p' Rec H.
 replace (xO p') with (p' + p')%positive.
 repeat rewrite Zpower_pos_is_exp; auto with zarith.
 rewrite _square_mod_spec with (t := Zpower_pos [|w2|] p'); auto with zarith.
 rewrite Rec; auto with zarith.
 rewrite <- Zmult_mod; auto with zarith.
 rewrite <- Pplus_diag; auto.
 intros H.
 assert (tmp: forall p, Zpower_pos p 1 = p); try (rewrite tmp; clear tmp).
 intros p1; unfold Zpower_pos; simpl; ring.
 rewrite Zmod_small; auto with zarith.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t [|b|]); auto with zarith.
 case (spec_to_Z op_spec w2); auto with zarith.
 Qed.

 Definition make_mod_op :=
   mk_mod_op
     _succ_mod _add_mod
     _pred_mod _sub_mod
     _mul_mod _square_mod _power_mod.

  Definition make_mod_spec: mod_spec make_mod_op.
  apply mk_mod_spec.
  exact _succ_mod_spec.
  exact _add_mod_spec.
  exact _pred_mod_spec.
  exact _sub_mod_spec.
  exact _mul_mod_spec.
  exact _square_mod_spec.
  exact _power_mod_spec.
  Defined.

(*********** Mersenne special **********)

 Variable p: positive.
 Variable zp: w.

 Hypothesis zp_b: [|zp|] = Zpos p.
 Hypothesis p_lt_w_digits: Zpos p <= Zpos w_digits.

 Let p1 := Pminus (xO w_digits) p.

 Theorem p_p1: Zpos p + Zpos p1 = Zpos (xO w_digits).
 unfold p1.
 rewrite Zpos_minus; auto with zarith.
 rewrite Zmax_right; auto with zarith.
 rewrite Zpos_xO; auto with zarith.
 assert (0 < Zpos w_digits); auto with zarith.
 Qed.

 Let zp1 := ww_sub ww_zdigits (WW w0 zp).

 Let spec_add2: forall x y,
  [[w_add2 x y]] = [|x|] + [|y|].
  unfold w_add2.
  intros xh xl; generalize (spec_add_c op_spec xh xl).
  unfold w_add_c; case znz_add_c; unfold interp_carry; simpl ww_to_Z.
    intros w2 Hw2; simpl; unfold w_to_Z; rewrite Hw2.
  unfold w0; rewrite spec_0; simpl; auto with zarith.
  intros w2; rewrite Zmult_1_l; simpl.
  unfold w_to_Z, w1; rewrite spec_1; auto with zarith.
  rewrite Zmult_1_l; auto.
 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 spec_zdigits; auto.
 rewrite Zpos_xO; auto with zarith.
 Qed.

 Let spec_ww_to_Z := (spec_ww_to_Z _ _ (spec_to_Z op_spec)).
 Let spec_ww_compare := spec_ww_compare _ _ _ _ (spec_0 op_spec)
      (spec_to_Z op_spec) (spec_compare op_spec).
 Let spec_ww_sub :=
         spec_ww_sub w0 zp wWW zp1 w_opp_c w_opp_carry
              w_sub_c w_opp w_sub w_sub_carry w_digits w_to_Z
             (spec_0 op_spec)
             (spec_to_Z op_spec)
             (spec_WW op_spec)
             (spec_opp_c op_spec)
             (spec_opp op_spec)
             (spec_opp_carry op_spec)
             (spec_sub_c op_spec)
             (spec_sub op_spec)
             (spec_sub_carry op_spec).

 Theorem zp1_b: [[zp1]] = Zpos p1.
 change ([[DoubleSub.ww_sub w0 wWW w_opp_c w_opp_carry w_sub_c w_opp w_sub
            w_sub_carry ww_zdigits (WW w0 zp)]] =
          Zpos p1).
 rewrite spec_ww_sub; auto with zarith.
 rewrite spec_ww_digits; simpl ww_to_Z.
 change (w_to_Z w0) with [|w0|].
 unfold w0; rewrite spec_0; autorewrite with rm10.
 change (w_to_Z zp) with [|zp|].
 rewrite zp_b.
 rewrite Zmod_small; auto with zarith.
 rewrite <- p_p1; auto with zarith.
 unfold ww_digits; split; auto with zarith.
 rewrite <- p_p1; auto with zarith.
 assert (0 < Zpos p1); auto with zarith.
 apply Zle_lt_trans with (Zpos (xO w_digits)); auto with zarith.
 assert (0 < Zpos p); auto with zarith.
 unfold base; apply Zpower2_lt_lin; auto with zarith.
 apply op_spec.
 Qed.

 Hypothesis p_b: [|b|] = 2 ^ (Zpos p) - 1.

 Let w_pos_mod := w_op.(znz_pos_mod).

 Let add_mul_div :=
   DoubleLift.ww_add_mul_div w0 wWW wW0 w0W
              ww_compare w_add_mul_div
              ww_sub w_zdigits low.

 Let _mmul_mod x y :=
  let xy := w_mul_c x y in
  match xy with
    W0 => w0
  | WW xh xl =>
      let xl1 := w_pos_mod zp xl in
        match add_mul_div zp1 W0 xy with
          W0 => match w_compare xl1 b with
                | Lt => xl1
                | Eq => w0
                | Gt => w1
                end
        | WW _ xl2 => _add_mod xl1 xl2
        end
  end.

 Hint Unfold w_digits.

 Lemma WW_0: forall x y, [[WW x y]] = 0 -> [|x|] = 0 /\ [|y|] =0.
 intros x y; simpl; case (spec_to_Z op_spec x); intros H1 H2;
   case (spec_to_Z op_spec y); intros H3 H4 H5.
 case Zle_lt_or_eq with (1 := H1); clear H1; intros H1; auto with zarith.
 absurd (0 < [|x|] * base (znz_digits w_op) + [|y|]); auto with zarith.
 unfold w_to_Z, w_digits in H5;auto with zarith.
 match goal with |- _ < ?X + _ =>
  apply Zlt_le_trans with X; auto with zarith
 end.
 case Zle_lt_or_eq with (1 := H3); clear H3; intros H3; auto with zarith.
 absurd (0 < [|x|] * base (znz_digits w_op) + [|y|]); auto with zarith.
 unfold w_to_Z, w_digits in H5;auto with zarith.
 rewrite <- H1; rewrite Zmult_0_l; auto with zarith.
 Qed.

 Theorem WW0_is_0: [[W0]] = 0.
 simpl; auto.
 Qed.
  Hint Rewrite WW0_is_0: w_rewrite.

 Theorem mmul_aux0: Zpos (xO w_digits) - Zpos p1 = Zpos p.
 unfold w_digits.
 apply trans_equal with (Zpos p + Zpos p1 - Zpos p1); auto with zarith.
 rewrite p_p1; auto with zarith.
 Qed.

 Theorem mmul_aux1: 2 ^ Zpos w_digits =
     2 ^ (Zpos w_digits - Zpos p) * 2 ^ Zpos p.
 rewrite <- Zpower_exp; auto with zarith.
 eq_tac; auto with zarith.
 Qed.

 Theorem mmul_aux2:forall x,
   x mod (2 ^ Zpos p - 1) =
    ((x / 2 ^ Zpos p) + (x mod 2 ^ Zpos p)) mod (2 ^ Zpos p - 1).
 intros x; pattern x at 1; rewrite Z_div_mod_eq with (b := 2 ^ Zpos p); auto with zarith.
 match goal with |- (?X * ?Y + ?Z) mod (?X - 1) = ?T =>
  replace (X * Y + Z) with (Y * (X - 1) + (Y + Z)); try ring
 end.
 rewrite Zplus_mod; auto with zarith.
 rewrite Z_mod_mult; auto with zarith.
 rewrite Zplus_0_l.
 rewrite Zmod_mod; auto with zarith.
 Qed.

 Theorem mmul_aux3:forall xh xl,
   [[WW xh xl]] mod (2 ^ Zpos p) = [|xl|] mod (2 ^ Zpos p).
 intros xh xl; simpl ww_to_Z; unfold base.
 rewrite Zplus_mod; auto with zarith.
 generalize mmul_aux1; unfold w_digits; intros tmp; rewrite tmp;
   clear tmp.
 rewrite Zmult_assoc.
 rewrite Z_mod_mult; auto with zarith.
 rewrite Zplus_0_l; apply Zmod_mod; auto with zarith.
 Qed.

 Let spec_low: forall x,
  [|low x|] = [[x]] mod base w_digits.
  intros x; case x; simpl low; auto with zarith.
  intros xh xl; simpl.
  rewrite Zplus_comm; rewrite Z_mod_plus; auto with zarith.
  rewrite Zmod_small; auto with zarith.
  case (spec_to_Z op_spec xl); auto with zarith.
  unfold base; auto with zarith.
 Qed.

 Theorem mmul_aux4:forall x,
  [[x]] < [|b|] * 2 ^  Zpos p ->
     match add_mul_div zp1 W0 x with
          W0 => 0
        | WW _ xl2 => [|xl2|]
     end = [[x]] / 2 ^ Zpos p.
 intros x Hx.
 assert (Hp: [[zp1]] <= Zpos (xO w_digits)); auto with zarith.
   rewrite zp1_b; rewrite <- p_p1; auto with zarith.
   assert (0 <= Zpos p); auto with zarith.
 generalize (@DoubleLift.spec_ww_add_mul_div w w0 wWW wW0 w0W
    ww_compare w_add_mul_div ww_sub w_digits w_zdigits low w_to_Z
    (spec_0 op_spec) (spec_to_Z op_spec) spec_ww_to_Z
    (spec_WW op_spec) (spec_W0 op_spec) (spec_0W op_spec)
    spec_ww_compare (spec_add_mul_div op_spec) spec_ww_sub
    (spec_zdigits op_spec) spec_low W0 x zp1 Hp).
  unfold add_mul_div;
    case DoubleLift.ww_add_mul_div; autorewrite with w_rewrite; auto.
 rewrite Zmult_0_l; rewrite Zplus_0_l.
 rewrite zp1_b.
 generalize mmul_aux0; unfold w_digits; intros tmp; rewrite tmp.
 rewrite Zmod_small; auto with zarith.
 split; auto with zarith.
 apply Z_div_pos; auto with zarith.
 case (spec_ww_to_Z x); auto with zarith.
 unfold base.
 apply Zdiv_lt_upper_bound; auto with zarith.
 case (spec_ww_to_Z x); auto with zarith.
 rewrite <- Zpower_exp; auto with zarith.
 intros.
 apply Zlt_le_trans with (base (ww_digits (znz_digits w_op))); auto with zarith.
   case (spec_ww_to_Z x); auto with zarith.
   intros.
 unfold base; apply Zpower_le_monotone; auto with zarith.
 split; auto with zarith.
 assert (0 < Zpos p); auto with zarith.
 intros w2 w3; rewrite Zmult_0_l; rewrite Zplus_0_l.
 rewrite zp1_b.
 generalize mmul_aux0; unfold w_digits; intros tmp; rewrite tmp;
  clear tmp.
 simpl ww_to_Z; rewrite Zmod_small; auto with zarith.
 intros H1;
   generalize (high_zero (WW w2 w3)); unfold w_digits;intros tmp;
   simpl fst in tmp; simpl ww_to_Z in tmp;auto with zarith.
   unfold w_to_Z in *.
   rewrite tmp in H1; auto with zarith. clear tmp.
 simpl ww_to_Z; rewrite H1; apply Zdiv_lt_upper_bound; auto with zarith.
 case (spec_ww_to_Z x); auto with zarith.
 unfold base; rewrite <- Zpower_exp; auto with zarith.
 intros.
 apply Zlt_le_trans with (1 := Hx).
 apply Zle_trans with (2 ^ Zpos p * 2 ^ Zpos p).
 rewrite p_b; apply Zmult_le_compat_r; auto with zarith.
 rewrite <- Zpower_exp; auto with zarith.
 apply Zpower_le_monotone; auto with zarith.
 split; auto with zarith.
 apply Z_div_pos; auto with zarith.
 case (spec_ww_to_Z  x); auto with zarith.
 unfold base.
 apply Zdiv_lt_upper_bound; auto with zarith.
 case (spec_ww_to_Z  x); auto with zarith.
 rewrite <- Zpower_exp; auto with zarith.
 intros.
 apply Zlt_le_trans with (base (ww_digits (znz_digits w_op))); auto with zarith.
   case (spec_ww_to_Z x); auto with zarith.
   intros.
 unfold base; apply Zpower_le_monotone; auto with zarith.
 split; auto with zarith.
 assert (0 < Zpos p); auto with zarith.
 Qed.

 Theorem mmul_aux5:forall xh xl,
      [[WW xh xl]] < [|b|] * 2 ^  Zpos p ->
      let xl1 := w_pos_mod zp xl in
      let r :=
        match add_mul_div zp1 W0 (WW xh xl) with
          W0 => match w_compare xl1 b with
                | Lt => xl1
                | Eq => w0
                | Gt => w1
                end
        | WW _ xl2 => _add_mod xl1 xl2
        end  in
        [|r|] = [[WW xh xl]] mod [|b|].
 intros xh xl Hx xl1 r; unfold r; clear r.
 generalize (mmul_aux4 _ Hx).
 simpl ww_to_Z; rewrite p_b.
 rewrite mmul_aux2.
 assert (Hp: [[zp1]] <= Zpos (xO w_digits)); auto with zarith.
   rewrite zp1_b; rewrite <- p_p1; auto with zarith.
   assert (0 <= Zpos p); auto with zarith.
 generalize (@DoubleLift.spec_ww_add_mul_div w w0 wWW wW0 w0W
    ww_compare w_add_mul_div ww_sub w_digits w_zdigits low w_to_Z
    (spec_0 op_spec) (spec_to_Z op_spec) spec_ww_to_Z
    (spec_WW op_spec) (spec_W0 op_spec) (spec_0W op_spec)
    spec_ww_compare (spec_add_mul_div op_spec) spec_ww_sub
    (spec_zdigits op_spec) spec_low W0 (WW xh xl) zp1 Hp).
  unfold add_mul_div;
    case DoubleLift.ww_add_mul_div; autorewrite with w_rewrite; auto.
 rewrite Zmult_0_l; rewrite Zplus_0_l.
 rewrite zp1_b.
 generalize mmul_aux0; unfold w_digits; intros tmp; rewrite tmp; clear tmp.
 intros H1 H2.
 rewrite <- H2.
 rewrite Zplus_0_l.
 generalize mmul_aux3; simpl ww_to_Z; intros tmp; rewrite tmp; clear tmp;
   auto with zarith.
 unfold xl1; unfold w_pos_mod.
  rewrite <- p_b; rewrite <- zp_b.
  rewrite <- spec_pos_mod; auto with zarith.
 generalize (spec_compare op_spec (znz_pos_mod w_op zp xl) b);
   unfold w_compare; case znz_compare; autorewrite with w_rewrite;
   try rewrite _w0_is_0; auto with zarith.
 intros H3; rewrite H3.
 rewrite Z_mod_same; auto with zarith.
 intros H3; rewrite Zmod_small; auto with zarith.
 case (spec_to_Z op_spec (znz_pos_mod w_op zp xl)); unfold w_to_Z; auto with zarith.
 rewrite p_b; rewrite (spec_pos_mod); auto with zarith.
 intros H3; assert (HH: [|xl|] mod 2 ^ Zpos p = 2 ^ Zpos p).
 apply Zle_antisym; auto with zarith.
 case (Z_mod_lt ([|xl|]) (2 ^ Zpos p)); auto with zarith.
 rewrite zp_b in H3; auto with zarith.
 rewrite zp_b; rewrite HH.
 rewrite <- Zmod_minus_one; auto with zarith.
 rewrite _w1_is_1; rewrite Zmod_small; auto with zarith.
 rewrite Zmult_0_l; rewrite Zplus_0_l.
 rewrite zp1_b.
 generalize mmul_aux0; unfold w_digits; intros tmp; rewrite tmp; clear tmp.
 intros w2 w3 H1 H2; rewrite <- H2.
 generalize mmul_aux3; simpl ww_to_Z; intros tmp; rewrite tmp; clear tmp;
   auto with zarith.
 rewrite <- p_b; rewrite <- zp_b.
 rewrite <- (spec_pos_mod); auto with zarith.
 unfold xl1; unfold w_pos_mod.
 rewrite Zplus_comm.
 apply _add_mod_correct; auto with zarith.
 assert (tmp: forall x, 2 * x = x + x); auto with zarith;
   rewrite tmp; apply Zplus_le_lt_compat; clear tmp; auto with zarith.
 rewrite spec_pos_mod; auto with zarith.
 rewrite p_b; case (Z_mod_lt [|xl|] (2 ^ Zpos p)); auto with zarith.
 rewrite zp_b; auto with zarith.
 rewrite H2; apply Zdiv_lt_upper_bound; auto with zarith.
(*  case (spec_ww_to_Z (WW xh xl)); simpl; auto with zarith. *)
 Qed.

 Lemma _mmul_mod_spec: forall w1 w2 t1 t2, [|w1|] = t1 mod [|b|] -> [|w2|] = t2 mod [|b|] ->
   [|_mmul_mod w1 w2|] = ([|w1|] * [|w2|]) mod [|b|].
 intros w2 w3 t1 t2; unfold _mmul_mod, w_mul_c; intros H H1.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t1 [|b|]); auto with zarith.
 assert (F': [|w3|] < [|b|]).
 case (Z_mod_lt t2 [|b|]); auto with zarith.
 match goal with |- context[znz_mul_c _ ?x ?y] =>
   generalize (spec_mul_c op_spec x y); unfold interp_carry;
   case (znz_mul_c w_op x y); autorewrite with w_rewrite
 end; auto with zarith.
 simpl; intros H2; rewrite <- H2; rewrite _w0_is_0; rewrite Zmod_small;
  auto with zarith.
 intros w4 w5 H2.
 rewrite mmul_aux5; auto with zarith.
 rewrite <- H2; auto.
 unfold ww_to_Z,w_digits,w_to_Z; rewrite H2.
 apply Zmult_lt_compat; auto with zarith.
 case (spec_to_Z op_spec w2); auto with zarith.
 case (spec_to_Z op_spec w3); auto with zarith.
 Qed.

 Let _msquare_mod x :=
  let xy := w_square_c x in
  match xy with
    W0 => w0
  | WW xh xl =>
      let xl1 := w_pos_mod zp xl in
        match add_mul_div zp1 W0 xy with
          W0 =>  match w_compare xl1 b with
                | Lt => xl1
                | Eq => w0
                | Gt => w1
                end
        | WW _ xl2 => _add_mod xl1 xl2
        end
  end.

 Lemma _msquare_mod_spec: forall w1 t1, [|w1|] = t1 mod [|b|] ->
   [|_msquare_mod w1|] = ([|w1|] * [|w1|]) mod [|b|].
 intros w2 t2; unfold _msquare_mod, w_square_c; intros H.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t2 [|b|]); auto with zarith.
 match goal with |- context[znz_square_c _ ?x] =>
   generalize (spec_square_c op_spec x); unfold interp_carry;
   case (znz_square_c w_op x); autorewrite with w_rewrite
 end; auto with zarith.
 simpl; intros H2; rewrite <- H2; rewrite _w0_is_0; rewrite Zmod_small;
  auto with zarith.
 intros w4 w5 H2.
 rewrite mmul_aux5; auto with zarith.
 unfold ww_to_Z, w_to_Z ,w_digits; rewrite <- H2; auto.
 unfold ww_to_Z,w_to_Z ,w_digits; rewrite H2.
 apply Zmult_lt_compat; auto with zarith.
 case (spec_to_Z op_spec w2); auto with zarith.
 case (spec_to_Z op_spec w2); auto with zarith.
 Qed.

 Definition mmake_mod_op :=
   mk_mod_op
     _succ_mod _add_mod
     _pred_mod _sub_mod
     _mmul_mod _msquare_mod _power_mod.

 Definition mmake_mod_spec: mod_spec mmake_mod_op.
  apply mk_mod_spec.
  exact _succ_mod_spec.
  exact _add_mod_spec.
  exact _pred_mod_spec.
  exact _sub_mod_spec.
  exact _mmul_mod_spec.
  exact _msquare_mod_spec.
  exact _power_mod_spec.
  Defined.

End Mod_op.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  The trivial subset of the language.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import CpdtTactics.

Require Export FormalSyntax.
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export DynamicSemanticsTypeSubstitution.
Require Export StaticSemanticsKindingAndContextWellFormedness.
Require Export StaticSemantics.
Require Export TypeSafety.

Fixpoint BinderlessSubsetTau (tau : Tau) :=
  match tau with
    | cint => True
    | cross t0 t1 =>
      BinderlessSubsetTau t0  /\
       BinderlessSubsetTau t1
    | ptype t => BinderlessSubsetTau t
    | _ => False
  end.

Fixpoint BinderlessSubsetI    (i : I)        := True.
Fixpoint BinderlessSubsetEVar (x : EVar)     := False.
Fixpoint BinderlessSubsetTVar (alpha : TVar) := False.

Fixpoint BinderlessSubsetF (f : E) := False.

Fixpoint BinderlessSubsetE (e : E) :=
  match e with
    | p_e _ _ => False
    | call _ => False
    | inst _ _ => False
    | pack _ _ _ => False
    | _ => True
  end.

Fixpoint BinderlessSubsetSt (s : St) :=
  match s with
    | (retn e) => BinderlessSubsetE e
    | (e_s e) => BinderlessSubsetE e
    | (seq s1 s2) => BinderlessSubsetSt s1 /\ BinderlessSubsetSt s2
    | (if_s e s1 s2) =>
      BinderlessSubsetE e /\ BinderlessSubsetSt s1 /\ BinderlessSubsetSt s2
    | (while e s) =>
      BinderlessSubsetE e /\ BinderlessSubsetSt s
    | _ => False
  end.

Theorem Type_Safety :
(*   If ·; ·; ·; τ styp s, ret s, and ·; s → H ; s *)
 forall (s : St) (tau : Tau),
   styp [] [] [] tau s ->
   BinderlessSubsetSt s ->
   BinderlessSubsetTau tau ->
   ret s ->
   exists (h' : H) (s' : St),
     Sstar [] s h' s' ->
     NotStuck h' s'.
Proof.
 Definition Thm (s : St) (tau : Tau) : Prop :=
   (
   BinderlessSubsetSt s ->
   BinderlessSubsetTau tau ->
   ret s ->
     exists (h' : H) (s' : St),
       Sstar [] s h' s' ->
       NotStuck h' s').
  intros s tau.
  apply (Term_ind_mutual
           (fun (s : St) =>
              forall (tau : Tau) (ts : (styp [] [] [] tau s)),
                Thm s tau)
           (fun (e : E ) =>
              forall (tau : Tau) (ts : (styp [] [] [] tau (e_s e))),
                Thm (e_s e) tau)
           (fun (f : F) =>
              forall (ts : (styp [] [] [] tau (e_s (f_e f)))),
                Thm (e_s (f_e f)) tau));
    repeat (unfold Thm; crush).
   (* Crush 8/22. *)
Admitted.

Lemma A_8_Return_Preservation:
  forall (s s' : St) (h h' : H),
  ret s ->
  S h s h' s' ->
  BinderlessSubsetSt s ->
  ret s'.
Proof.
  intros s s' h h' retder.
  apply (SLR_ind_mutual
           (fun (h : H) (s : St) (h' : H) (s' : St) (rstep: R h s h' s') =>
              BinderlessSubsetSt s ->
              ret s')
           (fun (h : H) (s : St) (h' : H) (s' : St) (sstep: S h s h' s') =>
              BinderlessSubsetSt s ->
              ret s')
           (fun (h : H) (s : St) (h' : H) (s' : St) (lstep: L h s h' s') =>
              BinderlessSubsetSt s ->
              ret s')); crush.
  (* Crush gets 13/41 *)
Admitted.

Inductive extends_Gamma : Gamma -> Gamma -> Prop :=
  | A_12_Extension_Gamma :
      forall (g1 g2 : Gamma),
        (exists (g3 : Gamma), g2 = g1 ++ g3) ->
        extends_Gamma g2 g1.

Inductive extends_Upsilon : Upsilon -> Upsilon -> Prop :=
  | A_12_Extension_Upsilon :
      forall (u1 u2 : Upsilon),
        (exists (g3 : Upsilon), u2 = u1 ++ g3) ->
        extends_Upsilon u2 u1.

Lemma A_13_Term_Preservation_1:
  forall (u : Upsilon) (g : Gamma)
         (e e' : E) (tau : Tau) (h h' : H),
    htyp u g h g ->
    refp h u ->
    ltyp [] u g e tau ->
    L h (e_s e)  h' (e_s e') ->
    BinderlessSubsetTau tau ->
    BinderlessSubsetE e ->
     exists (g' : Gamma) (u' : Upsilon),
       (extends_Gamma  g g' /\ extends_Upsilon  u u') ->
       htyp u' g' h' g' /\
       refp h' u' /\
       ltyp [] u' g' e' tau.
Proof.
  intros u g e e' tau h h'.
  intros htypder refpder ltypder.
  (* TODO am I proving the right theorem? e_s e not here. *)
  apply (SLR_ind_mutual
           (fun (h : H) (s : St) (h' : H) (s' : St)
                (rstep: R h s h' s') =>
              BinderlessSubsetTau tau ->
              BinderlessSubsetE e ->
              exists (g' : Gamma) (u' : Upsilon),
                (extends_Gamma  g g' /\ extends_Upsilon  u u') ->
                htyp u' g' h' g' /\
                refp h' u' /\
                ltyp [] u' g' e' tau)
           (fun (h : H) (s : St) (h' : H) (s' : St)
                (sstep: S h s h' s') =>
              BinderlessSubsetTau tau ->
              BinderlessSubsetE e ->
              exists (g' : Gamma) (u' : Upsilon),
                (extends_Gamma  g g' /\ extends_Upsilon  u u') ->
                htyp u' g' h' g' /\
                refp h' u' /\
                ltyp [] u' g' e' tau)
           (fun (h : H) (s : St) (h' : H) (s' : St)
                (lstep: L h s h' s') =>
              BinderlessSubsetTau tau ->
              BinderlessSubsetE e ->
              exists (g' : Gamma) (u' : Upsilon),
                (extends_Gamma  g g' /\ extends_Upsilon  u u') ->
                htyp u' g' h' g' /\
                refp h' u' /\
                ltyp [] u' g' e' tau)); crush.
  (* crush gives 19/41, same without filter *)
Admitted.

Lemma A_2_Term_Weakening_1 :
  forall (d: Delta) (u u' : Upsilon) (g g' : Gamma)
         (x : EVar) (p p' : P) (tau tau' : Tau),
    WFC d (u ++ u') (g ++ g') ->
    BinderlessSubsetTau tau ->
    BinderlessSubsetTau tau' ->
    gettype u x p tau p' = Some tau' ->
    gettype (u ++ u') x p tau p' = Some tau'.
Proof.
  intros d u u' g g' x p p' tau tau'.
  intros WFCd.
  intros gettypederivation.
  functional induction (gettype u x p tau p'); crush.
  (* Warning: Collision between bound varibles of name x *)
  (* Crush gets 25/26 same *)
Admitted.

Lemma A_2_Term_Weakening_2_3_4 :
  forall (d: Delta) (u u' : Upsilon) (g g' : Gamma)
         (e : E) (tau : Tau),
    WFC d (u ++ u') (g ++ g') ->
    ltyp d u g e tau ->
    BinderlessSubsetE e ->
    BinderlessSubsetTau tau ->
    ltyp d (u ++ u') (g++g') e tau.
Proof.
  intros d u u' g g' e tau WFC.
  apply (typ_ind_mutual
           (fun (d : Delta) (u : Upsilon) (g : Gamma) (t : Tau) (s : St)
                (st : styp d u g t s) =>
              BinderlessSubsetSt s ->
              BinderlessSubsetTau tau ->
              ltyp d (u ++ u') (g++g') e tau)
           (fun (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t : Tau)
                (lt : ltyp d u g e t) =>
              BinderlessSubsetE e ->
              BinderlessSubsetTau tau ->
              ltyp d (u ++ u') (g++g') e tau)
           (fun (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t : Tau)
                (rt : rtyp d u g e t) =>
              BinderlessSubsetE e ->
              BinderlessSubsetTau tau ->
              ltyp d (u ++ u') (g++g') e tau)).
  (* Crush gets 11/26. *)
Admitted.


Require Export Categories.Typ.

Structure Presheave (C: Category) := {
  pobj: C -> Type;
  pmap {X Y: C}: Y ~> X -> pobj X -> pobj Y;
  pmap_id {X: C} (x: pobj X): pmap (id X) x = x;
  pmap_comp {X Y Z: C} (f: Y ~> Z) (g: X ~> Y) (x: pobj Z): pmap (f ∘ g) x = pmap g (pmap f x);
}.

Arguments pobj {C} _ _.
Arguments pmap {C} _ {X Y} _ _.
Arguments pmap_id {C} _ {X} _.
Arguments pmap_comp {C} _ {X Y Z} _ _ _.

Coercion pobj: Presheave >-> Funclass.

Program Definition psfun {C: Category} (P: Presheave C): Functor (co C) Typ := Build_Functor (co C) Typ
  P (@pmap C P) _ _.
Next Obligation.
  extensionality x.
  exact (pmap_id P x).
Qed.
Next Obligation.
  extensionality x.
  exact (pmap_comp P g f x).
Qed.

Coercion psfun: Presheave >-> Functor.
Canonical psfun.

Module Presheave.

Structure hom {C: Category} (P Q: Presheave C) := {
  ptrans (X: C): P X -> Q X;
  pnatural {X Y: C} (f: X ~> Y) (x: P Y): ptrans X (pmap P f x) = pmap Q f (ptrans Y x);
}.

Arguments ptrans {C P Q} _ {X} _.
Arguments pnatural {C P Q} _ {X Y} _ _.
Coercion ptrans: hom >-> Funclass.

Lemma hom_eq {C: Category} {P Q: Presheave C} (η ϵ: hom P Q): η = ϵ <-> forall X (x: P X), η X x = ϵ X x.
Proof.
  split.
  now intros [].
  destruct η as [f Hf], ϵ as [g Hg]; simpl.
  intros H.
  enough (f = g); [subst g|].
  f_equal; apply proof_irrelevance.
  extensionality X.
  extensionality x.
  apply H.
Qed.

Section cat.
Context {C: Category}.

Let id (P: Presheave C): hom P P := {|
  ptrans X x := x;
  pnatural X Y f x := eq_refl;
|}.

Program Let comp {P Q R: Presheave C} (η: hom Q R) (ϵ: hom P Q): hom P R := {|
  ptrans X x := η X (ϵ X x);
|}.
Next Obligation.
  rewrite pnatural.
  apply pnatural.
Qed.

Lemma comp_assoc {P Q R S: Presheave C} (η: hom R S) (ϵ: hom Q R) (γ: hom P Q): comp η (comp ϵ γ) = comp (comp η ϵ) γ.
Proof. now apply hom_eq. Qed.

Lemma comp_id_l {P Q: Presheave C} (η: hom P Q): comp (id Q) η = η.
Proof. now apply hom_eq. Qed.

Lemma comp_id_r {P Q: Presheave C} (η: hom P Q): comp η (id P) = η.
Proof. now apply hom_eq. Qed.

Definition cat_mixin := Category.Mixin (Presheave C) hom id (@comp) (@comp_assoc) (@comp_id_l) (@comp_id_r).

End cat.

Canonical cat (C: Category) := Category.Pack (Presheave C) cat_mixin.

Lemma ptrans_is_eq {C} {P Q: Presheave C} (η: P ~> Q) (X: C): is_eq η -> @is_eq Typ _ _ (η X).
Proof.
  intros [e H].
  subst η Q; simpl.
  exact is_eq_id.
Qed.

Program Definition preimg {C D: Category} (F: Functor D C) (P: Presheave C): Presheave D := {|
  pobj X := P (F X);
  pmap X Y f x := pmap P (fmap F f) x;
|}.
Next Obligation.
  rewrite fmap_id.
  apply pmap_id.
Qed.
Next Obligation.
  rewrite fmap_comp.
  apply pmap_comp.
Qed.

Program Definition preimg_inc {C D: Category} (F: Functor D C) (P Q: Presheave C) (η: P ~> Q): preimg F P ~> preimg F Q := {|
  ptrans X x := η (F X) x;
  pnatural X Y f := pnatural η (fmap F f);
|}.

Program Canonical Preimg {C D: Category} (F: Functor D C): Functor (cat C) (cat D) := {|
  fobj := preimg F;
  fmap := preimg_inc F;
|}.
Next Obligation.
  now apply hom_eq.
Qed.

Program Canonical FCat: Functor (co Cat) Cat := {|
  fobj := cat;
  fmap := @Preimg;
|}.
Next Obligation.
  fun_eq P Q η.
  unfold preimg.
  destruct x; simpl.
  f_equal; apply proof_irrelevance.
  apply hom_eq; simpl.
  intros X x.
  rewrite (@is_eq_refl Typ (Q X) (to (eq_iso H0) X)).
  rewrite (@is_eq_refl Typ (P X) (to (eq_iso H) X)).
  reflexivity.
  1: apply (ptrans_is_eq (eq_iso H)).
  2: apply (ptrans_is_eq (eq_iso H0)).
  all: apply eq_iso_is_eq.
Qed.
Next Obligation.
  fun_eq P Q η.
  unfold preimg; simpl.
  f_equal; apply proof_irrelevance.
  apply hom_eq; simpl.
  intros X x.
  rewrite (@is_eq_refl Typ _ (to (eq_iso H0) X)).
  rewrite (@is_eq_refl Typ _ (to (eq_iso H) X)).
  reflexivity.
  1: apply (ptrans_is_eq (eq_iso H)).
  2: apply (ptrans_is_eq (eq_iso H0)).
  all: apply eq_iso_is_eq.
Qed.

End Presheave.

Notation ptrans := Presheave.ptrans.
Notation pnatural := Presheave.pnatural.
Coercion ptrans: Presheave.hom >-> Funclass.
Canonical Presheave.cat.
Canonical Presheave.Preimg.
Canonical Presheave.FCat.

Program Definition psnat {C: Category} {P Q: Presheave C} (η: Presheave.hom P Q): Natural P Q := Build_Natural (co C) Typ P Q
  η _.
Next Obligation.
  extensionality e.
  apply pnatural.
Qed.

Coercion psnat: Presheave.hom >-> Natural.
Canonical psnat.

Section Psfun.
Context {C: Category}.

Program Definition Psfun_to: Presheave.cat C ~> Fun (co C) Typ := {|
  fobj := psfun;
  fmap := @psnat C;
|}.
Next Obligation.
  now natural_eq x.
Qed.
Next Obligation.
  now natural_eq x.
Qed.

Program Definition Psfun_from: Functor (Fun (co C) Typ) (Presheave.cat C) := {|
  fobj P := {|
    pobj := P;
    pmap := @fmap _ _ P;
  |};
  fmap P Q η := {|
    ptrans := η;
  |}
|}.
Next Obligation.
  now rewrite (@fmap_id _ _ P).
Qed.
Next Obligation.
  change (f ∘ g) with (@comp (co C) _ _ _ g f).
  now rewrite (@fmap_comp _ _ P _ _ _ g f).
Qed.
Next Obligation.
  change ((η X ∘ fmap P f) x = (fmap Q f ∘ η Y) x).
  apply (f_equal (fun f => f x)).
  apply (@naturality _ _ _ _ η).
Qed.
Next Obligation.
  now apply Presheave.hom_eq.
Qed.
Next Obligation.
  now apply Presheave.hom_eq.
Qed.

Program Definition Psfun_mixin := Isomorphism.Mixin Cat (Presheave.cat C) (Fun (co C) Typ) Psfun_to Psfun_from _ _.
Next Obligation.
  fun_eq P Q η.
  destruct x; simpl.
  f_equal; apply proof_irrelevance.
  apply Presheave.hom_eq; simpl.
  intros X x.
  rewrite (@is_eq_refl Typ (Q X) (to (eq_iso H0) X)).
  rewrite (@is_eq_refl Typ (P X) (to (eq_iso H) X)).
  reflexivity.
  destruct H; simpl.
  exact (@is_eq_id Typ (P X)).
  destruct H0; simpl.
  exact (@is_eq_id Typ (Q X)).
Qed.
Next Obligation.
  fun_eq P Q η.
  destruct x; unfold psfun; simpl.
  f_equal; apply proof_irrelevance.
  natural_eq X.
  rewrite (is_eq_refl (to (eq_iso H0) X)).
  rewrite (is_eq_refl (to (eq_iso H) X)).
  rewrite comp_id_r.
  apply comp_id_l.
  1: destruct H; simpl.
  2: destruct H0; simpl.
  all: exact is_eq_id.
Qed.

Definition Psfun := Isomorphism.Pack Psfun_to Psfun_mixin.

End Psfun.

Canonical Psfun_to.
Canonical Psfun.

Definition psconst (C: Category) T := {|
  pobj (_: C) := T;
  pmap _ _ _ x := x;
  pmap_id _ x := eq_refl;
  pmap_comp _ _ _ _ _ x := eq_refl;
|}.

Definition yoneda {C: Category} (X: C): Presheave C := {|
  pobj Y := Y ~> X;
  pmap Y Z f g := g ∘ f;
  pmap_id Y f := comp_id_r f;
  pmap_comp Y Z V f g h := comp_assoc h f g;
|}.

Program Definition yoneda_map {C: Category} {X Y: C} (f: X ~> Y): yoneda X ~> yoneda Y := {|
  ptrans Z g := f ∘ g;
  pnatural Z V g h := comp_assoc f h g;
|}.

Program Canonical Yoneda {C: Category}: Functor C (Presheave.cat C) := {|
  fobj := yoneda;
  fmap := @yoneda_map C;
|}.
Next Obligation.
  apply Presheave.hom_eq; simpl.
  intros X f.
  apply comp_id_l.
Qed.
Next Obligation.
  apply Presheave.hom_eq; simpl.
  intros X h.
  symmetry.
  apply comp_assoc.
Qed.

Program Definition Yoneda_trans {C: Category} (P: Presheave C) (c: C) (x: P c): yoneda c ~> P := {|
  ptrans X f := pmap P f x;
|}.
Next Obligation.
  apply pmap_comp.
Qed.

Definition Yoneda_obj {C: Category} (P: Presheave C) (c: C) (η: yoneda c ~> P): P c := η c (id c).

Lemma Yoneda_obj_trans {C: Category} (P: Presheave C) (c: C) (x: P c): Yoneda_obj P c (Yoneda_trans P c x) = x.
Proof. apply pmap_id. Qed.

Lemma Yoneda_trans_obj {C: Category} (P: Presheave C) (c: C) (η: yoneda c ~> P): Yoneda_trans P c (Yoneda_obj P c η) = η.
Proof.
  apply Presheave.hom_eq; simpl.
  intros X f.
  unfold Yoneda_obj.
  rewrite <- pnatural; simpl.
  f_equal.
  apply comp_id_l.
Qed.

Lemma Yoneda_trans_surj {C: Category} (P: Presheave C) (c: C) (η: Yoneda c ~> P): exists! x, Yoneda_trans P c x = η.
Proof.
  exists (Yoneda_obj P c η); split.
  apply Yoneda_trans_obj.
  intros x Hη.
  subst η.
  apply Yoneda_obj_trans.
Qed.

Lemma Yoneda_lemma {C: Category} (c: C) (P: Presheave C): Hom (Presheave.cat C) (Yoneda c, P) ≃ P c.
Proof.
  constructor.
  exists (Yoneda_obj P c), (Yoneda_trans P c).
  simpl.
  1: extensionality η.
  2: extensionality x.
  all: unfold comp, id; simpl.
  apply Yoneda_trans_obj.
  apply Yoneda_obj_trans.
Qed.

Lemma Yoneda_full (C: Category): full (@Yoneda C).
Proof.
  intros x y η.
  exists (Yoneda_obj (yoneda y) x η).
  unfold Yoneda_obj; simpl.
  apply Presheave.hom_eq; simpl.
  intros z f.
  change (pmap (Yoneda y) f (η x (id x)) = η z f).
  rewrite <- pnatural; simpl.
  f_equal.
  apply comp_id_l.
Qed.

Lemma Yoneda_faithful (C: Category): faithful (@Yoneda C).
Proof.
  intros x y f g H.
  setoid_rewrite Presheave.hom_eq in H.
  simpl in H.
  specialize (H x (id x)).
  now rewrite !comp_id_r in H.
Qed.

Lemma Yoneda_fully_faithful (C: Category): fully_faithful (@Yoneda C).
Proof.
  apply full_and_faithful.
  split.
  apply Yoneda_full.
  apply Yoneda_faithful.
Qed.

(* fully_faithful_iso is currently to strict in its universes *)
Lemma Yoneda_principle {C: Category} (A B: C): Yoneda A ≃ Yoneda B <-> A ≃ B.
Proof.
  split.
  + intros [η].
    constructor.
    exists (to η A (id A)), (to η⁻¹ B (id B)).
    specialize (pnatural (to η⁻¹) (to η A (id A)) (id B)) as H.
    simpl in H |- *.
    rewrite <- H; clear H.
    rewrite comp_id_l.
    change ((η⁻¹ ∘ η) A (id A) = id (Yoneda A) A (id A)).
    f_equal.
    apply inv_l.
    specialize (pnatural (to η) (to η⁻¹ B (id B)) (id A)) as H.
    simpl in H |- *.
    rewrite <- H; clear H.
    rewrite comp_id_l.
    change ((η ∘ η⁻¹) B (id B) = id (Yoneda B) B (id B)).
    f_equal.
    apply inv_r.
  + intros [f].
    constructor.
    1: unshelve eexists.
    2: unshelve eexists.
    1: exists (fun Z g => f ∘ g).
    2: exists (fun Z g => f⁻¹ ∘ g).
    3, 4: apply Presheave.hom_eq.
    all: simpl.
    1, 2: intros X Y g h.
    1, 2: apply comp_assoc.
    all: intros X x.
    all: rewrite <- comp_id_l, comp_assoc.
    all: f_equal.
    apply inv_l.
    apply inv_r.
Qed.

Module TypColim.

Structure preObj {C: Category} (F: Presheave C) := PreObj {
  lobj: C;
  lelm: F lobj;
}.

Arguments PreObj {C F} lobj lelm.
Arguments lobj {C F} _.
Arguments lelm {C F} _.

Inductive equiv {C: Category} {F: Presheave C}: preObj F -> preObj F -> Prop :=
  | equiv_path {X Y Z: C} (f: Y ~> X) (g: Z ~> X) (x: F X): equiv (PreObj Y (pmap F f x)) (PreObj Z (pmap F g x))
  | equiv_trans X Y Z: equiv X Y -> equiv Y Z -> equiv X Z.

Instance equiv_inst (C: Category) (F: Presheave C): Equivalence (@equiv C F).
Proof.
  split.
  + intros [X x].
    change x with (id (F X) x).
    rewrite <- fmap_id.
    apply equiv_path.
  + intros X Y H.
    induction H.
    apply equiv_path.
    now apply (equiv_trans _ Y).
  + exact equiv_trans.
Qed.

Lemma equiv_step {C: Category} {X Y: C} (F: Presheave C) (f: Y ~> X) (x: F X): equiv (PreObj Y (pmap F f x)) (PreObj X x).
Proof.
  change x with (id (F X) x) at 2.
  rewrite <- fmap_id.
  apply equiv_path.
Qed.

Structure obj {C: Category} (F: Presheave C) := {
  class: preObj F -> Prop;
  class_inhabited: exists X, forall Y, class Y <-> equiv X Y;
}.

Arguments class {C F} _ _.
Arguments class_inhabited {C F} _.
Coercion class: obj >-> Funclass.

Instance class_proper (C: Category) (F: Presheave C): Proper (eq ==> @equiv C F ==> iff) class.
Proof.
  intros P Q e X Y H.
  subst Q.
  destruct (class_inhabited P) as [Z HZ].
  rewrite !HZ.
  now f_equiv.
Qed.

Program Definition Obj {C: Category} {F: Presheave C} (X: C) (x: F X) := {|
  class := equiv {| lobj := X; lelm := x |};
|}.
Next Obligation.
  now exists {| lobj := X; lelm := x |}.
Qed.

Lemma obj_eq {C: Category} {F: Presheave C} (X Y: obj F): X = Y <-> forall p, X p <-> Y p.
Proof.
  split.
  now intros [].
  destruct X as [X HX], Y as [Y HY]; simpl.
  intros H.
  enough (X = Y); [subst Y|].
  f_equal; apply proof_irrelevance.
  extensionality p.
  now apply propositional_extensionality.
Qed.

Lemma Obj_eq {C: Category} {F: Presheave C} (X: C) (x: F X) (Y: obj F): Obj X x = Y <-> Y (PreObj X x).
Proof.
  destruct (class_inhabited Y) as [y H].
  rewrite obj_eq; simpl; split.
  intros Hp.
  now apply Hp.
  intros Hx p.
  apply H in Hx.
  rewrite H.
  now f_equiv.
Qed.

Lemma Obj_surj {C: Category} {F: Presheave C} (X: obj F): exists Y (y: F Y), Obj Y y = X.
Proof.
  enough (exists Y (y: F Y), X {| lobj := Y; lelm := y |}) as [Y [y H]].
  exists Y, y.
  now apply Obj_eq.
  destruct X as [P HP]; simpl.
  destruct HP as [[X x] H].
  exists X, x.
  now apply H.
Qed.

Program Definition Into {C: Category} {F: Presheave C}: F ~> psconst C (obj F) := {|
  ptrans := Obj;
|}.
Next Obligation.
  apply Obj_eq; simpl.
  change x with (id (F Y) x) at 1.
  rewrite <- fmap_id.
  apply equiv_path.
Qed.

Lemma preObj_inhab {C: Category} {F: Presheave C} (X: obj F): inhabited (preObj F).
Proof. now destruct (class_inhabited X) as [x _]. Qed.

Definition map {C: Category} {F: Presheave C} {T: Type} (η: F ~> psconst C T) (X: obj F): T :=
  η (lobj (epsilon (preObj_inhab X) X)) (lelm (epsilon (preObj_inhab X) X)).

Lemma map_Obj {C: Category} {F: Presheave C} {T: Type} (η: F ~> psconst C T) (X: C) (x: F X): map η (Obj X x) = η X x.
Proof.
  unfold map.
  generalize (epsilon (preObj_inhab (Obj X x)) (Obj X x)), (epsilon_spec (preObj_inhab (Obj X x)) (Obj X x)).
  intros p H.
  assert (exists Y, Obj X x Y) by now exists (PreObj X x); simpl.
  specialize (H H0); clear H0.
  simpl in H.
  set (PreObj X x) in H.
  change X with (lobj p0).
  change x with (lelm p0).
  clearbody p0; clear X x.
  induction H; simpl.
  transitivity (η X x).
  2: symmetry.
  1, 2: apply (pnatural η).
  now transitivity (η (lobj Y) (lelm Y)).
Qed.

End TypColim.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.Combinatorics.Lists.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.products.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.exponentials.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Chains.All.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Limits.
Require Import UniMath.CategoryTheory.categories.HSET.Colimits.
Require Import UniMath.CategoryTheory.categories.HSET.Structures.
Require Import UniMath.CategoryTheory.categories.StandardCategories.
Require Import UniMath.CategoryTheory.Groupoids.

Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.SubstitutionSystems.SumOfSignatures.
Require Import UniMath.SubstitutionSystems.BinProductOfSignatures.
Require Import UniMath.SubstitutionSystems.MultiSorted_alt.

Require Import UniMath.CategoryTheory.Chains.OmegaContFunctors.

Require Import UniMath.SubstitutionSystems.ContinuitySignature.GeneralLemmas.

Local Open Scope cat.

Section OmegaLimitsCommutingWithCoproducts.

  (* We ask for the canonical morphism from canonical : ∐ ω-lim -> ω-lim ∐ to be an isomorphism. *)
  Context (C : category).

  Context (ω_lim_given : Lims_of_shape conat_graph C).
  Context {I : UU} (Iset : isaset I).
  Context (coproducts_given : Coproducts I C).

  Variable (ind : I → cochain C).

  Let coproduct_n (n : nat) := coproducts_given (λ i, pr1 (ind i) n).
  Definition coproduct_n_cochain : cochain C.
  Proof.
    exists (λ n, pr11 (coproduct_n n)).
    intros n m f.
    use CoproductArrow.
    exact (λ j, pr2 (ind j) n m f · CoproductIn I C (coproducts_given (λ i0 : I, pr1 (ind i0) m)) j).
  Defined.

  Definition limit_of_coproduct
    := ω_lim_given coproduct_n_cochain.

  Definition coproduct_of_limit
    := coproducts_given (λ i, pr11 (ω_lim_given (ind i))).

  Definition limit_of_coproduct_as_cone_of_coproduct_to_limit
    : cone coproduct_n_cochain (pr11 coproduct_of_limit).
  Proof.
    use tpair.
    - intro n.
      use CoproductOfArrows.
      exact (λ i, pr1 (pr21 (ω_lim_given (ind i))) n).
    - intros n m p.
      cbn.
      etrans.
      1: apply precompWithCoproductArrow.
      use CoproductArrowUnique.
      intro i.
      etrans.
      1: apply (CoproductInCommutes _ _ _ coproduct_of_limit _ ( (λ i0 : I, (pr121 (ω_lim_given (ind i0))) n · (pr2 (ind i0) n m p · CoproductIn I C (coproducts_given (λ i1 : I, pr1 (ind i1) m)) i0)))).
      etrans.
      1: apply assoc.
      apply maponpaths_2.
      exact (pr221 (ω_lim_given (ind i)) n m p).
  Defined.

  Definition coproduct_of_limit_to_limit_of_coproduct
    : pr11 coproduct_of_limit --> pr11 limit_of_coproduct
    := pr11 (pr2 limit_of_coproduct _ limit_of_coproduct_as_cone_of_coproduct_to_limit).

  Definition coproduct_distribute_over_omega_limits
    := is_z_isomorphism coproduct_of_limit_to_limit_of_coproduct.

End OmegaLimitsCommutingWithCoproducts.

Definition ω_limits_distribute_over_I_coproducts
           (C : category) (I : HSET)
           (ω_lim : Lims_of_shape conat_graph C)
           (coprd : Coproducts (pr1 I) C)
  : UU := ∏ ind, coproduct_distribute_over_omega_limits C ω_lim coprd ind.

(*
A coproducts of omega-continuous functors is in general not omega-continuous.
This boils down to the commutativity of ω-limits and coproducts.
*)
Section CoproductOfFunctorsContinuity.

  Context (D : category) (I : HSET) (ω_lim : Lims_of_shape conat_graph D) (CP : Coproducts (pr1 I) D).

  Definition ω_complete_functor_cat
    : ∏ C : category, Lims_of_shape conat_graph [C, D].
  Proof.
    intro C; apply LimsFunctorCategory_of_shape, ω_lim.
  Defined.

  Let coproduct_functor_cat
    : ∏ C : category, Coproducts (pr1 I) [C,D]
    := λ C, Coproducts_functor_precat (pr1 I) C D CP.

  Definition functor_category_ω_limits_distribute_over_I_coproducts
    : ω_limits_distribute_over_I_coproducts D I ω_lim CP
      -> ∏ C : category, ω_limits_distribute_over_I_coproducts [C,D] I (ω_complete_functor_cat C) (coproduct_functor_cat C).
  Proof.
    intros distr C ind.
    use nat_trafo_z_iso_if_pointwise_z_iso.
    intro c.

    transparent assert (ind_c : (pr1 I -> cochain D)).
    {
      intro i.
      exists (λ n, pr1 (pr1 (ind i) n) c).
      exact (λ n m p, pr1 (pr2 (ind i) n m p) c).
    }

    exists (pr1 (distr ind_c)).
    split.
    - refine (_ @ pr12 (distr ind_c)).
      apply maponpaths_2.
      use limArrowUnique ; intro.
      use CoproductArrowUnique ; intro.
      etrans.
      1: {
        apply maponpaths.
        apply (limArrowCommutes (ω_lim (diagram_pointwise (coproduct_n_cochain [C, D] (coproduct_functor_cat C) ind) c))).
      }
      apply (CoproductInCommutes _ _ _ (CP (λ i0 : pr1 I, lim (ω_lim (ind_c i0))))).
    - refine (_ @ pr22 (distr ind_c)).
      apply maponpaths.
      use limArrowUnique ; intro.
      use CoproductArrowUnique ; intro.
      etrans.
      1: {
        apply maponpaths.
        apply (limArrowCommutes (ω_lim (diagram_pointwise (coproduct_n_cochain [C, D] (coproduct_functor_cat C) ind) c))).
      }
      apply (CoproductInCommutes _ _ _ (CP (λ i0 : pr1 I, lim (ω_lim (ind_c i0))))).
  Defined.

  Definition coproduct_of_functors_omega_cont
             (C : category)
             (F : (pr1 I) → C ⟶ D)
             (ω_distr : ω_limits_distribute_over_I_coproducts D I ω_lim CP)
    : (∏ i : pr1 I, is_omega_cont (F i)) -> is_omega_cont (coproduct_of_functors _ _ _ CP F).
  Proof.
    intro Fi_cont.
    intros coch l l_cone l_lim.

    use limits.is_z_iso_isLim.
    { apply ω_lim. }

    transparent assert (ind : (pr1 I -> cochain D)).
    {
      intro i.
      exists (λ n, F i (pr1 coch n)).
      exact (λ n m p, #(F i) (pr2 coch n m p)).
    }

    set (distr := ω_distr ind).
    set (distr1 := pr1 distr).
    unfold limit_of_coproduct in distr1.
    unfold coproduct_of_limit in distr1.

    use make_is_z_isomorphism.
    - refine (distr1 · _).
      use CoproductOfArrows.
      intro i.
      set (Fi_l := Fi_cont i coch l l_cone l_lim).
      apply (pr1 (isLim_is_z_iso _ _ _ _ Fi_l)).
      (* apply (Fi_l (pr11 (ω_lim (ind i))) (pr21 (ω_lim (ind i)))). *)
    - split.
      + cbn.

        transparent assert (i_iso : (is_z_isomorphism (CoproductOfArrows (pr1 I) D (CP (λ i : pr1 I, pr11 (ω_lim (ind i)))) (CP (λ i : pr1 I, F i l)) (λ i : pr1 I, limArrow (make_LimCone (mapdiagram (F i) coch) (F i l) (mapcone (F i) coch l_cone) (Fi_cont i coch l l_cone l_lim)) (lim (ω_lim (ind i))) (limCone (ω_lim (ind i))))))).
        {
          use CoproductOfArrowsIsos.
          intro i.
          set (Fi_l := Fi_cont i coch l l_cone l_lim).
          apply (pr2 (z_iso_inv (_ ,, isLim_is_z_iso _ _ _ _ Fi_l))).
        }

        etrans.
        1: apply assoc.
        use (z_iso_inv_to_right _ _ _ _ (_ ,, i_iso)).
        etrans.
        2: apply pathsinv0, id_left.
        use CoproductArrowUnique.
        intro i.
        cbn.
        etrans.
        1: apply assoc.
        etrans.
        1: apply maponpaths_2, postCompWithLimArrow.

        use (z_iso_inv_to_right _ _ _ _ (distr1 ,, _)).
        {
          unfold coproduct_distribute_over_omega_limits in distr.
          apply (pr2 (z_iso_inv (_,,distr))).
        }
        apply pathsinv0, limArrowUnique.
        intro n.
        cbn.

        etrans.
        1: apply assoc'.
        etrans.
        1: {
          apply maponpaths.
          set (t := limArrowCommutes (ω_lim (mapdiagram (coproduct_of_functors (pr1 I) C D CP F) coch))).
          exact (t (pr11 (CP (λ i0 : pr1 I, pr11 (ω_lim (ind i0))))) (limit_of_coproduct_as_cone_of_coproduct_to_limit D ω_lim CP ind) n).
        }

        cbn.
        unfold CoproductOfArrows.
        etrans.
        1: apply assoc'.
        etrans.
        1: {
          apply maponpaths.
          apply (CoproductInCommutes _ _ _  (CP (λ i0 : pr1 I, pr11 (ω_lim (ind i0))))).
        }

        etrans.
        2: apply pathsinv0, (CoproductInCommutes _ _ _  (CP (λ j : pr1 I, F j l))).
        etrans.
        1: apply assoc.

        apply maponpaths_2.
        exact (limArrowCommutes (ω_lim (ind i))  (F i l) (mapcone (F i) coch l_cone) n).
      + cbn.
        etrans.
        1: apply assoc'.
        apply pathsinv0.
        use (z_iso_inv_to_left _ _ _ (_,,_)).
        {
          unfold coproduct_distribute_over_omega_limits in distr.
          apply (pr2 (z_iso_inv (_,,distr))).
        }
        etrans.
        1: apply id_right.

        apply pathsinv0.
        use limArrowUnique.
        intro n.

        etrans.
        1: apply assoc'.
        etrans.
        1: {
          apply maponpaths.
          apply (limArrowCommutes  (ω_lim (mapdiagram (coproduct_of_functors (pr1 I) C D CP F) coch))).
        }

        etrans.
        1: apply CoproductOfArrows_comp.
        use CoproductArrowUnique.
        intro i.

        etrans.
        1: apply (CoproductInCommutes _ _ _  (CP (λ i0 : pr1 I, pr11 (ω_lim (ind i0))))).
        apply maponpaths_2.

        exact (limArrowCommutes ( (make_LimCone (mapdiagram (F i) coch) (F i l) (mapcone (F i) coch l_cone) (Fi_cont i coch l l_cone l_lim))) _ (pr21 (ω_lim (ind i))) n).
  Defined.

End CoproductOfFunctorsContinuity.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D E F : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ B D /\ (wd_ A D /\ (wd_ C D /\ (wd_ C F /\ (wd_ A D /\ (wd_ D E /\ (wd_ A E /\ (col_ A B C /\ (col_ A D E /\ col_ A E C)))))))))))) -> col_ A C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O A B C D E : Universe, ((wd_ O A /\ (wd_ B A /\ (wd_ C D /\ (wd_ D E /\ (wd_ D B /\ (wd_ C E /\ (wd_ A D /\ (wd_ O B /\ (wd_ C O /\ (wd_ D O /\ (wd_ E O /\ (col_ O D E /\ (col_ D E B /\ (col_ C D E /\ col_ A C D)))))))))))))) -> col_ O A D)).
Proof.
  time tac.
Qed.

End FOFProblem.