(** *Indexed functional programming *)

Require Ascii String.
From Equations Require Import Equations.
Require FunctionalExtensionality.
Require Import MPRICoq.Monad.

(** **Typing `sprintf` *)
Module sprintf.
  Import Ascii String.
  Open Scope list_scope.
  Open Scope char_scope.
  Open Scope string_scope.

  Inductive format : Type :=
  | digitf (k : format) : format
  | stringf (k : format) : format
  | symbf (c : ascii)(k : format) : format
  | endf : format.

  Fixpoint parse (s : string) : format :=
    match s with
    | String "%" (String "d" tl) => digitf (parse tl)
    | String "%" (String "s" tl) => stringf (parse tl)
    | String "%" (String c tl) | String c tl => symbf c (parse tl)
    | EmptyString => endf
    end.

  Fixpoint format_type (fmt : format) : Type :=
    match fmt with
    | digitf k => nat -> (format_type k)
    | stringf k => string -> (format_type k)
    | symbf c k => (format_type k)
    | endf => string
    end.
  Notation "⟦ fmt ⟧" := (format_type fmt).

  Definition parse_and_type (s : string) :=
    ⟦ (parse s) ⟧.
  Notation "⟦p s ⟧" := (parse_and_type s).

  Fixpoint show_nat (n : nat) : string :=
    match n with
    | O => "O"
    | S n => "S(" ++ (show_nat n) ++ ")"
    end.

  Fixpoint eval (fmt : format) (acc : string) : ⟦ fmt ⟧ :=
    match fmt return ⟦ fmt ⟧ with
    | digitf k => fun n => eval k (acc ++ (show_nat n))
    | stringf k => fun s => eval k (acc ++ s)
    | symbf c k => eval k (acc ++ String c "")
    | endf => acc
    end.

  Definition sprintf (fmt : string) : ⟦p fmt ⟧ :=
    eval (parse fmt) "".

  Example test : sprintf "test %%d & %%s: %d & %s" 2 "hello world!"
                 = "test %d & %s: S(S(O)) & hello world!".
  Proof. reflexivity. Qed.
End sprintf.

(** **Computing normal forms of λ-terms *)
Module NormalForms.

  (** ***Types and terms *)

  Inductive type : Type :=
  | unit : type
  | arrow (t1 t2 : type) : type
  | prod (t1 t2 : type) : type.
  Notation "t1 ⇒ t2" := (arrow t1 t2) (at level 30).
  Notation "t1 × t2" := (prod t1 t2) (at level 30).

  Inductive context : Type :=
  | ϵ : context
  | ext_context (Γ : context) (t : type) : context.
  Notation "Γ ▷ t" := (ext_context Γ t) (at level 40).
  Derive NoConfusion for context.

  Inductive in_env : type -> context -> Type :=
  | here {t Γ} : in_env t (Γ ▷ t)
  | there {t t' Γ} : in_env t Γ -> in_env t (Γ ▷ t').
  Notation "t ∈ Γ" := (in_env t Γ) (at level 50).
  Derive Signature for in_env.

  Reserved Notation "Γ ⊢ t" (at level 50).
  Inductive has_type : context -> type -> Type :=
  | lam {Γ s t} :
      (Γ ▷ s) ⊢ t ->
      Γ ⊢ s ⇒ t
  | var {Γ t} :
      t ∈ Γ ->
      Γ ⊢ t
  | app {Γ s t} :
      Γ ⊢ s ⇒ t -> Γ ⊢ s ->
      Γ ⊢ t
  | tt {Γ} : Γ ⊢ unit
  | pair {Γ a b} :
      Γ ⊢ a -> Γ ⊢ b ->
      Γ ⊢ a × b
  | fst {Γ a b} :
      Γ ⊢ a × b ->
      Γ ⊢ a
  | snd {Γ a b} :
      Γ ⊢ a × b ->
      Γ ⊢ b
  where "Γ ⊢ t" := (has_type Γ t).

  (** ***Interlude: substitution, structurally *)

  Module Fin.
    Inductive fin : nat -> Type :=
    | zero {n : nat} : fin (S n)
    | suc {n : nat} (i : fin n) : fin (S n).
    Derive Signature for fin.

    Fact fin_eq_suc {n} : forall (i j : fin n), suc i = suc j -> i = j.
    Proof.
      intros i j Heq.
      inversion Heq.
      apply Eqdep.EqdepTheory.inj_pair2 in H0. assumption.
    Qed.

    Reserved Notation "x ⊇ y" (at level 50).
    Inductive geq : nat -> nat -> Type :=
    | id {m} : m ⊇ m
    | weak1 {m n} : m ⊇ n -> (S m) ⊇ n
    | weak2 {m n} : m ⊇ n -> (S m) ⊇ (S n)
    where "x ⊇ y" := (geq x y).
    Derive Signature for geq.

    Equations mono_inter {m n : nat} (Hgeq : m ⊇ n) (l : fin n) : fin m :=
      { mono_inter id k := k;
        mono_inter (weak1 wk) v := suc (mono_inter wk v);
        mono_inter (weak2 wk) zero := zero;
        mono_inter (weak2 wk) (suc k) := suc (mono_inter wk k) }.
    Notation "⟦ wk ⟧" := (mono_inter wk).

    (* TODO *)
    (* Lemma lemma_valid : forall m n k l (wk : m ⊇ n), k <= l -> ⟦ wk ⟧ k <= ⟦ wk ⟧ l. *)
  End Fin.

  (** We can adapt this intentional characterization of monotone functions
      to typed embeddings *)
  Reserved Notation "x ⊇ y" (at level 50).
  Inductive geq : context -> context -> Type :=
  | id {Γ} : Γ ⊇ Γ
  | weak1 {Γ Δ t} : Δ ⊇ Γ -> Δ ▷ t ⊇ Γ
  | weak2 {Γ Δ t} : Δ ⊇ Γ -> Δ ▷ t ⊇ Γ ▷ t
  where "x ⊇ y" := (geq x y).

  Equations shift {Γ Δ T}: (Γ ⊇ Δ) -> (T ∈ Δ) -> T ∈ Γ :=
    { shift id v := v;
      shift (weak1 wk) v := there (shift wk v);
      shift (weak2 wk) here := here;
      shift (weak2 wk) (there v) := there (shift wk v) }.

  Equations rename {Γ Δ T}: (Γ ⊇ Δ) -> (Δ ⊢ T) -> Γ ⊢ T :=
    { rename wk (lam t) := lam (rename (weak2 wk) t);
      rename wk (var v) := var (shift wk v);
      rename wk (app f s) := app (rename wk f) (rename wk s);
      rename wk tt := tt;
      rename wk (pair a b) := pair (rename wk a) (rename wk b);
      rename wk (fst p) := fst (rename wk p);
      rename wk (snd p) := snd (rename wk p) }.

  (* Equations sub {Γ Δ t}: (Γ ⊢ t) -> (forall {s}, s ∈ Γ -> Δ ⊢ s) -> Δ ⊢ t := *)
  (*   { sub (lam t) ρ := lam (sub t (fun s H  with H := *)
  (*                                   { | here := var here; *)
  (*                                     | there v := rename (weak1 id) (ρ _ v) }; *)
  (*                                   (* match H in s ∈ Δ ▷ s return Δ ▷ s ⊢ s with *) *)
  (*                                   (* | here => var here *) *)
  (*                                   (* | (there v) => rename (weak1 id) (ρ _ v) *) *)
  (*                                   (* end)); *) *)
  (*     sub (var v) ρ := ρ _ v; *)
  (*     sub (app f s) ρ := app (sub f ρ) (sub s ρ); *)
  (*     sub tt ρ := tt; *)
  (*     sub (pair a b) ρ := pair (sub a ρ) (sub b ρ); *)
  (*     sub (fst p) ρ := fst (sub p ρ); *)
  (*     sub (snd p) ρ := snd (sub p ρ) }. *)

  Definition sub : forall {Γ Δ T}, (Γ ⊢ T) -> (forall {S}, S ∈ Γ -> Δ ⊢ S) -> Δ ⊢ T.
  Proof.
    fix sub 4.
    intros Γ Δ T v ρ.
    destruct v as [? ? ? v|? ? v|? ? ? f x| |? ? ? v1 v2|? ? ? p|? ? ? p].
    - (* lam *) refine (lam (sub _ _ _ v _)).
      intros x Hx. inversion Hx; subst.
      + exact (var here).
      + eapply rename; eauto.
        apply weak1. apply id.
    - (* var *) exact (ρ _ v).
    - (* app *) exact (app (sub _ _ _ f ρ) (sub _ _ _ x ρ)).
    - (* tt *) exact tt.
    - (* pair *) exact (pair (sub _ _ _ v1 ρ) (sub _ _ _ v2 ρ)).
    - (* fst *) exact (fst (sub _ _ _ p ρ)).
    - (* snd *) exact (snd (sub _ _ _ p ρ)).
  Defined.

  Definition sub1 {Γ T1 T2} (v : Γ ▷ T1 ⊢ T2) (s : Γ ⊢ T1) : Γ ⊢ T2.
  Proof.
    eapply sub; eauto.
    intros x Hx. inversion Hx; subst; clear Hx.
    - exact s.
    - exact (var H1).
  Defined.

  (** Some examples to check it computes *)
  Compute (sub1 (fst (var here)) (pair tt tt)).
  Compute (sub1 (pair (var here) (var (there here))) tt).
  Compute (sub1 (lam (var here)) tt).
  Compute (sub1 (lam (var (there here))) tt).

  (* Equations weak_comp {Δ Σ Γ} : (Δ ⊇ Σ) -> (Γ ⊇ Δ) -> Γ ⊇ Σ := *)
  (*   { weak_comp wk id := wk; *)
  (*     weak_comp wk' (weak1 wk) := weak1 (weak_comp wk' wk); *)
  (*     weak_comp id (weak2 wk) := weak2 wk; *)
  (*     weak_comp (weak1 wk') (weak2 wk) := weak1 (weak_comp wk' wk); *)
  (*     weak_comp (weak2 wk') (weak2 wk) := weak2 (weak_comp wk' wk) }. *)
  Definition weak_comp : forall {Δ Σ Γ}, (Δ ⊇ Σ) -> (Γ ⊇ Δ) -> (Γ ⊇ Σ).
  Proof.
    fix weak_comp 5.
    intros Δ Σ Γ wk1 wk2.
    inversion wk2; subst; clear wk2.
    - exact wk1.
    - apply weak1; eauto.
    - inversion wk1; subst; clear wk1.
      + apply weak2; auto.
      + apply weak1; eauto.
      + apply weak2; eauto.
  Defined.
  Notation "x ∘wk y" := (weak_comp x y) (at level 60).

  Lemma comp_right_unit : forall {Γ Δ} (wk : Γ ⊇ Δ), wk ∘wk id = wk.
  Proof. reflexivity. Qed.

  Lemma comp_left_unit : forall {Γ Δ} (wk : Γ ⊇ Δ), id ∘wk wk = wk.
  Proof.
    induction wk; simpl.
    - reflexivity.
    - unfold eq_rec_r, eq_rec, eq_rect; simpl.
      rewrite IHwk. reflexivity.
    - unfold eq_rec_r, eq_rec, eq_rect; simpl.
      reflexivity.
  Qed.

  Lemma comp_assoc : forall {Γ Δ Σ Ω} (wk3 : Γ ⊇ Δ) (wk2 : Δ ⊇ Σ) (wk1 : Σ ⊇ Ω),
      (wk1 ∘wk wk2) ∘wk wk3 = wk1 ∘wk (wk2 ∘wk wk3).
  Proof.
    fix comp_assoc 5.
    intros Γ Δ Σ Ω wk3 wk2 wk1.
    destruct wk1; simpl.
    - repeat rewrite comp_assoc. reflexivity.
    - unfold eq_rec_r, eq_rec, eq_rect; simpl.
      repeat rewrite comp_assoc. reflexivity.
    - admit.
  Admitted.

  (** **Normal forms *)
  Module Model1.

    (** We can represent the equation theory as an inductive family: *)
    (* Reserved Notation "Γ ⊢ T ∋ t ⤳ s" (at level 70). *)
    Inductive βη_norm : forall (Γ : context) (T : type), Γ ⊢ T -> Γ ⊢ T -> Prop :=
    | rule_β : forall{Γ T S}{b : Γ ▷ S ⊢ T}{s : Γ ⊢ S},
        βη_norm Γ T (app (lam b) s) (sub1 b s)
    | rule_η_fun : forall{Γ T S}{f : Γ ⊢ S ⇒ T},
        βη_norm Γ (S ⇒ T) f (lam (app (rename (weak1 id) f) (var here)))
    | rule_η_pair : forall{Γ A B}{p : Γ ⊢ A × B},
        βη_norm Γ (A × B) p (pair (fst p) (snd p)).

    Inductive βη_eq : forall (Γ : context) (T : type), Γ ⊢ T -> Γ ⊢ T -> Prop :=
    | inc : forall {Γ T t1 t2},
        βη_norm Γ T t1 t2 ->
        βη_eq Γ T t1 t2
    | refl : forall {Γ T t},
        βη_eq Γ T t t
    | sym : forall {Γ T t1 t2},
        βη_eq Γ T t1 t2 ->
        βη_eq Γ T t2 t1
    | trans : forall {Γ T t1 t2 t3},
        βη_eq Γ T t1 t2 -> βη_eq Γ T t2 t3 ->
        βη_eq Γ T t1 t3
    | struct_lam : forall{Γ S T b b'},
        βη_eq (Γ ▷ S) T b b' ->
        βη_eq Γ (S ⇒ T) (lam b) (lam b')
    | struct_app : forall{Γ S T f f' s s'},
        βη_eq Γ (S ⇒ T) f f' -> βη_eq Γ S s s' ->
        βη_eq Γ T (app f s) (app f' s')
    | struct_pair : forall{Γ A B a a' b b'},
        βη_eq Γ A a a' -> βη_eq Γ B b b' ->
        βη_eq Γ (A × B) (pair a b) (pair a' b')
    | struct_fst : forall{Γ A B p p'},
        βη_eq Γ (A × B) p p' ->
        βη_eq Γ A (fst p) (fst p')
    | struct_snd : forall{Γ A B p p'},
        βη_eq Γ (A × B) p p' ->
        βη_eq Γ B (snd p) (snd p').

    (** ***Compute η-long β-normal forms for the simply typed λ-calculus: *)
    Inductive term : Type :=
    | Lam (v : String.string) (b : term) : term
    | Var (v : String.string) : term
    | App (f s : term) : term
    | Tt : term
    | Pair (a b : term) : term
    | Fst (p : term) : term
    | Snd (p : term) : term.

    Reserved Notation "⟦ T ⟧Type".
    Fixpoint interp_type (T : type) : Type :=
      match T with
      | unit => term
      | T1 ⇒ T2 => ⟦ T1 ⟧Type -> ⟦ T2 ⟧Type
      | T1 × T2 => ⟦ T1 ⟧Type * ⟦ T2 ⟧Type
      end
    where "⟦ T ⟧Type" := (interp_type T).

    Reserved Notation "⟦ Γ ⟧context".
    Fixpoint interp_context (Γ : context) : Type :=
      match Γ with
      | ϵ => Datatypes.unit
      | Γ ▷ T1 => ⟦ Γ ⟧context * ⟦ T1 ⟧Type
      end
    where "⟦ Γ ⟧context" := (interp_context Γ).

    Definition interp_type_context (Γ : context) (T : type) : Type :=
      ⟦ Γ ⟧context -> ⟦ T ⟧Type.
    Notation "Γ ⊩ T" := (interp_type_context Γ T) (at level 50).

    Fixpoint lookup {Γ T} (v : T ∈ Γ) : Γ ⊩ T :=
      match v with
      | here => fun '(_, x) => x
      | there h => fun '(γ, _) => lookup h γ
      end.

    Fixpoint eval {Γ T} (t : Γ ⊢ T) : Γ ⊩ T :=
      match t with
      | var v => fun ρ => lookup v ρ
      | app f s => fun ρ => eval f ρ (eval s ρ)
      | lam b => fun ρ => fun s => eval b (ρ, s)
      | pair a b => fun ρ => (eval a ρ , eval b ρ)
      | fst p => fun ρ => Datatypes.fst (eval p ρ)
      | snd p => fun ρ => Datatypes.snd (eval p ρ)
      | tt => fun _ => Tt
      end.

    (** Let us, for simplicity, assume that we have access to a fresh name
      generator, `gensym` *)
    Axiom gensym : Datatypes.unit -> String.string.

    (** We could then back-translate the objects in the model (`⟦_⟧Type`)
      back to raw terms (through `reify`). However, to do so, one needs to
      inject variables in η-long normal form into the model: this is the
      role of `reflect`: *)
    Equations reify (T : type) : ⟦ T ⟧Type -> term :=
      { reify unit t => t;
        reify (T1 ⇒ T2) t => let freshx := gensym Datatypes.tt in
                            Lam freshx (reify T2 (t (reflect T1 (Var freshx))));
        reify (T1 × T2) (f, s) => Pair (reify T1 f) (reify T2 s)
      } with reflect (T : type) : term -> ⟦ T ⟧Type :=
        { reflect unit t => t;
          reflect (T1 ⇒ T2) t => fun s => reflect T2 (App t (reify T1 s));
          reflect (T1 × T2) t => (reflect T1 (Fst t), reflect T2 (Snd t))
        }.

    (** Given a λ-term, we can thus compute its normal form: *)
    Fixpoint idC (Γ : context) : ⟦ Γ ⟧context :=
      match Γ with
      | ϵ => Datatypes.tt
      | (Γ ▷ T) => (idC Γ, reflect T (Var (gensym Datatypes.tt)))
      end.
    Definition norm {Γ T} Δ := reify T (eval Δ (idC Γ)).

    (** Just like in the previous lecture, we can use it to check whether any two
      terms belong to the same congruence class by comparing their normal forms *)
    Definition term1 : ϵ ⊢ (unit ⇒ unit) ⇒ (unit ⇒ unit) :=
      (* λ s. λ z. s (s z) *)
      lam (lam (app (var (there here)) (app (var (there here)) (var here)))).

    Definition term2 : ϵ ⊢ (unit ⇒ unit) ⇒ (unit ⇒ unit) :=
      (* λ s. (λ r. λ z. r (s z)) (λ x. s x) *)
      lam (app (lam (lam (app (var (there here))
                              (app (var (there (there here))) (var here)))))
               (lam (app (var (there here)) (var here)))).

    Example test_nbe : norm term1 = norm term2.
    Proof. reflexivity. Qed.

    (** For instance, thanks to a suitable model construction, we have
      surjective pairing *)
    Definition term3 : ϵ ⊢ (unit × unit) ⇒ (unit × unit) :=
      (* λ p. p *)
      lam (var here).

    Definition term4 : ϵ ⊢ (unit × unit) ⇒ (unit × unit) :=
      (* λ p. (fst p, snd p) *)
      lam (pair (fst (var here)) (snd (var here))).

    Example test_nbe2 : norm term3 = norm term4.
    Proof. reflexivity. Qed.

    (** However, this implementation is a bit of wishful thinking: we do not
      have a `gensym`! So the following is also true, for the bad reason
      that `gensym` is not actually producing unique names but always the
      same name (itself): *)
    Definition term5 : ϵ ⊢ unit ⇒ (unit ⇒ unit) :=
      (* λ z1 z2. z1 *)
      lam (lam (var (there here))).

    Definition term6 : ϵ ⊢ unit ⇒ (unit ⇒ unit) :=
      (* λ z1 z2. z2 *)
      lam (lam (var here)).

    Example test_nbe3 : norm term5 = norm term6.
    Proof. reflexivity. Qed. (* BUG ! *)
  End Model1.

  (** This might not deter the brave monadic programmer: we can emulate
      `gensym` using a reenactment of the state monad: *)
  Module Fresh.
    Import FunctionalExtensionality.

    Definition Fresh (A : Type) : Type := nat -> (A * nat).
    Definition gensym (tt : Datatypes.unit) : Fresh String.string :=
      fun n => (sprintf.show_nat n, 1 + n).

    Program Instance FreshMonad : Monad Fresh :=
      {
        ret _ x := fun n => (x, n);
        bind _ _ x k := fun n => let (a, n') := x n in k a n'
      }.
    Next Obligation.
      apply functional_extensionality; intro n.
      destruct (x n) as [a n']. reflexivity.
    Qed.
    Next Obligation.
      apply functional_extensionality; intro n.
      destruct (x n) as [a n'].
      destruct (f a n') as [a1 n1].
      reflexivity.
    Qed.

  (** We then simply translate the previous code to a monadic style, a
      computer could do it automatically: *)
    (* Equations reify (T : type) : ⟦ T ⟧Type -> Fresh term := *)
    (*   { reify unit t => ret t; *)
    (*     reify (T1 × T2) (a, b) => *)
    (*     reify T1 a >>= *)
    (*           fun a => reify T2 b >>= *)
    (*                       fun b => ret (Pair a b); *)
    (*     reify (T1 ⇒ T2) f => *)
    (*     gensym Datatypes.tt >>= *)
    (*            fun s => reflect T1 (Var s) >>= *)
    (*                          fun t => reify T2 (f t) >>= *)
    (*                                      fun b => ret (Lam s b) *)
    (*   } with reflect (T : type) : term -> Fresh ⟦ T ⟧Type := *)
    (*     { reflect unit t => ret t; *)
    (*       reflect (T1 × T2) t => *)
    (*       reflect T1 (Fst t) >>= *)
    (*               fun a => reflect T2 (Snd t) >>= *)
    (*                             fun b => ret (a, b); *)
    (*       reflect (T1 ⇒ T2) t => ret (fun s => _) *)
    (*     }. *)
    (* cannot conclude with `reflect T (neu ! reify s)` *)
  End Fresh.

  (** **The Rising Sea *)
  Module Model2.

    Reserved Notation "Γ ⊢Nf T" (at level 50).
    Reserved Notation "Γ ⊢Ne T" (at level 50).
    Inductive has_type_nf (Γ : context) : type -> Type :=
    | Lam {S T} (b : Γ ▷ S ⊢Nf T) : Γ ⊢Nf S ⇒ T
    | Pair {A B} (a : Γ ⊢Nf A) (b : Γ ⊢Nf B) : Γ ⊢Nf A × B
    | Tt : Γ ⊢Nf unit
    | Ground (grnd : Γ ⊢Ne unit) : Γ ⊢Nf unit
    where "Γ ⊢Nf T" := (has_type_nf Γ T)
    with has_type_ne (Γ : context) : type -> Type :=
         | Var {T} (v : T ∈ Γ) : Γ ⊢Ne T
         | App {S T} (f : Γ ⊢Ne S ⇒ T) (s : Γ ⊢Nf S) : Γ ⊢Ne T
         | Fst {A B} (p : Γ ⊢Ne A × B) : Γ ⊢Ne A
         | Snd {A B} (p : Γ ⊢Ne A × B) : Γ ⊢Ne B
    where "Γ ⊢Ne T" := (has_type_ne Γ T).
    Arguments Lam {_ _ _}. Arguments App {_ _ _}.
    Arguments Tt {_}. Arguments Ground {_}. Arguments Var {_ _}.
    Arguments Fst {_ _ _}. Arguments Snd {_ _ _}. Arguments Pair {_ _ _}.

    Reserved Notation "⎣ t ⎦Nf".
    Reserved Notation "⎣ t ⎦Ne".
    Fixpoint nf_to_term {Γ T} (t : Γ ⊢Nf T) : Γ ⊢ T :=
      match t with
      | Lam b => lam ⎣ b ⎦Nf
      | Ground grnd => ⎣ grnd ⎦Ne
      | Pair a b => pair ⎣ a ⎦Nf ⎣ b ⎦Nf
      | Tt => tt
      end
    where "⎣ t ⎦Nf" := (nf_to_term t)
    with ne_to_term {Γ T} (t : Γ ⊢Ne T) : Γ ⊢ T :=
           match t with
           | Var v => var v
           | App f s => app ⎣ f ⎦Ne ⎣ s ⎦Nf
           | Fst p => fst ⎣ p ⎦Ne
           | Snd p => snd ⎣ p ⎦Ne
           end
    where "⎣ t ⎦Ne" := (ne_to_term t).

    Class Sem : Type :=
      { sem_context : context -> Type;
        ren {Γ Δ} : Γ ⊇ Δ -> sem_context Δ -> sem_context Γ
      }.

    Local Set Warnings "-implicits".
    Definition context_and_type (P Q : Sem) : Type :=
      forall {Γ}, @sem_context P Γ -> @sem_context Q Γ.
    Notation "P ⟦⊢⟧ Q" := (context_and_type P Q) (at level 80).

    Fixpoint rename_Nf {Γ Δ T} (wk : Γ ⊇ Δ) (t : Δ ⊢Nf T) : Γ ⊢Nf T :=
      match t with
      | Lam b => Lam (rename_Nf (weak2 wk) b)
      | Ground grnd => Ground (rename_Ne wk grnd)
      | Pair a b => Pair (rename_Nf wk a) (rename_Nf wk b)
      | Tt => Tt
      end
    with rename_Ne {Γ Δ T} (wk : Γ ⊇ Δ) (t : Δ ⊢Ne T) : Γ ⊢Ne T :=
           match t with
           | Var v => Var (shift wk v)
           | App f s => App (rename_Ne wk f) (rename_Nf wk s)
           | Fst p => Fst (rename_Ne wk p)
           | Snd p => Snd (rename_Ne wk p)
           end.

    Instance Nf (T : type) : Sem :=
      { sem_context Γ := Γ ⊢Nf T;
        ren _ _ := rename_Nf }.

    Instance Ne (T : type) : Sem :=
      { sem_context Γ := Γ ⊢Ne T;
        ren _ _ := rename_Ne }.

    (** Following our earlier model, we will interpret the `unit` type as
        the normal forms of type `unit`: *)
    Definition sem_unit : Sem := Nf unit.
    Notation "⟦unit⟧" := sem_unit.

    Definition sem_tt {P} : P ⟦⊢⟧ ⟦unit⟧ := fun _ _ => Tt.
    Notation "⟦tt⟧" := sem_tt.

    (** Similarly, we will interpret the `_×_` type as a product in
        `Sem`, defined in a pointwise manner: *)
    Instance sem_prod (P Q : Sem) : Sem :=
      { sem_context Γ := Datatypes.prod (@sem_context P Γ) (@sem_context Q Γ);
        ren _ _ wk '(x, y) := (@ren P _ _ wk x, @ren Q _ _ wk y) }.
    Notation "P ⟦×⟧ Q" := (sem_prod P Q) (at level 70).

    Definition sem_pair {P Q R} : P ⟦⊢⟧ Q -> P ⟦⊢⟧ R -> P ⟦⊢⟧ Q ⟦×⟧ R :=
      fun a b ρ Γ => (a ρ Γ, b ρ Γ).
    Notation "⟦pair⟧" := sem_pair.

    Definition sem_fst {P Q R} : P ⟦⊢⟧ Q ⟦×⟧ R -> P ⟦⊢⟧ Q :=
      fun p ρ Γ => Datatypes.fst (p ρ Γ).
    Notation "⟦fst⟧" := sem_fst.

    Definition sem_snd {P Q R} : P ⟦⊢⟧ Q ⟦×⟧ R -> P ⟦⊢⟧ R :=
      fun p ρ Γ => Datatypes.snd (p ρ Γ).
    Notation "⟦snd⟧" := sem_snd.

    (** ***Interlude: Yoneda lemma *)
    (* TODO *)

    (** ***Back to the Sea *)
    Instance sem_arrow (P Q : Sem) : Sem :=
      { sem_context Γ := forall {Δ}, Δ ⊇ Γ -> @sem_context P Δ -> @sem_context Q Δ;
        ren _ _ wk1 k _ wk2 := k _ (wk1 ∘wk wk2) }.
    Notation "P ⟦⇒⟧ Q" := (sem_arrow P Q) (at level 70).

    Definition sem_lam {P Q R} : P ⟦×⟧ Q ⟦⊢⟧ R -> P ⟦⊢⟧ Q ⟦⇒⟧ R :=
      fun η _ p _ wk q => η _ (ren wk p , q).
    Notation "⟦lam⟧" := sem_lam.

    Definition sem_app {P Q R} : P ⟦⊢⟧ Q ⟦⇒⟧ R -> P ⟦⊢⟧ Q -> P ⟦⊢⟧ R :=
      fun η μ _ px => η _ px _ id (μ _ px).
    Notation "⟦app⟧" := sem_app.

    (** At this stage, we have enough structure to interpret the types *)
    Reserved Notation "⟦ T ⟧".
    Fixpoint interp_type (T : type) : Sem :=
      match T with
      | unit => ⟦unit⟧
      | T1 ⇒ T2 => ⟦ T1 ⟧ ⟦⇒⟧ ⟦ T2 ⟧
      | T1 × T2 => ⟦ T1 ⟧ ⟦×⟧ ⟦ T2 ⟧
      end
    where "⟦ T ⟧" := (interp_type T).

    (** To interpret contexts, we also need a terminal object: *)
    Instance terminal : Sem :=
      { sem_context _ := Datatypes.unit;
        ren _ _ _ _ := Datatypes.tt }.
    Notation "⟦⊤⟧" := terminal.

    Reserved Notation "⟦ Γ ⟧C".
    Fixpoint interp_context (Γ : context) : Sem :=
      match Γ with
      | ϵ => ⟦⊤⟧
      | Γ ▷ T => ⟦ Γ ⟧C ⟦×⟧ ⟦ T ⟧
      end
    where "⟦ Γ ⟧C" := (interp_context Γ).

    (** As usual, a type in context will be interpreted as a morphism between
        their respective interpretations. The interpreter then takes the
        syntactic object to its semantical counterpart: *)
    Definition sem_has_type (Γ : context) (T : type) : Type :=
      ⟦ Γ ⟧C ⟦⊢⟧ ⟦ T ⟧.
    Notation "Γ ⊩ T" := (sem_has_type Γ T) (at level 80).

    Fixpoint lookup {Γ T} (v : T ∈ Γ) : Γ ⊩ T :=
      match v with
      | here => fun _ '(_, v) => v
      | there x => fun _ '(γ, _) => lookup x _ γ
      end.

    Fixpoint eval {Γ T} (t : Γ ⊢ T) : Γ ⊩ T :=
      match t with
      | lam b => ⟦lam⟧ (eval b)
      | var v => lookup v
      | app f s => ⟦app⟧ (eval f) (eval s)
      | tt => ⟦tt⟧
      | pair a b => ⟦pair⟧ (eval a) (eval b)
      | fst p => ⟦fst⟧ (eval p)
      | snd p => ⟦snd⟧ (eval p)
      end.

    (** Reify and reflect are defined for a given syntactic context, we
        therefore introduce suitable notations: *)

    Definition synt_has_type (Γ : context) (T : type) : Type :=
      @sem_context ⟦T⟧ Γ.
    Notation "[ Γ ]⊩ T" := (synt_has_type Γ T) (at level 80).

    Definition synt_has_context (Γ Δ : context) : Type :=
      @sem_context ⟦Δ⟧C Γ.
    Notation "[ Γ ]⊩C Δ" := (synt_has_context Γ Δ) (at level 80).

    (** The sea has sufficiently risen: we can implement our initial plan,
        using the renaming operator `ren` equipping `Sem` in the function
        case in `reify`: *)

    Fixpoint reify {Γ} (T : type) : [ Γ ]⊩ T -> Γ ⊢Nf T :=
      match T with
      | unit => fun v => v
      | T1 ⇒ T2 =>
        fun f => Lam (reify T2 ((ren (weak1 id) f) _ id (reflect T1 (Var here))))
      | A × B => fun '(a, b) => Pair (reify A a) (reify B b)
      end
    with reflect {Γ} (T : type) : Γ ⊢Ne T -> [ Γ ]⊩ T :=
           match T with
           | unit => Ground
           | T1 ⇒ T2 =>
             fun v _ w s => reflect T2 (App (@ren (Ne _) _ _ w v) (reify T1 s))
           | A × B => fun v => (reflect A (Fst v), reflect B (Snd v))
           end.

    Fixpoint idC (Γ : context) : [ Γ ]⊩C Γ :=
      match Γ with
      | ϵ => Datatypes.tt
      | (Γ ▷ T) => (ren (weak1 id) (idC Γ), reflect T (Var here))
      end.
    Definition reify_id {Γ T} (f : Γ ⊩ T) : Γ ⊢Nf T :=
      reify _ (f _ (idC Γ)).

    Definition norm {Γ T} (t : Γ ⊢ T) : Γ ⊢Nf T :=
      reify_id (eval t).
  End Model2.
End NormalForms.

(** **Optional: Categorical spotting *)
(* TODO *)


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

(* $Id$ *)

(** * Finite sets library : conversion to old [Finite_sets] *)

Require Import Ensembles Finite_sets.
Require Import MSetInterface MSetProperties OrdersEx.

(** * Going from [MSets] with usual Leibniz equality
    to the good old [Ensembles] and [Finite_sets] theory. *)

Module WS_to_Finite_set (U:UsualDecidableType)(M: WSetsOn U).
 Module MP:= WPropertiesOn U M.
 Import M MP FM Ensembles Finite_sets.

 Definition mkEns : M.t -> Ensemble M.elt :=
   fun s x => M.In x s.

 Notation " !! " := mkEns.

 Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x.
 Proof.
 unfold In; compute; auto with extcore.
 Qed.

 Lemma Subset_Included : forall s s',  s[<=]s'  <-> Included _ (!!s) (!!s').
 Proof.
 unfold Subset, Included, In, mkEns; intuition.
 Qed.

 Notation " a === b " := (Same_set M.elt a b) (at level 70, no associativity).

 Lemma Equal_Same_set : forall s s', s[=]s' <-> !!s === !!s'.
 Proof.
 intros.
 rewrite double_inclusion.
 unfold Subset, Included, Same_set, In, mkEns; intuition.
 Qed.

 Lemma empty_Empty_Set : !!M.empty === Empty_set _.
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intro; set_iff; inversion 1.
 Qed.

 Lemma Empty_Empty_set : forall s, Empty s -> !!s === Empty_set _.
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intros.
 destruct(H x H0).
 inversion H0.
 Qed.

 Lemma singleton_Singleton : forall x, !!(M.singleton x) === Singleton _ x .
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intro; set_iff; inversion 1; try constructor; auto.
 Qed.

 Lemma union_Union : forall s s', !!(union s s') === Union _ (!!s) (!!s').
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intro; set_iff; inversion 1; [ constructor 1 | constructor 2 | | ]; auto.
 Qed.

 Lemma inter_Intersection : forall s s', !!(inter s s') === Intersection _ (!!s) (!!s').
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intro; set_iff; inversion 1; try constructor; auto.
 Qed.

 Lemma add_Add : forall x s, !!(add x s) === Add _ (!!s) x.
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intro; set_iff; inversion 1; auto with sets.
 inversion H0.
 constructor 2; constructor.
 constructor 1; auto.
 Qed.

 Lemma Add_Add : forall x s s', MP.Add x s s' -> !!s' === Add _ (!!s) x.
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intros.
 red in H; rewrite H in H0.
 destruct H0.
 inversion H0.
 constructor 2; constructor.
 constructor 1; auto.
 red in H; rewrite H.
 inversion H0; auto.
 inversion H1; auto.
 Qed.

 Lemma remove_Subtract : forall x s, !!(remove x s) === Subtract _ (!!s) x.
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intro; set_iff; inversion 1; auto with sets.
 split; auto.
 contradict H1.
 inversion H1; auto.
 Qed.

 Lemma mkEns_Finite : forall s, Finite _ (!!s).
 Proof.
 intro s; pattern s; apply set_induction; clear s; intros.
 intros; replace (!!s) with (Empty_set elt); auto with sets.
 symmetry; apply Extensionality_Ensembles.
 apply Empty_Empty_set; auto.
 replace (!!s') with (Add _ (!!s) x).
 constructor 2; auto.
 symmetry; apply Extensionality_Ensembles.
 apply Add_Add; auto.
 Qed.

 Lemma mkEns_cardinal : forall s, cardinal _ (!!s) (M.cardinal s).
 Proof.
 intro s; pattern s; apply set_induction; clear s; intros.
 intros; replace (!!s) with (Empty_set elt); auto with sets.
 rewrite MP.cardinal_1; auto with sets.
 symmetry; apply Extensionality_Ensembles.
 apply Empty_Empty_set; auto.
 replace (!!s') with (Add _ (!!s) x).
 rewrite (cardinal_2 H0 H1); auto with sets.
 symmetry; apply Extensionality_Ensembles.
 apply Add_Add; auto.
 Qed.

 (** we can even build a function from Finite Ensemble to MSet
     ... at least in Prop. *)

 Lemma Ens_to_MSet : forall e : Ensemble M.elt, Finite _ e ->
   exists s:M.t, !!s === e.
 Proof.
 induction 1.
 exists M.empty.
 apply empty_Empty_Set.
 destruct IHFinite as (s,Hs).
 exists (M.add x s).
 apply Extensionality_Ensembles in Hs.
 rewrite <- Hs.
 apply add_Add.
 Qed.

End WS_to_Finite_set.

Module S_to_Finite_set (U:UsualOrderedType)(M: SetsOn U) :=
  WS_to_Finite_set U M.


Require Import Preorder.
Require Import Cat.Category.

Require Import Coq.Program.Basics.
Require Import Coq.Logic.Classical_Prop.

Definition gt_both {p : PrO} (s t gt : undertype_pro p) : Prop
    := ordering p s gt /\ ordering p t gt.

Definition is_join (p : PrO) (s t joined : undertype_pro p) : Prop
    := gt_both s t joined
        /\ (forall alternate : undertype_pro p,
                gt_both s t alternate -> ordering p joined alternate).

Class PreorderWithAllJoins (p : PrO)
    (join : undertype_pro p -> undertype_pro p -> undertype_pro p)
        : Prop := Build_PreorderWithAllJoins {
                is_actual_join : forall (s t : undertype_pro p),
                    is_join p s t (join s t)
            }.

Inductive PrOJ : Type
    := cons_proj
        (p : PrO)
        (join : undertype_pro p -> undertype_pro p -> undertype_pro p)
        (proj_inst : PreorderWithAllJoins p join) : PrOJ.

Definition underpro (p : PrOJ) : PrO := match p with cons_proj p' _ _ => p' end.

Definition undertype_proj (p : PrOJ) : Type := undertype_pro (underpro p).

Definition join (p : PrOJ) : undertype_proj p -> undertype_proj p -> undertype_proj p
    := match p with cons_proj _ join _ => join end.

Definition preserves_joins {P Q : PrOJ} (f : PrOHom (underpro P) (underpro Q)) : Prop
    := forall (x y : undertype_proj P),
            (join Q (pro_fn f x) (pro_fn f y) = pro_fn f (join P x y)).

Definition PrOJHom (P Q : PrOJ) : Type :=
    { f : PrOHom (underpro P) (underpro Q) | preserves_joins f }.

Definition proj_hom {P Q : PrOJ} (hom : PrOJHom P Q) : PrOHom (underpro P) (underpro Q)
    := match hom with exist f _ => f end.

Definition proj_fn {P Q : PrOJ} (hom : PrOJHom P Q) : undertype_proj P -> undertype_proj Q
   := pro_fn (proj_hom hom).

Theorem proj_hom_eq (P Q : PrOJ) (f g : PrOJHom P Q) : proj_fn f = proj_fn g -> f = g.
    destruct f as [f pf].
    destruct g as [g pg].
    unfold proj_fn; unfold proj_hom.
    intro H.
    assert (f = g).
       apply pro_hom_eq;
       exact H.
    subst f.
    f_equal.
    apply proof_irrelevance.
Qed.

Definition id_proj (P : PrOJ) : PrOJHom P P.
    refine (exist _ (id_pro (underpro P)) _).
    destruct P.
    unfold preserves_joins.
    reflexivity.
Defined.

Definition comp_proj {P Q R : PrOJ} (f : PrOJHom Q R) (g : PrOJHom P Q) : PrOJHom P R.
    refine (exist _ (comp_pro _ _ _ (proj_hom f) (proj_hom g)) _).
    destruct f as [f pF]; destruct g as [g pG].
    destruct P; destruct Q; destruct R.
    unfold preserves_joins in *.
    simpl in *.
    unfold compose.
    intros.
    rewrite pF.
    rewrite pG.
    reflexivity.
Defined.

Instance PrJIsCat : Category id_proj (@comp_proj).
    split;
        intros;
        apply proj_hom_eq;
        reflexivity.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat ssrint.
From mathcomp Require Import fintype (*tuple *) finfun bigop  (*fingroup perm*).
From mathcomp Require Import ssralg zmodp matrix mxalgebra poly (* polydiv *)
  mxpoly.

(*
Only works with pure ring expressions, and I couldn't find any in this proof.
Maybe it would work with "generalize <expr>; field"? TODO: try that.
From mathcomp.algebra_tactics Require Import ring .
 *)

From mathcomp Require Import algC.
Require Import Lia.
From Hammer Require Import Tactics .

Require Import Friendship.square_char_poly.
Require Import Friendship.matrix_lemmas.

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

(*Import GroupScope.*)
Import GRing.Theory.
Local Open Scope ring_scope.

From mathcomp Require Import tuple seq.

Ltac ssrnat_lia := rewrite /leq /subn /subn_rec /addn /addn_rec
                     /muln /muln_rec; lia.
Section adj2_matrix_props.

  Definition R := algC.
  Context (n k: nat) (kge1: (k >=1) %N) (nge1: (n >= 1) %N).

  Definition matN := 'M[R]_(1%N + (n-1)%N).

  Definition P : matN := (@block_mx _ 1 (n-1)%N 1 (n-1)%N
                            (const_mx 1)  (const_mx 1)
                            (const_mx 1) ((-1)%:M)).

  (* Proof by computation; Use the block determinant formula to show
   that the determinant is ±n, and then use the field characteristic
   assumption to show that it's not zero. *)
  Lemma P_unit : P \in unitmx.

    have neg1M_det m :
      (\det ((-1)%:M : 'M[R]_m)) = (-1) ^+ (odd m) by
      rewrite det_scalar -[in LHS]signr_odd.

    have neg1M_unit m : ((-1)%:M : 'M[R]_m) \in unitmx
        by rewrite unitmxE neg1M_det; case: (odd m);
      rewrite ?expr1 ?expr0 ?unitrN1 ?unitr1.

    rewrite unitmxE  det_block // neg1M_det (pinvmxE (neg1M_unit _))
     invmx_scalar det_mx11  invrN1  scalar_mxC
            -mulmxA dotmul  mul_scalar_mx scalemx_const  !mxE mulN1r opprK
            -{2}(mulr1n 1) -mulrnDr.
    generalize nge1;
      case n => [_|n' _] //= ;
                rewrite subSS  /subn /subn_rec  PeanoNat.Nat.sub_0_r  unitfE .

    suff aou: (@GRing.natmul (ZmodType algC _ ) 1 (1 + n')) != 0.
    case: (odd n') => //=; rewrite ?expr1 ?expr0 ?unitrN1 ?unitr1;
                      apply: GRing.mulf_neq0;
                      [ exact (lreg_neq0 (lregN (@lreg1 _)))
                      | exact (aou )|   |exact (aou) ].
    exact (oner_neq0 _).

    by rewrite -[(1+n')%N]/n'.+1  (iffLR (charf0P _) Cchar _).
  Qed.

  Definition diag_vec : 'rV[R]_(1 + (n-1)) :=
    (row_mx ((k+n-1)%:R%:M : 'rV_1)
       (@const_mx R _ _ (k-1)%:R : 'rV_(n-1))).

  Definition adj2_diag : matN := diag_mx diag_vec.

  Lemma adj_diag_block_form : adj2_diag = @block_mx _ 1 (n-1)%N 1 (n-1)%N
                                            (const_mx (k+n-1)%:R) 0
                                            0            (k-1)%:R%:M.
    rewrite /adj2_diag /diag_vec diag_mx_row diag_const_mx.

    suff oeua: (diag_mx (@scalar_mx _ 1 (k+n-1)%N%:R)) =
                 (@const_mx R 1 1 (k+n-1)%N%:R)
      by rewrite oeua.

    by rewrite (mx11_scalar (const_mx _)) (mx11_scalar (diag_mx _)) !mxE
    //=.
  Qed.

  Definition adj2 : 'M[R]_(1 + (n-1))  := (const_mx 1) +
                                            (k-1)%:R%:M.

  Lemma adj2_block_form :
    adj2 = @block_mx _ 1 (n-1)%N 1 (n-1)%N
             (const_mx k%:R)     (const_mx 1)
             (const_mx 1)        ((const_mx 1) + (k - 1)%:R%:M).
  Proof.
    rewrite -(@submxK R 1 (n-1)%N 1 (n-1)%N adj2).

    have -> : (@ulsubmx _ 1 _ 1 _ adj2) = const_mx k%:R.
    {
      apply/matrixP=> i j; rewrite !mxE .

      have {i} {j} -> : lshift (n - 1) i == lshift (n - 1) j
        by rewrite !ord1; apply/eqP.

      rewrite -{1}(mulr1n 1) -mulrnDr.
      suff -> : (1 + (k - 1))%N = k by [].
      {
        by move: kge1; case k => [|k' _] //=; ssrnat_lia.
      }
    }

    have -> : (@ursubmx _ 1 _ 1 _ adj2) = const_mx 1. {
      apply/matrixP=> i j; rewrite !mxE !ord1.
      have -> : (lshift (n - 1) 0 == rshift 1 j) = false
        by rewrite eq_lrshift.
      by rewrite mulr0n addr0.
    }

    have -> : (@dlsubmx _ 1 _ 1 _ adj2) = const_mx 1. {
      apply/matrixP=> i j; rewrite !mxE !ord1.
      have -> : (rshift 1 i == lshift (n-1) 0) = false
        by rewrite eq_rlshift.
      by rewrite mulr0n addr0.
    }

    suff -> : (@drsubmx _ 1 _ 1 _ adj2) = const_mx 1 + (k - 1)%:R%:M by []. {
      by apply/matrixP=> i j; rewrite !mxE eq_rshift.
    }
  Qed.

  Lemma D_m_P_eq : P *m adj2 = adj2_diag *m P.

    rewrite /P adj2_block_form adj_diag_block_form
      !mulmx_block !mul0mx !addr0 !add0r !mul_scalar_mx
      (mx11_scalar (const_mx (k + n - 1)%:R)) (mx11_scalar (const_mx 1))
      [in RHS](mx11_scalar (const_mx 1))
      !mxE -scalar_mxM //= !mul_scalar_mx !scalemx_const !mulr1  scale_scalar_mx.

    (* Top left block : *)
    rewrite mul1r dotmul  (mx11_scalar (const_mx k%:R))
      (mx11_scalar (const_mx (n-1)%:R))
      !mxE (mx11_scalar (k%:R%:M + (n - 1)%:R%:M)) mxE  !(mxE _ _ 0 0) //=
      !mulr1n -natrD.
    have -> : (k + (n - 1))%N = (k + n -1)%N
      by move:  nge1 => /ltP; ssrnat_lia.

    (* Bot left block: *)
    rewrite scalar_mxC mul_scalar_mx scalemx_const mulr1.
    have ->:
      (@const_mx R (n-1) 1 k%:R + const_mx (-1)) = const_mx (k-1)%:R .
    apply/matrixP => i j; rewrite !mxE.
    move: kge1; case: k => [//| k' _].

    by rewrite /subn /subn_rec //= PeanoNat.Nat.sub_0_r  [_.+1]/((1+k')%N) -/addn
         natrD addrC addrA (addNr 1) add0r.
    (* bot left block done *)

    (* 1×1^T = ones; used in 2 places. *)
    have -> : (@const_mx R (n-1) (n-1) 1) =
                (const_mx 1 : 'cV__) *m (const_mx 1 : 'rV__).
    apply/matrixP => i j; rewrite !mxE  (eq_bigr (fun=>1))  ?big_const_ord
                            ?iter_addr ?addr0 //=.
    by move=> i' _; rewrite !mxE mulr1.
    (* end proof  of 1×1 = ones*)

    (* Top right piece *)
    rewrite mulmxDr  [in LHS]mulmxA dotmul
      (mx11_scalar (const_mx _)) (mxE _ _ 0 0)
      mul_scalar_mx  mul_mx_scalar !scalemx_const -!raddfD //=.

    have -> : 1 + ((n - 1)%:R * 1 + (k - 1)%:R * 1) = ((k + n - 1)%:R :R).
    rewrite !mulr1  -{1}[in 1](mulr1n 1) -!natrD.
    suff -> : (1 + (n - 1 + (k - 1)))%N = (k + n - 1)%N by [].
    by move: nge1 kge1 => /ltP nge1' /ltP kge1'; ssrnat_lia.

    (* Top right piece done *)

    (* Bot right piece *)
    by rewrite scaleN1r [in -(_ + _)] raddfD //=  addrA addrN add0r mulrN1
       -mulNrn -raddfN //= mulNrn.
  Qed.

  Lemma diagonalizable_m : adj2 ~_P adj2_diag.
    by apply/simmxW; [ rewrite row_free_unit; exact P_unit
                     |  exact D_m_P_eq].
  Qed.

  Lemma char_poly_adj2: char_poly adj2 =
                          ('X - ((k + n - 1)%:R)%:P) * ('X - ((k - 1)%:R)%:P) ^+ (n - 1).
  Proof.
    rewrite (simmx_charpoly P_unit diagonalizable_m).
    have adj2_trig : is_trig_mx adj2_diag
      by apply: (is_diag_mx_is_trig (diag_mx_is_diag _)).
    rewrite (char_poly_trig adj2_trig).

    rewrite (@big_split_ord _ _ _ 1%N (n-1) _ _) //= adj_diag_block_form
      (eq_bigr (fun=> ('X-((k + n - 1)%:R :R) %:P))); last first.
    {
      move=>i _; rewrite block_mxEul.
      suff -> : (@const_mx R 1 1 (k + n - 1)%:R i i) = (k + n - 1)%:R by [].
      by rewrite mxE.
    }

    rewrite [in X in _*X](eq_bigr (fun=> ('X-((k - 1)%:R) %:P))); last first.
    {
      move=>i _; rewrite block_mxEdr.
      suff -> : ((k - 1)%:R%:M i i) = ((k - 1)%:R :R) by [].
      rewrite mxE //=.
      have -> : (i==i) by apply/eqP .
      by rewrite mulr1n.
    }

    by rewrite !big_const_ord !iter_mulr !mulr1 expr1.

  Qed.

  Definition lams : (1+(n-1)).-tuple algC := cons_tuple (k + n - 1)%:R
                                               (nseq_tuple (n-1) (k - 1)%:R).
  Lemma lams_prod: char_poly adj2 = \prod_(l <- lams) ('X - l%:P).
    rewrite char_poly_adj2  /lams big_cons.
    apply: f_equal.
    rewrite big_tnth.
    rewrite (eq_bigr (fun => ('X-((k - 1)%:R) %:P))); last first. {
      move=> i _.
      by rewrite tvalK  tcastE tnth_nseq.
    }
    by rewrite big_const_ord iter_mulr mulr1  size_tuple.
  Qed.

  Definition is_square_root A := A *m A = adj2.
  (*From mathcomp Require Import seq.*)

  Lemma adj_mtx_char_poly adj :
    is_square_root adj ->
    (*char_poly mtx = \prod_(μ <- μs) ('X - μ %:P) ->*)
    { μs' : (1+(n-1)).-tuple R |
      char_poly adj = \prod_(μ <- μs') ('X - μ %:P) &
        all2 (fun μ λ => μ^2 == λ) μs' (cons_tuple (k + n - 1)%:R
                                         (nseq_tuple (n-1) (k - 1)%:R))
    }.
  Proof.
    move=> adj2_eq.
    set p := char_poly adj.
    have [μs' prop] := closed_field_poly_normal p.
    rewrite (monicP (char_poly_monic adj)) scale1r in prop.
    have deg_p := size_char_poly adj.
    have size_μs' : (seq.size μs') == (1 + (n-1))%N by
      subst p; rewrite prop size_prod_XsubC  in deg_p; apply /eqP; congruence.
    clear deg_p.
    simpl in *.
    set tμs' := (@Tuple _ _ μs' size_μs').
    have tp : p = \prod_(z <- tμs') ('X - z%:P)
      by rewrite prop; apply: eq_bigr.

    have p_X2 : p \Po 'X^2 = \prod_(μ <- tμs') ('X^2 - μ%:P)
      by rewrite tp (big_endo (fun q=> q\Po 'X^2)
                       (fst (comp_poly_multiplicative 'X^2) )
                       (snd (comp_poly_multiplicative 'X^2) )
           );
      apply/eq_bigr => μ _;
                       rewrite comp_polyD comp_polyX -polyCN comp_polyC.

    set p_μ2 := (\prod_(μ <- tμs') ('X^2 - (μ%:P)^2) : {poly algC}).
    have p_μ2_eq : p_μ2 = (\prod_(μ <- tμs') ('X - (μ%:P))) *
                            (\prod_(μ <- tμs') ('X + (μ%:P))) . {
      subst p_μ2;
        rewrite (eq_bigr (fun μ => ('X - μ%:P) * ('X + μ%:P))) //=. {
        by rewrite big_split //=.
      }
      by move=> μ _; rewrite subr_sqr.
    }

    rewrite -tp in p_μ2_eq.
    have μs_subst :
      \prod_(μ <- tμs') ('X + μ%:P) = ((-1)^+(1+(n-1)))%:P * (p \Po (-'X)). {
      clear  p_X2 p_μ2 p_μ2_eq adj2_eq  k kge1.
      rewrite (eq_bigr (fun μ => (-1)*(-'X - μ%:P))); last first.
      by move=>  μ _; rewrite mulrDr !mulN1r !opprK.
      rewrite big_split //=.

      have  -> : (\prod_(i <- μs') -1) =
                   ((-1)^+(1+(n-1))). {
        move=> RR.
        clear prop tμs' tp p  adj .
        have <- : seq.size μs' = (1 + (n - 1))%N by apply: eqP; exact size_μs'.
        clear size_μs'.
        elim: μs' => [|μs''].
        by rewrite -signr_odd  expr0 big_nil.
        move=> l indL.
        rewrite big_cons indL.
        rewrite -exprS.
        suff -> : (seq.size l).+1 = seq.size (μs'' :: l) by [].
        sauto.
      }
      have -> : (-1) ^+ (1 + (n - 1)) = ((-1) ^+ (1 + (n - 1)))%:P. {
        clear prop tμs' tp  p adj .
        move=> RR.
        generalize ((1 + (n - 1)%N)%N) => nn.
        rewrite -signr_odd -[in RHS]signr_odd.
        case: (odd nn) => //=; rewrite ?expr0 ?expr1.
        by rewrite rmorphN1.
      }

      rewrite prop.
      rewrite (big_endo (fun q=> q \Po (-'X))
                 (fst (comp_poly_multiplicative (-'X) ))
                 (snd (comp_poly_multiplicative (-'X) ))
              ).
      rewrite [in RHS](eq_bigr (fun μ => -'X - μ%:P)) //=; last first. {
        move => μ _.
        by rewrite comp_polyB comp_polyX comp_polyC.
      }
    }

    rewrite {}μs_subst in p_μ2_eq.
    have pNx_det : p \Po - 'X = \det ( -('X%:M) - map_mx polyC adj ). {
      clear k kge1 nge1 adj2_eq μs' prop size_μs' tμs' tp p_X2 p_μ2 p_μ2_eq.
      rewrite /p /char_poly /char_poly_mx -det_map_mx //=.
      suff -> : map_mx (comp_poly (- 'X)) ('X%:M - map_mx polyC adj) =
                  - 'X%:M - map_mx polyC adj by []. {
        rewrite map_mxD //= map_scalar_mx  //= comp_polyX rmorphN //=.
        suff -> : map_mx (comp_poly (- 'X)) (- map_mx polyC adj) = - map_mx polyC adj
          by []. {
          rewrite rmorphN //=  -map_mx_comp //=.
          suff -> : map_mx (comp_poly (- 'X) \o polyC) adj = map_mx polyC adj by []. {
            suff : comp_poly (- 'X) \o polyC =1 polyC
              by move=> comp_comp;
                        apply/matrixP => i j;
                                         rewrite !mxE (comp_comp _).
            by move=> R {p adj } c //=;
                        rewrite comp_polyC.
          }
        }
      }
    }
    rewrite {}pNx_det in p_μ2_eq.
    have p_μ2_det : p_μ2 = \det (('X^2)%:M  - map_mx polyC adj2). {
      subst p; rewrite {}p_μ2_eq.
      clear  μs' prop size_μs' tμs' tp p_X2 p_μ2.
      have -> : ((-1) ^+ (1 + (n - 1)))%:P = ((-1) ^+ (1 + (n - 1))). {
        generalize ((1 + (n - 1))%N).
        move=> nn R.
        rewrite -signr_odd -[in RHS]signr_odd.
        case: (odd nn) => //=; rewrite ?expr0 ?expr1.
        by rewrite rmorphN1.
      }
      by rewrite -detZ scaleN1r opprB opprK  /char_poly /char_poly_mx
         -det_mulmx  mulmxDl !mulmxDr  -rmorphN //= -scalar_mxM;
         apply: f_equal;
         rewrite [in X in X + _]addrC  expr2
           [in X in _ + _ + X]addrC addrA  map_mxN //=  comm_mx_scalar
         -[in X in X + (- _ *m _)]addrA -mulmxDr addrN mulmx0 addr0;
         apply: f_equal;
         rewrite -adj2_eq  map_mx_is_multiplicative //=  mulNmx.
    }
    clear p_μ2_eq p_X2.
    set q := char_poly adj2.
    have p_μ2_q : p_μ2 = q \Po 'X^2. {
      rewrite p_μ2_det /q /char_poly /char_poly_mx  -det_map_mx //=.
      apply: f_equal.

      rewrite [in RHS]map_mxD //= [in RHS]map_scalar_mx  //= comp_polyX.
      rewrite rmorphN //=.
      repeat apply: f_equal.

      suff -> : map_mx (comp_poly ('X^2)) ( map_mx polyC adj2) = map_mx polyC adj2
        by []. {
        rewrite  -map_mx_comp //=.
        by apply/matrixP => i j; rewrite !mxE //= comp_polyC.
      }
    }

    have aoeu : q \Po 'X^2 = \prod_(μ <- tμs') ('X^2 - (μ ^ 2)%:P). {
      rewrite -p_μ2_q /p_μ2.
      suff : forall μ, (μ ^ 2)%:P = (μ%:P ^ 2 : {poly algC}). {
        move=> hyp.
        apply eq_bigr => μ _.
        by rewrite (hyp μ).
      } {
        move=> μ.
        by rewrite !exprSzr !expr0z !mul1r  polyC_multiplicative.
      }
    }

    have [μs prop2 prop3] := (polys_and_squares_technical_lemma lams_prod aoeu).
    exists μs. {
      by rewrite tp prop2.
    } {
      exact prop3.
    }
  Qed.

End adj2_matrix_props.


(*
 - Adjoint equivalences preserve initial objects
*)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.

Require Import Integers.WildCategories.WildCat.
Require Import Integers.WildCategories.DispWildCat.
Require Import Integers.WildCategories.Invertible_2cells.
Require Import Integers.WildCategories.WildFunctor.
Import WildFunctor.Notations.
Require Import Integers.WildCategories.WildNaturalTransformation.
Import WildNaturalTransformation.Notations.
Require Import Integers.WildCategories.WildNaturalIsomorphism.
Require Import Integers.WildCategories.Initial.
Require Import Integers.WildCategories.AdjointEquivalence.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

(** Adjunctions preserve initial objects **)
Lemma adjunction_preserves_initial
      {C D : wild_cat}
      (A : adjoint_equivalence C D)
      (i : initial_object C)
  : initial_object D.
Proof.
  use build_initial_object.
    - exact (adj_left A i).
    - exact (λ d, #(adj_left A) (initial_mor i (adj_right A d)) · (adj_counit A d)).
    - intros d f g.
      pose (initial_2cell
               (adj_unit A i · #(adj_right A) f)
               (adj_unit A i · #(adj_right A) g)) as θ.
      exact (linvunitor f
                        • ((adj_tL A i)^-1 ▹ f)
                        • rassociator _ _ _
                        • (#(adj_left A) (adj_unit A i) ◃ $(adj_counit A) f)
                        • lassociator _ _ _
                        • (wild_functor_comp (adj_left A) _ _ ▹ adj_counit A d)
                        • (##(adj_left A) θ ▹ adj_counit A d)
                        • ((wild_functor_comp (adj_left A) _ _)^-1 ▹ adj_counit A d)
                        • rassociator _ _ _
                        • (#(adj_left A) (adj_unit A i) ◃ ($(adj_counit A) g)^-1)
                        • lassociator _ _ _
                        • (adj_tL A i ▹ g)
                        • lunitor g).
Qed.

Lemma adjunction_preserves_initial_inv
      {C D : wild_cat}
      (A : adjoint_equivalence C D)
      (j : initial_object D)
  : initial_object C.
Proof.
  use build_initial_object.
    - exact (adj_right A j).
    - exact (λ c, #(adj_right A) (initial_mor j (adj_left A c))
                   · wild_nat_iso_trans_inv (adj_unit A) c).
    - intros c f g.
      pose (initial_2cell
               (wild_nat_iso_trans_inv (adj_counit A) j · #(adj_left A) f)
               (wild_nat_iso_trans_inv (adj_counit A) j · #(adj_left A) g)) as θ.
      exact (linvunitor f
                        • ((adj_tR_inv A j)^-1 ▹ f)
                        • rassociator _ _ _
                        • (_ ◃ $(wild_nat_iso_trans_inv (adj_unit A)) f)
                        • lassociator _ _ _
                        • (wild_functor_comp (adj_right A) _ _ ▹ _)
                        • (##(adj_right A) θ ▹ _)
                        • ((wild_functor_comp (adj_right A) _ _)^-1 ▹ _)
                        • rassociator _ _ _
                        • (_ ◃ ($(wild_nat_iso_trans_inv (adj_unit A)) g)^-1)
                        • lassociator _ _ _
                        • (adj_tR_inv A j ▹ _)
                        • lunitor g).
Qed.


Require Import Functor.
Require Import CommaCategory.
Require Import FunctorCategory.
Require Import Delta.
Require Import Diagrams.
Require Import MetaCategory.

Polymorphic Definition Cone{D A: Cat}(F: Fun D A): CAT :=
  CommaCat (delta D A) (oneFun (FUN D A) F).

Polymorphic Definition cone{D A: Cat}{F: Fun D A}
    (N: A)
    (psi: forall X, Hom N (F X)):
    (forall{X Y: D}(f: Hom X Y), eq_h (comp (fmap F f) (psi X)) (psi Y)) ->
    Cone F.

  intro H. simpl.
  refine (Build_CommaOb _ _ _
    (delta D A) (oneFun (FUN D A) F)
    N one_X
    (Build_NatTrans _ _ (delta D A N) (oneFun (FUN D A) F one_X) psi _)).
  intros X Y f. simpl.
  transitivity (psi Y). apply H.
  symmetry. apply (ident_r A).
Defined.

Polymorphic Definition cone_Ob{D A: Cat}{F: Fun D A}: Fun (Cone F) A :=
  CommaDomFun _ _.

Polymorphic Definition cone_Hom{D A: Cat}{F: Fun D A}(L: Cone F)(X: D): Hom (cone_Ob L) (F X) :=
  fmap (CommaHomFun _ _ L) two_f X.

Polymorphic Lemma cone_prop{D A: Cat}{F: Fun D A}(L: Cone F):
    forall{X Y: D}(f: Hom X Y), eq_h (comp (fmap F f) (cone_Hom L X)) (cone_Hom L Y).
Proof.
  intros X Y f.
  transitivity (comp (cone_Hom L Y) (id _)).
  apply (natTrans_natural (fmap (CommaHomFun _ _ L) two_f) X Y f).
  apply (ident_r A).
Qed.

Polymorphic Definition coneHom{D A: Cat}{F: Fun D A}
    (X Y: Cone F)
    (f: Hom (cone_Ob X) (cone_Ob Y)):
    (forall d: D, eq_h (cone_Hom X d) (comp (cone_Hom Y d) f)) ->
    Hom X Y.
  intro H.
  refine {|
    commaHom_fst := f;
    commaHom_snd := one_f;
  |}.
  intro d.
  symmetry.
  transitivity (commaOb_f X d).
  destruct one_f.
  apply (ident_l (FUN D A)).
  apply (H d).
Defined.

Polymorphic Record Lim{D A: Cat}(F: Fun D A) := {
  limit_cone    :> Cone F;
  limit_terminal:  terminal limit_cone
}.

Polymorphic Definition lim{D A: Cat}{F: Fun D A}(Y: Cone F)
    (f: forall X, Hom X Y):
    (forall X' f', eq_h (f X') f') ->
    Lim F.

  intro H.
  refine {|
    limit_cone := Y;
    limit_terminal := {|
      terminal_hom  := f;
      terminal_uniq := H
    |}
  |}.
Defined.

Polymorphic Lemma lim_equalizer{A: Cat}{X Y: A}{f g: Hom X Y}
  (L: Lim (equalizerFun f g)):
  let e := cone_Hom L equalizer_X: Hom (cone_Ob L) X in
    eq_h (comp f e) (comp g e).
Proof.
  intro e.
  transitivity (cone_Hom L equalizer_Y).
  apply (cone_prop L equalizer_f).
  symmetry.
  apply (cone_prop L equalizer_g).
Qed.

Polymorphic Lemma lim_pullback{A: Cat}{Xf Xg Y: A}{f: Hom Xf Y}{g: Hom Xg Y}
  (L: Lim (pullbackFun f g)):
  let f' := cone_Hom L pullback_Xg: Hom (cone_Ob L) Xg in
  let g' := cone_Hom L pullback_Xf: Hom (cone_Ob L) Xf in
    eq_h (comp f g') (comp g f').
Proof.
  intros f' g'.
  transitivity (cone_Hom L pullback_Y).
  apply (cone_prop L pullback_f).
  symmetry.
  apply (cone_prop L pullback_g).
Qed.


(** * Indu\u00e7\u00e3o em Coq *)

Set Warnings "-notation-overridden,-parsing".
Add LoadPath "/Users/marcosmonteiro/desktop/coq".
Require Export aula06_listas.

(* ############################################### *)
(** * Listas polim\u00f3rficas *)

(** Polimorfismo permite criar defini\u00e7\u00f5es abstraindo
    os tipos de dados que ser\u00e3o manipulados. *)

Inductive list (X:Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

(** Agora, [list] \u00e9 uma fun\u00e7\u00e3o de [Type]s para
    [Type]s. Dado um tipo [X], [list X] \u00e9 o conjunto
    de listas indutivamente definidas cujos elementos
    possuem tipo [X]. *)

Check list.
(* ===> list : Type -> Type *)
Check (nil nat).
(* ===> nil nat : list nat *)
Check (cons nat 3 (nil nat)).
(* ===> cons nat 3 (nil nat) : list nat *)
Check nil.
(* ===> nil : forall X : Type, list X *)
Check cons.
(* ===> cons : forall X : Type, X -> list X -> list X *)

(** Fun\u00e7\u00f5es sobre listas polim\u00f3rficas. *)

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

Example test_repeat1 :
  repeat nat 4 2 =
  cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity.  Qed.

Example test_repeat2 :
  repeat bool false 1 =
  cons bool false (nil bool).
Proof. reflexivity.  Qed.

(** Coq possui um mecanismo de infer\u00eancia. *)

Fixpoint repeat' X x count : list X :=
  match count with
  | 0        => nil X
  | S count' => cons X x (repeat' X x count')
  end.

Check repeat'.
(* ===> forall X : Type, X -> nat -> list X *)
Check repeat.
(* ===> forall X : Type, X -> nat -> list X *)

(** \u00c9 importante ter um equil\u00edbrio entre o
    que \u00e9 inferido e o que \u00e9 informado:
    - inferido: + pr\u00e1tica, dificultar entendimento
    - informado: - pr\u00e1tico, facilitar entendimento. *)

(** \u00c9 poss\u00edvel indicar argumentos impl\u00edcitos: [_]. *)

Fixpoint repeat'' X x count : list X :=
  match count with
  | 0        => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

(** \u00c9 poss\u00edvel omitir at\u00e9 o [_]. A diretiva
    [Arguments] especifica o nome de uma fun\u00e7\u00e3o
    (ou construtor) e, em seguida, lista os nomes
    dos seus argumentos, com chaves limitando
    os argumentos que ser\u00e3o impl\u00edcitos. Se a
    fun\u00e7\u00e3o tiver argumentos sem nome, usar [_]. *)

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

(** Agora \u00e9 poss\u00edvel escrever o seguinte. *)

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

(** Tamb\u00e9m \u00e9 poss\u00edvel usar chaves na pr\u00f3pria
    defini\u00e7\u00e3o da fun\u00e7\u00e3o. *)
Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0        => nil
  | S count' => cons x (repeat''' x count')
  end.

(** Sugest\u00e3o: usar a \u00faltima op\u00e7\u00e3o para fun\u00e7\u00f5es
    e a anterior para construtores indutivos.
    Em construtores, torna o tipo impl\u00edcito
    at\u00e9 para o tipo sendo definido pelo construtor.

    Em alguns casos, ser\u00e1 necess\u00e1rio informar
    explicitamente o tipo impl\u00edcito: [@]. *)

Fail Definition mynil := nil.

(** Alternativas:
    - Declarar o tipo explicitamente
    - Tornar expl\u00edcito o tipo impl\u00edcito. *)

Definition mynil : list nat := nil.

Check @nil.
Definition mynil' := @nil nat.

(** Outras fun\u00e7\u00f5es para listas polim\u00f3rficas. *)

Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil      => l2
  | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil      => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Example test_rev1 :
  rev (cons 1 (cons 2 nil)) =
  (cons 2 (cons 1 nil)).
Proof. reflexivity.  Qed.

Example test_rev2:
  rev (cons true nil) =
  cons true nil.
Proof. reflexivity.  Qed.

Example test_length1:
  length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity.  Qed.

(** Definindo uma sintaxe conveniente para listas. *)

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(** Agora, podemos escrever listas da seguinte forma. *)

Definition list123''' := [1; 2; 3].
Check (list123''').

(** **** Exercise: (poly_exercises)  *)
(** Complete as provas a seguir. *)

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
  (* COMPLETE AQUI *) Admitted.

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  (* COMPLETE AQUI *) Admitted.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  (* COMPLETE AQUI *) Admitted.

(* ############################################### *)
(** * Pares polim\u00f3rficos *)

Inductive prod (X Y : Type) : Type :=
| pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y) : type_scope.

(** A anota\u00e7\u00e3o [: type_scope] diz para Coq
    s\u00f3 usar esta abrevia\u00e7\u00e3o ao processar tipos.
    Isto impede conflitos com o s\u00edmbolo da
    multiplica\u00e7\u00e3o. *)

(** Algumas fun\u00e7\u00f5es \u00fateis. *)

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

(** A fun\u00e7\u00e3o a seguir combina lista de pares. *)

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

Example combine_test1 :
  combine [1;2;3] [0;10]
  = [(1,0);(2,10)].
Proof. reflexivity. Qed.

(** **** Exercise: (split)  *)
(** A fun\u00e7\u00e3o [split] \u00e9 a inversa direita de [combine]:
    dada uma lista de pares, retorna um par de listas. *)

Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y)
(* SUBSTITUA COM ":= _sua_defini\u00e7\u00e3o_ ." *). Admitted.

Example test_split:
  split [(1,false);(2,false)] =
  ([1;2],[false;false]).
Proof.
  (* COMPLETE AQUI *) Admitted.

(* ############################################### *)
(** * Option polim\u00f3rfico *)

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

Arguments Some {X} _.
Arguments None {X}.

(** Reescrevendo [nth_error]. *)

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | [] => None
  | a :: l' => if beq_nat n O then Some a
               else nth_error l' (pred n)
  end.

Example test_nth_error1 :
  nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 :
  nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.
Example test_nth_error3 :
  nth_error [true] 2 = None.
Proof. reflexivity. Qed.

(** **** Exercise: (hd_error_poly)  *)
(** Complete a defini\u00e7\u00e3o polim\u00f3rfica
    da fun\u00e7\u00e3o [hd_error]. *)

Definition hd_error {X : Type} (l : list X)
           : option X
(* SUBSTITUA COM ":= _sua_defini\u00e7\u00e3o_ ." *). Admitted.

Example test_hd_error1 :
  hd_error [1;2] = Some 1.
Proof. (* COMPLETE AQUI *) Admitted.

Example test_hd_error2 : hd_error  [[1];[2]]  = Some [1].
Proof. (* COMPLETE AQUI *) Admitted.

(* ############################################### *)
(** * Leitura sugerida *)

(** Software Foundations: volume 1
  - Polymorphism
  https://softwarefoundations.cis.upenn.edu/lf-current/Poly.html
*)


Require Import XR_Rmax.
Require Import XR_Rle_dec.
Require Import XR_Rle_antisym.
Require Import XR_Rmult_le_compat_l.
Require Import XR_Rnot_le_lt.

Local Open Scope R_scope.

Lemma RmaxRmult :
  forall (p q:R) r, R0 <= r -> Rmax (r * p) (r * q) = r * Rmax p q.
Proof.
  intros x y z h.
  unfold Rmax.
  destruct (Rle_dec (z*x) (z*y)) as [ hpl | hpr ] ;
  destruct (Rle_dec x y) as [ hl | hr ].
  { reflexivity. }
  {
    apply Rle_antisym.
    {
      apply Rmult_le_compat_l.
      { exact h. }
      {
        left.
        apply Rnot_le_lt.
        exact hr.
      }
    }
    { exact hpl. }
  }
  {
    apply Rle_antisym.
    {
      apply Rmult_le_compat_l.
      { exact h. }
      { exact hl. }
    }
    {
      left.
      apply Rnot_le_lt.
      exact hpr.
    }
  }
  { reflexivity. }
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.LegacyArithmetic.Interface.
Require Import Crypto.LegacyArithmetic.Double.Core.
Require Import Crypto.LegacyArithmetic.Double.Proofs.Decode.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.Tactics.BreakMatch.

Local Open Scope Z_scope.

Section bitwise_or.
  Context {n W}
          {decode : decoder n W}
          {is_decode : is_decode decode}
          {or : bitwise_or W}
          {is_or : is_bitwise_or or}.

  Global Instance is_bitwise_or_double
    : is_bitwise_or or_double.
  Proof using Type*.
    constructor; intros x y.
    destruct n as [|p|].
    { rewrite !(tuple_decoder_n_O (W:=W) 2); easy. }
    { assert (0 <= Z.lor (decode (fst x)) (decode (fst y)) < 2^Z.pos p) by auto with zarith.
      rewrite (tuple_decoder_2 x), (tuple_decoder_2 y), (tuple_decoder_2 (or_double x y))
        by apply Zle_0_pos.
      push_decode.
      apply Z.bits_inj'; intros; autorewrite with Ztestbit.
      break_match; Z.ltb_to_lt; autorewrite with Ztestbit; reflexivity. }
    { rewrite !(tuple_decoder_n_neg (W:=W) 2); easy. }
  Qed.
End bitwise_or.


Require Import UniDB.
Require Import List.

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

Inductive Tm : Set :=
  | var (i : Ix)
  | abs (t : Tm)
  | app (t1 t2 : Tm).

Section WsTm.

  Inductive WsTm (γ : Dom) : Tm → Prop :=
    | ws_var {i} (wi : γ ∋ i): ⟨ γ ⊢ var i ⟩
    | ws_abs {t} (wt : ⟨ S γ ⊢ t ⟩): ⟨ γ ⊢ abs t ⟩
    | ws_app {t1 t2} (wt1 : ⟨ γ ⊢ t1 ⟩) (wt2 : ⟨ γ ⊢ t2 ⟩):
        ⟨ γ ⊢ app t1 t2 ⟩
  where "⟨ γ ⊢ t ⟩" := (WsTm γ t).

  Global Instance iWsTm : Ws Tm := WsTm.

End WsTm.

Fixpoint trTm {Ξ : Type} `{Lk Tm Ξ, Up Ξ} (t : Tm) (ξ : Ξ) : Tm :=
  match t with
  | var i     => lk Tm Ξ ξ i
  | abs t     => abs (trTm t ξ↑₁)
  | app t1 t2 => app (trTm t1 ξ) (trTm t2 ξ)
  end.

Instance UniDBTm : UniDBVar Tm :=
  {| VrT := var; TrT := @trTm |}.
Instance UnidebTmLemmas : UniDBVarLemmas Tm.
Proof. unidb_derive_instance. Qed.

Instance UniDBTms : UniDBTerm Tm (list Tm) :=
  {| TrTX := fun Ξ lkTΞ upΞ ts ξ => map (fun t => tr Tm Tm Ξ t ξ) ts
  |}.

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

Definition subTm {X : Type} {trTmX : Tr Tm X} (s : Tm) (x : X) : X :=
  tr Tm X (Reg Tm) x (beta₁ Tm (Reg Tm) s).

Inductive Eval : Tm → Tm → Prop :=
  | e_app₁ {t₁ t₁' t₂ : Tm} :
      Eval t₁ t₁' → Eval (app t₁ t₂) (app t₁' t₂)
  | e_app₂ {t₁ t₂ t₂' : Tm} :
      Eval t₂ t₂' → Eval (app t₁ t₂) (app t₁ t₂')
  | e_abs  {t t' : Tm} :
      Eval t t' → Eval (abs t) (abs t')
  | e_beta₁ {s : Tm} {t : Tm} :
      Eval (app (abs t) s) (subTm s t).

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


Require Import Recdef.

From FormalSystems Require Import Base.

Inductive AExp : Type :=
    | AConst : nat -> AExp
    | Var : Loc -> AExp
    | Add : AExp -> AExp -> AExp
    | Sub : AExp -> AExp -> AExp
    | Mul : AExp -> AExp -> AExp
    | Div : AExp -> AExp -> AExp.

Inductive BExp : Type :=
    | BTrue : BExp
    | BFalse : BExp
    | Eq : AExp -> AExp -> BExp
    | Le : AExp -> AExp -> BExp
    | Not : BExp -> BExp
    | And : BExp -> BExp -> BExp
    | Or : BExp -> BExp -> BExp.

Inductive Com : Type :=
    | Skip : Com
    | Asgn : Loc -> AExp -> Com
    | Seq : Com -> Com -> Com
    | If : BExp -> Com -> Com -> Com
    | While : BExp -> Com -> Com.

Definition State : Type := Loc -> nat.

Definition initialState : State := fun _ => 0.

Definition changeState (s : State) (x : Loc) (n : nat) : State :=
  fun y : Loc => if x =? y then n else s y.

Fixpoint aeval (a : AExp) (s : State) : option nat :=
match a with
    | AConst n => Some n
    | Var v => Some (s v)
    | Add a1 a2 => liftM2 plus (aeval a1 s) (aeval a2 s)
    | Sub a1 a2 => liftM2 minus (aeval a1 s) (aeval a2 s)
    | Mul a1 a2 => liftM2 mult (aeval a1 s) (aeval a2 s)
    | Div a1 a2 =>
        match aeval a1 s, aeval a2 s with
            | _, Some 0 => None
            | Some n, Some m => Some (n / m)
            | _, _ => None
        end
end.

Fixpoint loca (a : AExp) : list Loc :=
match a with
    | AConst _ => []
    | Var x => [x]
    | Add a1 a2 => loca a1 ++ loca a2
    | Sub a1 a2 => loca a1 ++ loca a2
    | Mul a1 a2 => loca a1 ++ loca a2
    | Div a1 a2 => loca a1 ++ loca a2
end.

Definition acompatible (a : AExp) (s1 s2 : State) : Prop :=
  forall x : Loc, In x (loca a) -> s1 x = s2 x.

#[global] Hint Resolve in_or_app : core.

Lemma aeval_acompatible :
  forall {a : AExp} {s1 s2 : State},
    acompatible a s1 s2 -> aeval a s1 = aeval a s2.
Proof.
  unfold acompatible.
  induction a; cbn; intros; try f_equal; auto.
  rewrite (IHa1 s1 s2), (IHa2 s1 s2).
  destruct (aeval a1 s2), (aeval a2 s2).
  all: auto.
Qed.

Fixpoint beval (e : BExp) (s : State) : option bool :=
match e with
    | BTrue => Some true
    | BFalse => Some false
    | Eq a1 a2 => liftM2 Nat.eqb (aeval a1 s) (aeval a2 s)
    | Le a1 a2 => liftM2 Nat.leb (aeval a1 s) (aeval a2 s)
    | Not e' => omap negb (beval e' s)
    | And e1 e2 => liftM2 andb (beval e1 s) (beval e2 s)
    | Or e1 e2 => liftM2 orb (beval e1 s) (beval e2 s)
end.

Fixpoint locb (b : BExp) : list Loc :=
match b with
    | BTrue => []
    | BFalse => []
    | Eq a1 a2 => loca a1 ++ loca a2
    | Le a1 a2 => loca a1 ++ loca a2
    | Not b' => locb b'
    | And b1 b2 => locb b1 ++ locb b2
    | Or b1 b2 => locb b1 ++ locb b2
end.

Definition bcompatible (b : BExp) (s1 s2 : State) : Prop :=
  forall x : Loc, In x (locb b) -> s1 x = s2 x.

#[global] Hint Resolve aeval_acompatible : core.
#[global] Hint Unfold acompatible : core.

Lemma beval_bcompatible :
  forall {e : BExp} {s1 s2 : State},
    bcompatible e s1 s2 -> beval e s1 = beval e s2.
Proof.
  unfold bcompatible.
  induction e; cbn; intros; try f_equal; auto 7.
Qed.

Inductive CEval : Com -> State -> option State -> Prop :=
    | EvalSkip :
        forall s : State, CEval Skip s (Some s)
    | EvalAsgnNone :
        forall (v : Loc) (a : AExp) (s : State),
          aeval a s = None -> CEval (Asgn v a) s None
    | EvalAsgnSome :
        forall (v : Loc) (a : AExp) (s : State) (n : nat),
          aeval a s = Some n -> CEval (Asgn v a) s (Some (changeState s v n))
    | EvalSeqNone :
        forall (c1 c2 : Com) (s1 : State),
          CEval c1 s1 None -> CEval (Seq c1 c2) s1 None
    | EvalSeqSome :
        forall (c1 c2 : Com) (s1 s2 : State) (s3 : option State),
          CEval c1 s1 (Some s2) -> CEval c2 s2 s3 -> CEval (Seq c1 c2) s1 s3
    | EvalIfNone :
        forall (b : BExp) (c1 c2 : Com) (s1 : State),
          beval b s1 = None -> CEval (If b c1 c2) s1 None
    | EvalIfTrue :
        forall (b : BExp) (c1 c2 : Com) (s1 : State) (s2 : option State),
          beval b s1 = Some true -> CEval c1 s1 s2 ->
            CEval (If b c1 c2) s1 s2
    | EvalIfFalse :
        forall (b : BExp) (c1 c2 : Com) (s1 : State) (s2 : option State),
          beval b s1 = Some false -> CEval c2 s1 s2 ->
            CEval (If b c1 c2) s1 s2
    | EvalWhileNone :
        forall (b : BExp) (c : Com) (s : State),
          beval b s = None -> CEval (While b c) s None
    | EvalWhileFalse :
        forall (b : BExp) (c : Com) (s : State),
          beval b s = Some false -> CEval (While b c) s (Some s)
    | EvalWhileTrueNone :
        forall (b : BExp) (c : Com) (s1 : State),
          beval b s1 = Some true ->
          CEval c s1 None ->
            CEval (While b c) s1 None
    | EvalWhileTrueSome :
        forall (b : BExp) (c : Com) (s1 s2 : State) (s3 : option State),
          beval b s1 = Some true ->
          CEval c s1 (Some s2) -> CEval (While b c) s2 s3 ->
            CEval (While b c) s1 s3.

#[global] Hint Constructors CEval : core.

Lemma CEval_det :
  forall (c : Com) (s : State) (s1 : option State),
    CEval c s s1 -> forall s2 : option State, CEval c s s2 -> s1 = s2.
Proof.
  induction 1; intros.
  Ltac wut :=
  match goal with
      | H : CEval ?c _ _ |- _ => is_var c + inv H
  end;
  repeat match goal with
      | IH : forall _, CEval _ _ _ -> _, H : CEval _ _ _ |- _ =>
          let H' := fresh "H" in
            assert (H' := IH _ H); clear H; rename H' into H; subst
      | H : Some _ = Some _ |- _ => inv H
  end; eauto; try congruence.
  all: wut.
Qed.

Inductive E : Type :=
    | NoFuel : E
    | Div0 : E.

Function ceval (n : nat) (c : Com) (s : State) : E + State :=
match n with
    | 0 => inl NoFuel
    | S n' =>
        match c with
            | Skip => inr s
            | Asgn x a =>
                match aeval a s with
                    | None => inl Div0
                    | Some n => inr (changeState s x n)
                end
            | Seq c1 c2 =>
                match ceval n' c1 s with
                    | inr s' => ceval n' c2 s'
                    | x => x
                end
            | If b c1 c2 =>
                match beval b s with
                    | None => inl Div0
                    | Some true => ceval n' c1 s
                    | Some false => ceval n' c2 s
                end
            | While b c =>
                match beval b s with
                    | None => inl Div0
                    | Some true =>
                        match ceval n' c s with
                            | inr s' => ceval n' (While b c) s'
                            | x => x
                        end
                    | Some false => inr s
                end
        end
end.

Lemma ceval_CEval_inr :
  forall (n : nat) (c : Com) (s1 s2 : State),
    ceval n c s1 = inr s2 -> CEval c s1 (Some s2).
Proof.
  intros n c s1.
  functional induction ceval n c s1; intros; inv H; eauto.
    specialize (IHs _ H1). econstructor; eauto.
      destruct (ceval n' c1 s) eqn: Heq.
        inv H1.
        contradiction.
    destruct (ceval n' c0 s).
      inv H1.
      contradiction.
Qed.

#[global] Hint Resolve ceval_CEval_inr : core.

Lemma ceval_CEval_Div0 :
  forall (n : nat) (c : Com) (s1 : State),
    ceval n c s1 = inl Div0 -> CEval c s1 None.
Proof.
  intros n c s1.
  functional induction ceval n c s1; intros; inv H; eauto.
Qed.

Lemma while_true_do_skip :
  forall (s1 : State) (s2 : option State),
    ~ CEval (While BTrue Skip) s1 s2.
Proof.
  intros s1 s2 H.
  remember (While BTrue Skip) as w. revert Heqw.
  induction H; intros; inv Heqw.
    inv H.
    inv H.
    inv H0.
Qed.


(************************************************************************)
(* Copyright 2018 Frédéric Dabrowski                                    *)
(*
    This program is free software:: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    Foobar is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with Foobar.  If not, see <https://www.gnu.org/licenses/>.    *)
(************************************************************************)

Require Import Utf8.
Require Import Program.Basics.

Open Scope program_scope.

Notation "$" := (fun x y => y x) (at level 29).

Class Functor (f : Type -> Type) : Type :=
  {
    fmap : forall {A B : Type}, (A -> B) -> f A-> f B;
    functor_identity   : forall {A : Type}, fmap (@id A) = id;
    functor_compose : forall {A B C : Type} (f : B -> C) (g : A -> B),
        (fmap f ∘ fmap g) = fmap (f ∘ g)
  }.

Class Applicative (f : Type -> Type) `(E : Functor f)  : Type :=
  {
    pure : ∀ {A : Type}, A -> f A;
    ap : ∀ {A B : Type}, f (A -> B) -> f A -> f B;
    applicative_identity : ∀ {A : Type} (x : f A), ap (pure id) x = x;
    applicative_compose : ∀ {A B C : Type} (u : f (B -> C)) (v : f (A -> B)) (w : f A),
        ap (ap (ap (pure compose) u) v) w = ap u (ap v w);
    applicative_homomorphism :
      ∀ {A B : Type} (f : A -> B) (x : A), ap (pure f) (pure x) = pure (f x);
    applicative_interchange :
      ∀ {A B : Type} (u : f ( A -> B)) ( y : A), ap u (pure y) = ap (pure ($ y)) u;
    applicative_fmap : ∀ {A B : Type} (f : A -> B), fmap f  = ap (pure f)
  }.

(*Arguments fmap {f _ a b} g x.*)

Definition liftA (f : Type -> Type) `{E : Applicative f} (A B : Type) (g : A -> B) (a : f A) :=
  @ap f _ _ _ _ (pure g) a.

Definition liftA2 (f : Type -> Type) `{E : Applicative f} (A B C : Type) (g : A -> B -> C)
           (a : f A) (b : f B) : f C :=
  @ap f _ _ _ _ (fmap g a) b.

Declare Scope functor_scope.

Infix "<$>" := fmap (at level 28, left associativity, only parsing) : functor_scope.

Infix "<&>" := (flip fmap) (at level 28, left associativity, only parsing) : functor_scope.

Infix "<$" := (fmap ∘ const) (at level 28) : functor_scope.

Infix "($>)" := (flip (fmap ∘ const)) (at level 28) : functor_scope.

Infix "<*>" := ap (at level 28) : functor_scope.


Require Import Logic.Axiom.Extensionality.

Require Import Logic.Rel.R.
Require Import Logic.Rel.Id.
Require Import Logic.Rel.Domain.
Require Import Logic.Rel.Include.
Require Import Logic.Rel.Converse.
Require Import Logic.Rel.Intersect.
Require Import Logic.Rel.Composition.

(* A Functional relation is known as a 'simple arrow' in the book AOP           *)

Definition Functional (a b:Type) (r:R a b) : Prop := r ; conv r <= id.

Arguments Functional {a} {b}.

Lemma Functional_charac : forall (a b:Type) (r:R a b),
    Functional r <-> forall (x:a) (y y':b), r x y -> r x y' -> y = y'.
Proof.
    intros a b r. unfold Functional. split; intros H1.
    - intros x y y' H2 H3. assert ((r ; conv r) y y') as H4.
        { exists x. split; assumption. }
      apply (incl_charac_to _ _ (r ; conv r) _ y y') in H1; try assumption.
      destruct H1 as [y]. reflexivity.
    - apply incl_charac. intros y y'. intros [x [H2 H3]].
      rewrite (H1 x y y'); try assumption. constructor.
Qed.

Lemma comp_distrib_inter_r : forall (a b c:Type) (t:R a b) (r s:R b c),
    Functional t -> (r /\ s) ; t = ((r ; t) /\ (s ; t)).
Proof.
    intros a b c t r s H1. apply incl_anti.
    - apply comp_semi_distrib_inter_r.
    - apply incl_charac. intros x y [[z' [H2 H3]] [z [H4 H5]]].
      assert (z' = z) as H6.
        { destruct (Functional_charac a b t) as [H6 H7].
          apply (H6 H1) with x; assumption. }
      subst. exists z. split; try assumption. split; assumption.
Qed.

Lemma Functional_conv : forall (a b:Type) (r:R a b),
    Functional r -> r = r ; conv r ; r.
Proof.
    intros a b r H1. apply Ext. intros x y. split; intros H2.
    - exists x. split; try assumption. exists y. split; assumption.
    - destruct H2 as [z [[u [H2 H3]] H4]]. assert (y = u) as H5.
        { destruct (Functional_charac a b r) as [H6 H7].
          apply H6 with z; assumption. }
      subst. assumption.
Qed.

Lemma dom_ex4_17 : forall (a b c:Type) (r:R a b) (s:R b c),
    Functional r -> dom s ; r = r ; dom (s ; r).
Proof.
    intros a b c r s H0. apply Ext. intros x y. split; intros H1.
    - destruct H1 as [z [H1 H2]]. destruct H2 as [y [z H2]].
      exists x. split; try assumption. constructor. exists z. exists y.
      split; assumption.
    - destruct H1 as [z [H1 H2]]. destruct H1 as [x [z [y' [H1 H3]]]].
      assert (y' = y) as H4.
        { destruct (Functional_charac a b r) as [H5 H6].
          apply H5 with x; assumption. }
      subst. exists y. split; try assumption. constructor. exists z. assumption.
Qed.


Set Implicit Arguments.

Require Coq.Arith.Compare_dec.
Require Coq.FSets.FMapFacts.

Require Tid.
Require Bijection.

Require Import Coq.Structures.OrderedType.
Require Import Coq.Structures.OrderedTypeEx.
Require Import Coq.FSets.FMapAVL.
Require Import Coq.FSets.FSetAVL.
Require Import Coq.Arith.Peano_dec.
Require Import Omega.

Require Import Aniceto.Map.

Inductive node := make : nat -> node.

Definition node_id r := match r with | make n => n end.

Definition node_first := make 0.

Definition node_next m := make (S (node_id m)).

Module NODE <: UsualOrderedType.
  Definition t := node.
  Definition eq := @eq node.
  Definition lt x y := lt (node_id x) (node_id y).
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.
  Lemma lt_trans: forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    intros.
    unfold lt in *.
    destruct x, y, z.
    simpl in *.
    omega.
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
    unfold lt in *.
    intros.
    destruct x, y.
    simpl in *.
    unfold not; intros.
    inversion H0.
    subst.
    apply Lt.lt_irrefl in H.
    inversion H.
  Qed.

  Import Coq.Arith.Compare_dec.
  Lemma compare:
    forall x y, Compare lt eq x y.
  Proof.
    intros.
    destruct x, y.
    destruct (Nat_as_OT.compare n n0);
    eauto using LT, GT.
    apply EQ.
    unfold Nat_as_OT.eq in *.
    subst.
    intuition.
  Qed.

  Lemma eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
  Proof.
    intros.
    unfold eq.
    destruct x, y.
    destruct (eq_nat_dec n n0).
    - subst; eauto.
    - right.
      unfold not.
      intros.
      contradiction n1.
      inversion H; auto.
  Qed.
End NODE.

Module MN := FMapAVL.Make NODE.
Module MN_Facts := FMapFacts.Facts MN.
Module MN_Props := FMapFacts.Properties MN.
Module MN_Extra := MapUtil MN.
Module SN := FSetAVL.Make NODE.
Definition set_node := SN.t.

Lemma node_eq_rw:
  forall (k k':node), NODE.eq k k' <-> k = k'.
Proof.
  intros.
  auto with *.
Qed.

Lemma node_eq_dec:
  forall x y : node, {x = y} + {x <> y}.
Proof.
  auto using node_eq_rw, NODE.eq_dec.
Qed.

Section NotIn.
  Variable elt:Type.

  Lemma node_lt_irrefl:
    forall x : node, ~ NODE.lt x x.
  Proof.
    unfold not; intros.
    apply NODE.lt_not_eq in H.
    contradiction H.
    apply NODE.eq_refl.
  Qed.

  Let lt_next:
    forall x, NODE.lt x (node_next x).
  Proof.
    intros.
    destruct x.
    unfold node_next, node_id, NODE.lt.
    simpl.
    auto.
  Qed.

  Let node_impl_eq:
    forall k k' : node, k = k' -> k = k'.
  Proof.
    auto.
  Qed.

  Definition supremum {elt:Type} := @MN_Extra.supremum elt node_first node_next NODE.lt NODE.compare.

  Theorem find_not_in:
    forall (m: MN.t elt),
    ~ MN.In (supremum m) m.
  Proof.
    intros.
    eauto using MN_Extra.find_not_in, NODE.lt_trans, node_lt_irrefl.
  Qed.

End NotIn.

Section Props.
  Import Tid.

  Variable A:Type.

  Definition MapsTo (x:A) (n:node) (vs:list A) := Bijection.MapsTo x (node_id n) vs.

  Definition fresh (vs:list A) := make (length vs).

  Definition Node x (vs:list A) := Bijection.Index (node_id x) vs.

  Definition TaskOf (n:node) (x:A) (vs:list A) := Bijection.IndexOf x (node_id n) vs.

  Definition First (x:A) (n:node) (vs:list A) := Bijection.First x (node_id n) vs.

  Lemma maps_to_fun_1:
    forall x y n (vs:list A),
    MapsTo x n vs ->
    MapsTo y n vs ->
    y = x.
  Proof.
    unfold MapsTo; eauto using Bijection.maps_to_fun_1.
  Qed.

  Lemma maps_to_fun_2:
    forall vs (x:A) n n',
    MapsTo x n vs ->
    MapsTo x n' vs ->
    n' = n.
  Proof.
    intros.
    unfold MapsTo in *.
    destruct n as (n), n' as (n').
    simpl in *.
    eauto using Bijection.maps_to_fun_2.
  Qed.

  Lemma maps_to_inv_eq:
    forall (x:A) n vs,
    MapsTo x n (x :: vs) ->
    n = fresh vs.
  Proof.
    intros.
    unfold MapsTo, fresh in *.
    destruct n as (n).
    simpl in *.
    eauto using Bijection.maps_to_inv_eq.
  Qed.

  Lemma task_of_inv_key:
    forall (x:A) y vs,
    TaskOf (fresh vs) x (y :: vs) ->
    x = y.
  Proof.
    intros.
    unfold TaskOf, fresh in *; simpl in *.
    eauto using Bijection.index_of_inv_key.
  Qed.

  Lemma maps_to_neq:
    forall (x:A) y vs n,
    x <> y ->
    MapsTo y n (x :: vs) ->
    MapsTo y n vs.
  Proof.
    intros.
    destruct n as (n).
    unfold MapsTo in *; simpl in *.
    eauto using Bijection.maps_to_neq.
  Qed.

  Lemma node_eq:
    forall x vs,
    Node (fresh vs) (x::vs).
  Proof.
    intros.
    unfold Node, fresh in *.
    eauto using Bijection.index_eq.
  Qed.

  Lemma maps_to_eq:
    forall x vs,
    MapsTo x (fresh vs) (x::vs).
  Proof.
    intros.
    unfold MapsTo, fresh.
    simpl.
    auto using Bijection.maps_to_eq.
  Qed.

  Lemma maps_to_cons:
    forall x vs y n,
    x <> y ->
    MapsTo x n vs ->
    MapsTo x n (y :: vs).
  Proof.
    unfold MapsTo, fresh.
    auto using Bijection.maps_to_cons.
  Qed.

  Lemma maps_to_lt:
    forall (x:A) n vs,
    MapsTo x n vs ->
    NODE.lt n (fresh vs).
  Proof.
    intros.
    unfold NODE.lt, fresh, MapsTo in *.
    destruct n; simpl in *.
    eauto using Bijection.maps_to_lt.
  Qed.

  Lemma node_lt:
    forall n vs,
    Node n vs ->
    NODE.lt n (fresh vs).
  Proof.
    intros.
    destruct n.
    unfold Node, fresh, NODE.lt in *.
    eauto using Bijection.index_lt.
  Qed.

  Lemma lt_to_node:
    forall n vs,
    NODE.lt n (fresh vs) ->
    Node n vs.
  Proof.
    unfold NODE.lt, Node, fresh.
    auto using Bijection.lt_to_index.
  Qed.

  Lemma node_cons:
    forall n vs x,
    Node n vs ->
    Node n (x::vs).
  Proof.
    unfold NODE.lt, Node, fresh.
    auto using Bijection.index_cons.
  Qed.

  Lemma maps_to_absurd_fresh:
    forall (x:A) vs,
    ~ MapsTo x (fresh vs) vs.
  Proof.
    unfold fresh, MapsTo.
    eauto using Bijection.maps_to_absurd_length.
  Qed.

  Lemma task_of_absurd_fresh:
    forall (x:A) vs,
    ~ TaskOf (fresh vs) x vs.
  Proof.
    unfold fresh, TaskOf.
    eauto using Bijection.index_of_absurd_length.
  Qed.

  Lemma node_absurd_fresh:
    forall vs,
    ~ Node (fresh vs) vs.
  Proof.
    intros.
    unfold Node.
    simpl.
    apply Bijection.index_absurd_length.
  Qed.

  Lemma node_next_node:
    forall vs n,
    Node (node_next n) vs ->
    Node n vs.
  Proof.
    unfold Node; intros.
    destruct n.
    simpl in *.
    auto using Bijection.index_succ.
  Qed.

  Lemma node_absurd_next_fresh:
    forall vs,
    ~ Node (node_next (fresh vs)) vs.
  Proof.
    intros.
    unfold not; intros N.
    apply node_next_node in N.
    apply node_absurd_fresh in N.
    assumption.
  Qed.

  Lemma node_absurd_cons_fresh:
    forall vs x,
    ~ Node (fresh (x::vs)) vs.
  Proof.
    intros.
    assert (Hx := node_absurd_next_fresh).
    unfold node_next, fresh in *; simpl in *.
    auto.
  Qed.

  Lemma maps_to_to_node:
    forall (x:A) n vs,
    MapsTo x n vs ->
    Node n vs.
  Proof.
    unfold MapsTo, Node.
    intros.
    eauto using Bijection.maps_to_to_index.
  Qed.

  Lemma maps_to_absurd_next_fresh:
    forall (x:A) vs,
    ~ MapsTo x (node_next (fresh vs)) vs.
  Proof.
    intros.
    unfold not; intros N.
    apply maps_to_to_node in N.
    apply node_absurd_next_fresh in N.
    assumption.
  Qed.

  Lemma maps_to_to_task_of:
    forall (x:A) n vs,
    MapsTo x n vs ->
    TaskOf n x vs.
  Proof.
    unfold MapsTo, TaskOf.
    eauto using Bijection.maps_to_to_index_of.
  Qed.

End Props.

Section MoreProps.

  Lemma maps_to_length_rw:
    forall {A:Type} {B:Type} (vs:list A) (vs':list B),
    length vs = length vs' ->
    fresh vs = fresh vs'.
  Proof.
    intros.
    unfold fresh.
    auto.
  Qed.

  Let length_node_id_rw:
    forall {A} (vs:list A) n,
    length vs = node_id n ->
    fresh vs = n.
  Proof.
    unfold fresh.
    intros.
    destruct n; auto.
  Qed.

  Lemma maps_to_to_in:
    forall {A} x n (vs:list A),
    MapsTo x n vs ->
    List.In x vs.
  Proof.
    unfold MapsTo; eauto using Bijection.maps_to_to_in.
  Qed.

  Lemma maps_to_inv:
    forall {A} x (y:A) n vs,
    MapsTo x n (y :: vs) ->
    (x = y /\ n = fresh vs) \/ (x <> y /\ MapsTo x n vs).
  Proof.
    intros.
    inversion H; subst.
    - apply length_node_id_rw in H1.
      subst.
      intuition.
    - intuition.
  Qed.

  Lemma maps_to_inv_key:
    forall {A} (x:A) y vs,
    MapsTo y (fresh vs) (x :: vs) ->
    y = x.
  Proof.
    unfold MapsTo; intros.
    apply Bijection.maps_to_inv_key in H.
    trivial.
  Qed.

  Lemma task_of_inv:
    forall {A} x (y:A) n vs,
    TaskOf n x (y :: vs) ->
    (x = y /\ n = fresh vs) \/ TaskOf n x vs.
  Proof.
    intros.
    inversion H; subst.
    - apply length_node_id_rw in H1.
      subst.
      intuition.
    - intuition.
  Qed.

  Lemma node_to_task_of:
    forall {A} n (vs:list A),
    Node n vs ->
    exists x, TaskOf n x vs.
  Proof.
    intros.
    destruct H as (x, H).
    eauto.
  Qed.

  Lemma task_of_to_node:
    forall {A} x n (vs:list A),
    TaskOf n x vs ->
    Node n vs.
  Proof.
    intros.
    unfold Node, TaskOf in *.
    eauto using Bijection.index_def.
  Qed.

  Lemma task_of_to_in:
    forall {A} x n (vs:list A),
    TaskOf n x vs ->
    List.In x vs.
  Proof.
    unfold TaskOf; eauto using Bijection.index_of_to_in.
  Qed.

  Lemma task_of_cons:
    forall {A} x y n (vs:list A),
    TaskOf n x vs ->
    TaskOf n x (y::vs).
  Proof.
    unfold TaskOf; eauto using Bijection.index_of_cons.
  Qed.

  Lemma node_inv:
    forall {A} (x:A) n vs,
    Node n (x :: vs) ->
    n = fresh vs \/ Node n vs.
  Proof.
    intros.
    apply node_to_task_of in H.
    destruct H as (y, H).
    apply task_of_inv in H.
    destruct H as [(?,?)|?].
    - subst.
      intuition.
    - eauto using task_of_to_node.
  Qed.

  Lemma task_of_inv_eq:
    forall {A} x (y:A) vs,
    TaskOf (fresh vs) x (y :: vs) ->
    x = y.
  Proof.
    unfold TaskOf, fresh; eauto using Bijection.index_of_inv_key.
  Qed.

  Lemma task_of_eq:
    forall {A} (x:A) vs,
    TaskOf (fresh vs) x (x :: vs).
  Proof.
    unfold TaskOf, fresh; eauto using Bijection.index_of_eq.
  Qed.

  Lemma first_fun:
    forall {A} (x:A) vs (n n':node),
    First x n vs ->
    First x n' vs ->
    n' = n.
  Proof.
    intros.
    destruct n, n'.
    eauto using Bijection.first_fun.
  Qed.

  Lemma in_to_node:
    forall {A} vs (x:A),
    List.In x vs ->
    exists n, TaskOf n x vs.
  Proof.
    intros.
    apply Bijection.in_to_index_of in H.
    destruct H as (n, (Hx, Hy)).
    unfold TaskOf.
    exists (make n).
    auto.
  Qed.

  Lemma node_tr:
    forall {A B} (a:list A) (b:list B) n,
    length a = length b ->
    Node n a -> Node n b.
  Proof.
    intros.
    unfold Node in *.
    eauto using Bijection.index_tr.
  Qed.

  Lemma first_cons:
    forall {A} (x y:A) n vs,
    First x n vs ->
    First x n (y::vs).
  Proof.
    unfold First; intros.
    auto using Bijection.first_cons.
  Qed.

  Lemma first_eq:
    forall {A} (x:A) vs,
    ~ List.In x vs ->
    First x (fresh vs) (x::vs).
  Proof.
    unfold First, fresh; intros.
    simpl.
    auto using Bijection.first_eq.
  Qed.

  Variable A:Type.
  Variable eq_dec: forall (x y:A), {x = y} + {x <> y}.

  Lemma in_to_first:
    forall vs (x:A),
    List.In x vs ->
    exists n, First x n vs.
  Proof.
    unfold First; intros.
    apply Bijection.in_to_first in H; auto.
    destruct H as (n, Hf).
    exists (make n).
    simpl.
    trivial.
  Qed.

  Lemma first_simpl_1:
    forall {A} (x:A) y vs n,
    First x n (y :: vs) ->
    x <> y ->
    First x n vs.
  Proof.
    intros.
    inversion H; subst; clear H; auto.
    contradiction H0; auto.
  Qed.

  Lemma maps_to_to_first:
    forall (x:A) n vs,
    MapsTo x n vs ->
    exists n', First x n' vs.
  Proof.
    intros.
    apply maps_to_to_in in H.
    auto using in_to_first.
  Qed.

  Lemma first_cons_fun:
    forall n n' (x:A) y vs,
    First x n vs ->
    First x n' (y :: vs) ->
    n' = n.
  Proof.
    unfold First; intros.
    eapply Bijection.first_cons_fun in H0; eauto.
    destruct n, n'.
    simpl in *.
    subst.
    trivial.
  Qed.

  Lemma fresh_cons_rw_next:
    forall (x:A) l,
    fresh (x :: l) = node_next (fresh l).
  Proof.
    intros.
    unfold fresh, node_next; auto.
  Qed.

End MoreProps.

  Ltac simpl_node :=
  repeat match goal with
  | [ H1: MapsTo ?x ?n ?v, H2: MapsTo ?y ?n ?v |- _ ] =>
      let H' := fresh "H" in
      assert (H': y = x) by eauto using maps_to_fun_1;
      rewrite H' in *;
      clear H' H2
  | [ H1: First ?x ?nx ?v, H2: First ?x ?ny (_::?v) |- _ ] =>
      let H' := fresh "H" in
      assert (H': ny = nx) by eauto using first_cons_fun;
      rewrite H' in *;
      clear H' H2
  | [ H1: First ?x ?nx ?v, H2: First ?x ?ny ?v |- _ ] =>
      let H' := fresh "H" in
      assert (H': ny = nx) by eauto using first_fun;
      rewrite H' in *;
      clear H' H2
  | [ H1: MapsTo ?x ?n1 ?v, H2: MapsTo ?x ?n2 ?v |- _ ] =>
      let H' := fresh "H" in
      assert (H': n1 = n2) by eauto using maps_to_fun_2;
      rewrite H' in *;
      clear H' H2
  | [ H: MapsTo _ (fresh ?vs) ?vs |- _ ] =>
      apply maps_to_absurd_fresh in H;
      contradiction
  | [ H: MapsTo _ (node_next (fresh ?vs)) ?vs |- _ ] =>
      apply maps_to_absurd_next_fresh in H;
      contradiction
  | [ H: TaskOf (fresh ?vs) _ ?vs |- _ ] =>
      apply task_of_absurd_fresh in H;
      contradiction
  | [ H: Node (fresh ?vs) ?vs |- _ ] =>
      apply node_absurd_fresh in H;
      contradiction
  | [ H: Node (node_next (fresh ?vs)) ?vs |- _ ] =>
      apply node_absurd_next_fresh in H;
      contradiction
  | [ H: Node (fresh (_::?vs)) ?vs |- _ ] =>
      apply node_absurd_cons_fresh in H;
      contradiction
  | [ H: TaskOf (fresh ?vs) ?x (?y :: ?vs) |- _ ] => apply task_of_inv_eq in H; subst
  | [ H: MapsTo ?x (fresh ?vs) (?x :: ?vs) |- _ ] => clear H
  | [ H1: MapsTo ?x _ (?y :: _), H2: ?x <> ?y |- _ ] => apply maps_to_neq in H1; auto
  | [ H1: MapsTo ?x _ (?y :: _), H2: ?y <> ?x |- _ ] => apply maps_to_neq in H1; auto
  | [ H1: First ?x _ (?y :: _), H2: ?x <> ?y |- _ ] => apply first_simpl_1 in H1; auto
  | [ H1: First ?x _ (?y :: _), H2: ?y <> ?x |- _ ] => apply first_simpl_1 in H1; auto
  | [ H: MapsTo ?x _ (?x :: _) |- _ ] => apply maps_to_inv_eq in H; rewrite H in *; clear H
  | [ H: MapsTo ?y (fresh ?vs) (?x :: ?vs) |- _ ] => apply maps_to_inv_key in H; rewrite H in *; clear H
  | [ H: ?x = ?x |- _] => clear H
  end.


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

(* ** Exponentiation is Diophantine *)

Require Import Arith ZArith Lia.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac gcd sums.

From Undecidability.H10.ArithLibs
  Require Import Zp.

From Undecidability.H10.Matija
  Require Import alpha.

Set Implicit Arguments.

Set Default Proof Using "Type".

Local Notation expo := (mscal mult 1).

Section expo_diophantine.

  Variables (p q r : nat).

  Definition expo_conditions :=
      r = 0 /\ p = 1
   \/ q = 0 /\ 0 < r /\ p = 0
   \/ (0 < r /\ q <> 0) /\ exists b m a1 a2 a3,
             (3 < q+4 /\ a1 = alpha_nat (q+4) (1+r))
          /\ (3 < b   /\ a2 = alpha_nat b r)
          /\ (3 < b   /\ a3 = alpha_nat b (1+r))
          /\ b = a1+q*q+2
          /\ m + q*q + 1 = b*q
          /\ p < m
          /\ rem (p+b*a2) m = rem (q*a2+a3) m.

  Let H_q3_q : 0 < q -> q*q+2 <= q*q*q+2*q.
  Proof.
    intros H.
    apply plus_le_compat; try lia.
    replace q with (1+(q-1)) at 3 by lia.
    rewrite <- mult_assoc, Nat.mul_add_distr_r, Nat.mul_1_l.
    apply le_plus_l.
  Qed.

  Lemma expo_sufficiency : p = expo r q -> expo_conditions.
  Proof.
    intros H.
    destruct (le_lt_dec r 0) as [ Hr | Hr ]; red.
    1: { left; revert H; replace r with 0 by lia; rewrite mscal_0; tauto. }
    destruct (eq_nat_dec q 0) as [ Hq | Hq ].
    1: { right; left; subst; rewrite power_of_0; auto. }
    remember (alpha_nat (q+4) (S r)) as a1.
    remember (a1+q*q+2) as b.
    remember (alpha_nat b r) as a2.
    remember (alpha_nat b (1+r)) as a3.
    remember (b*q-q*q-1) as m.
    right; right; split; auto; exists b, m, a1, a2, a3.
    assert (3 < b) as Hb.
    { rewrite Heqb.
      apply lt_le_trans with (1+(1*1)+2); try lia.
      repeat apply plus_le_compat; auto.
      + rewrite Heqa1.
        apply alpha_nat_mono with (i := 1); lia.
      + apply mult_le_compat; lia. }
    assert (2 <= b) as Hb' by lia.
    destruct (@alpha_nat_power (q+4)) with (n := r)
        as (H1 & H2); try lia.
    assert (q*q+2 <= q*q*q+2*q) as Hq'.
    { apply H_q3_q; lia. }
    assert (m <> 0) as Hm.
    { rewrite Heqm, Heqb.
      do 2 rewrite  Nat.mul_add_distr_r.
      assert (a1*q <> 0) as Ha1.
      { intros E; apply mult_is_O in E.
        destruct E as [ E | ]; try lia.
        revert E; rewrite Heqa1.
        apply alpha_nat_gt_0; lia. }
      revert Ha1; generalize (a1*q); intros x Hx.
      lia. }
    assert (expo r q < m) as Hexpo.
    { rewrite Heqm, Heqb.
      do 2 rewrite Nat.mul_add_distr_r.
      rewrite <- Heqa1 in H1.
      apply lt_le_trans with (a1*1+1).
      + rewrite plus_comm, Nat.mul_1_r; apply le_n_S.
        apply le_trans with (2 := H1).
        apply power_mono_r; lia.
      + rewrite <- Nat.sub_add_distr, <- plus_assoc, <- Nat.add_sub_assoc; try lia.
        apply plus_le_compat; try lia.
        apply mult_le_compat; lia. }
    repeat (split; auto); try lia.
    rewrite <- nat2Zp_inj with (Hp := Hm).
    do 2 rewrite nat2Zp_plus.
    rewrite Heqa2.
    revert Hm; rewrite Heqm; intros Hm.
    rewrite expo_congruence; auto.
    rewrite <- H, plus_comm, nat2Zp_plus, <- Zp_plus_assoc; f_equal.
    rewrite <- nat2Zp_plus; f_equal.
    rewrite Heqa3.
    destruct r as [ | r' ]; try lia.
    replace (S r' -1) with r' by lia.
    simpl plus at 2.
    rewrite alpha_nat_fix_2.
    generalize (alpha_nat_le Hb' r'); lia.
  Qed.

  Infix "⊕" := (Zp_plus _) (at level 50, left associativity).
  Infix "⊗" := (Zp_mult _) (at level 40, left associativity).
  Notation "∸" := (Zp_opp _).
  Notation f := (nat2Zp _).
  Notation "〚 x 〛" :=  (f x).

  Ltac fold_nat2Zp :=
    repeat match goal with
      | |- context[nat2Zp _ ?x ⊕ nat2Zp _ ?y] => rewrite <- nat2Zp_plus
      | |- context[nat2Zp _ ?x ⊗ nat2Zp _ ?y] => rewrite <- nat2Zp_mult
      | |- context[∸ nat2Zp _ ?x] => fail
    end.

  Lemma expo_necessity : expo_conditions -> p = expo r q.
  Proof.
    unfold expo_conditions.
    intros [ (H1 & H2) | [ (H1 & H2 & H3) | ((H0 & H1) & b & m & a1 & a2 & a3 & (_ & H2) &
                                            (H3 & H4) & (H5 & H6) & H7 & H8 & H9 & H10) ] ].
    + subst; auto.
    + subst; rewrite power_of_0; auto.
    + assert (m = b*q - q*q -1) as Hm1 by lia.
      assert (m <> 0) as Hm by lia.
      assert (q*q+2 <= q*q*q+2*q) as Hq'.
      { apply H_q3_q; lia. }
      assert (expo r q < m) as Hq.
      { rewrite Hm1, H7.
        do 2 rewrite Nat.mul_add_distr_r.
        apply lt_le_trans with (a1*1+1).
        + rewrite plus_comm, Nat.mul_1_r; apply le_n_S.
          destruct alpha_nat_power with (b_nat := q+4) (n := r)
            as (G1 & _); try lia.
          rewrite H2.
          apply le_trans with (2 := G1), power_mono_r; lia.
        + rewrite <- Nat.sub_add_distr, <- plus_assoc, <- Nat.add_sub_assoc; try lia.
          apply plus_le_compat; try lia.
          apply mult_le_compat; lia. }
      rewrite <- (rem_lt Hm H9), <- (rem_lt Hm Hq).
      revert H10.
      rewrite Hm1 in Hm |- *.
      do 2 rewrite <- nat2Zp_inj with (Hp := Hm).
      do 2 rewrite nat2Zp_plus.
      rewrite H4, expo_congruence; auto; [ | lia ].
      rewrite H6, nat2Zp_plus.
      destruct r as [ | r' ]; [ lia | ].
      replace (S r' -1) with r' by lia.
      simpl plus.
      rewrite alpha_nat_fix_2, nat2Zp_minus.
      2: apply alpha_nat_le; lia.
      intros H; rewrite Zp_opp_plus_eq in H.
      rewrite H.
      rewrite (Zp_plus_comm _ 〚b * _〛 (∸ _)).
      repeat rewrite <- Zp_plus_assoc.
      rewrite Zp_minus, Zp_plus_zero_r.
      rewrite Zp_plus_comm, <- Zp_plus_assoc.
      rewrite (Zp_plus_comm _ (∸ _)), Zp_minus, Zp_plus_zero_r.
      trivial.
  Qed.

End expo_diophantine.

Local Hint Resolve expo_sufficiency expo_necessity : core.

Theorem expo_diophantine p q r : p = expo r q <-> expo_conditions p q r.
Proof. split; auto. Qed.


Require Coq.extraction.Extraction.
Extraction Language Haskell.
Require Import ExtrHaskellZNum.
Require Import ZArith.

From F4 Require Export clipping.

Open Scope Z_scope.

Extract Inductive list => "[]" [ "[]" "(:)" ].
Extract Inductive bool => "Prelude.Bool" [ "Prelude.True" "Prelude.False" ].

Extract Inductive Z => "Prelude.Integer" [ "0" "(\x -> x)" "Prelude.negate" ]
  "(\fO fP fN n -> if n Prelude.== 0 then fO () else if n Prelude.> 0 then fP n else fN (Prelude.negate n))".

Extract Inductive positive => "Prelude.Integer" [
  "(\x -> 2 Prelude.* x Prelude.+ 1)"
  "(\x -> 2 Prelude.* x)"
  "1" ]
  "(\fI fO fH n -> if n Prelude.== 1 then fH () else if Prelude.odd n then fI (n `Prelude.div` 2) else fO (n `Prelude.div` 2))".

(* Annoyingly, when run inside CoqIde the below will try to write to the directory from which CoqIde
   is run, and I cannot find a way to alter this behaviour. Fortunately, this does not arise when
   compiling from the command line with coqc which is the typical flow so we can live with this.
   The alternative would be to use an absolute path below which I refuse to do. *)
Extraction "./clipPolygon.hs" clipPolygon.


From Coq Require Import Arith.
From Coq Require Import EqNat.
From VT Require Export Map.
From VT Require Export Machine.
From VT Require Export xcapi.
From VT Require Export tylist.

Lemma shift_subst_eq : forall L (p:PropX L) B (A:B->PropX L),
                         p = Subst _ B (Shift tO _ p B) A.
induction p.
intros. simpl. auto.
intros. simpl. auto.
intros. simpl. rewrite <- (ext_eq _ _ p (fun x => Subst L B (Shift tO L (p x) B) A) (fun s => H s B A)). auto.
intros. simpl. auto.
intros. simpl. rewrite <- IHp1. rewrite <- IHp2. auto.
intros. simpl. rewrite <- IHp1. rewrite <- IHp2. auto.
intros. simpl. rewrite <- IHp1. rewrite <- IHp2. auto.
intros. simpl. rewrite <- (ext_eq _ _ p (fun x => Subst L B (Shift tO L (p x) B) A0) (fun s => H s B A0)). auto.
intros. simpl. rewrite <- (ext_eq _ _ p (fun x => Subst L B (Shift tO L (p x) B) A0) (fun s => H s B A0)). auto.
intros. simpl. rewrite <- IHp. auto.
intros. simpl. rewrite <- IHp. auto.
Qed.

Lemma ok_eq_ok : forall E Si p q, OK E Si p -> p = q -> OK E Si q.
intros. rewrite <- H0. auto.
Qed.