From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import
     Functor.Functor Functor.Functor_Ops Functor.Functor_Properties.
From Categories Require Import Cat.Cat.
From Categories Require Import
     NatTrans.NatTrans NatTrans.Func_Cat NatTrans.Operations.

Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn : core.

Local Open Scope nattrans_scope.

Notation "a ≃ b" := (a ≃≃ b ::> Func_Cat _ _)%isomorphism : natiso_scope.

Section NatIso.
  Context {C C' : Category} (F G : (C --> C')%functor)
          (n : F --> G) (n' : G --> F).

  (** Two natural transformation for which individual arrows of arrow
      families form isomorphism form natural isomorphisms. *)
  Program Definition NatIso
          (H : (∀ (c : Obj), (Trans n c) ∘ (Trans n' c)
                             = (id (G _o c)))%morphism)
          (H' : (∀ (c : Obj), (Trans n' c) ∘ (Trans n c)
                              = (id (F _o c)))%morphism)
    : (F ≃ G)%natiso
    := (Build_Isomorphism (Func_Cat _ _) _ _ n n' _ _).

End NatIso.

Section NatTrans_id_Iso.
  Context {C D : Category} (F : (C --> D)%functor).

  (** The identity natural transformation is a natural isomorphism. *)
  Definition NatTrans_id_Iso :
    (F ≃ F)%natiso := @Isomorphism_id (Func_Cat _ _) F.

End NatTrans_id_Iso.

(** Horizontal composition of natural isomorphisms is a natural isomorphism. *)
Section NatIso_hor_comp.
  Context {C D E : Category} {F F' : (C --> D)%functor}
          {G G' : (D --> E)%functor} (N : (F ≃ F')%natiso)
          (N' : (G ≃ G')%natiso).

  Local Obligation Tactic := idtac.

  Program Definition NatIso_hor_comp
    : ((G ∘ F)%functor ≃ (G' ∘ F')%functor)%natiso :=
    {|
      iso_morphism := ((iso_morphism N') ∘_h (iso_morphism N))%nattrans;
      inverse_morphism :=
        ((inverse_morphism N') ∘_h (inverse_morphism N))%nattrans
    |}.

  Next Obligation.
  Proof.
    cbn.
    rewrite NatTrans_comp_hor_comp.
    cbn_rewrite (left_inverse N).
    cbn_rewrite (left_inverse N').
    auto.
  Qed.

  Next Obligation.
  Proof.
    cbn.
    rewrite NatTrans_comp_hor_comp.
    cbn_rewrite (right_inverse N).
    cbn_rewrite (right_inverse N').
    auto.
  Qed.

End NatIso_hor_comp.

Notation "f ∘_h g" := (NatIso_hor_comp g f) : natiso_scope.

(** If two functors are naturally isomorphic then their opposites are too. *)
Section Opposite_NatIso.
  Context {C D : Category} {F G : (C --> D)%functor} (N : (F ≃ G)%natiso).

  Program Definition Opposite_NatIso : (F^op%functor ≃ G^op%functor)%natiso :=
    {|
      iso_morphism := (inverse_morphism N)^op%nattrans;
      inverse_morphism := (iso_morphism N)^op%nattrans
    |}.

  Next Obligation.
  Proof.
    rewrite <- NatTrans_compose_Op.
    change ((N⁻¹)%morphism ∘ (iso_morphism N))%nattrans with (N⁻¹ ∘ N)%morphism.
    rewrite left_inverse.
    apply NatTrans_id_Op.
  Qed.

  Next Obligation.
  Proof.
    rewrite <- NatTrans_compose_Op.
    change ((iso_morphism N) ∘ (N⁻¹)%morphism)%nattrans with (N ∘ N⁻¹)%morphism.
    rewrite right_inverse.
    apply NatTrans_id_Op.
  Qed.

End Opposite_NatIso.

Notation "f ^op" := (Opposite_NatIso f) : natiso_scope.

Section Embedding_mono.
  Context {C C' : Category} (F : Embedding C C') {B : Category}.

  Local Obligation Tactic := idtac.

  (** For an embeding F and functors G and G', F ∘ G ≃ F ∘ G' implies
      there is a natural transformation from G to G'. We will use
      this to show that G and G' are naturally isomorphic below. *)
  Section Embedding_mono_NT.
    Context {G G' : (B --> C)%functor}
            (H : ((F ∘ G)%functor ≃ (F ∘ G')%functor)%natiso).

    Program Definition Embedding_mono_NT :  G --> G' :=
      {|
        Trans := fun c => proj1_sig (Emb_Full _ (Trans (iso_morphism H) c))
      |}.

    Next Obligation.
      intros c c' h.
      apply (Emb_Faithful F).
      repeat rewrite F_compose.
      cbn_rewrite (proj2_sig (Emb_Full _ (Trans (iso_morphism H) c))).
      cbn_rewrite (proj2_sig (Emb_Full _ (Trans (iso_morphism H) c'))).
      apply (@Trans_com _ _ _ _ (iso_morphism H) _ _ h).
    Qed.

    Next Obligation.
    Proof.
      symmetry.
      apply Embedding_mono_NT_obligation_1.
    Qed.

  End Embedding_mono_NT.

  Context {G G' : (B --> C)%functor}
          (H : ((F ∘ G)%functor ≃ (F ∘ G')%functor)%natiso).

  (** For an embeding F and functors G and G', F ∘ G ≃ F ∘ G' implies G ≃ G'. *)
  Program Definition Embedding_mono : (G ≃ G')%natiso  :=
    {|
      iso_morphism := Embedding_mono_NT H;
      inverse_morphism := Embedding_mono_NT (H⁻¹)
    |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c; cbn.
    apply (Emb_Faithful F).
    repeat rewrite F_compose.
    cbn_rewrite (proj2_sig (Emb_Full _ (Trans (iso_morphism H) c))).
    cbn_rewrite (proj2_sig (Emb_Full _ (Trans (inverse_morphism H) c))).
    rewrite F_id.
    change (Trans (inverse_morphism H) c ∘ Trans (iso_morphism H) c)%morphism
    with (Trans ((inverse_morphism H) ∘ (iso_morphism H))%nattrans c).
    cbn_rewrite (left_inverse H).
    trivial.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c; cbn.
    apply (Emb_Faithful F).
    repeat rewrite F_compose.
    cbn_rewrite (proj2_sig (Emb_Full _ (Trans (iso_morphism H) c))).
    cbn_rewrite (proj2_sig (Emb_Full _ (Trans (inverse_morphism H) c))).
    rewrite F_id.
    change (Trans (iso_morphism H) c ∘ Trans (inverse_morphism H) c)%morphism
    with (Trans ((iso_morphism H) ∘ (inverse_morphism H))%nattrans c).
    cbn_rewrite (right_inverse H).
    trivial.
  Qed.

End Embedding_mono.

Section NatIso_Functor_assoc.
  Context {C1 C2 C3 C4 : Category}
          (F : (C1 --> C2)%functor)
          (G : (C2 --> C3)%functor)
          (H : (C3 --> C4)%functor).

  (** Natrual isomorphism form of functor composition associativity. *)
  Program Definition NatIso_Functor_assoc
    : (((H ∘ G) ∘ F)%functor ≃ (H ∘ (G ∘ F))%functor)%natiso :=
    {|
      iso_morphism := NatTrans_Functor_assoc F G H;
      inverse_morphism := NatTrans_Functor_assoc_sym F G H
    |}.

End NatIso_Functor_assoc.

Section NatIso_Image.
  Context {C C' : Category} {F G : (C --> C')%functor} (N : (F ≃ G)%natiso).

  (** Natrual isomorphism form of functor composition associativity. *)
  Program Definition NatIso_Image (c : C) : ((F _o c) ≃ (G _o c))%isomorphism :=
    {|
      iso_morphism := Trans (iso_morphism N) c;
      inverse_morphism := Trans (inverse_morphism N) c
    |}.

  Next Obligation.
    change (Trans (inverse_morphism N) c ∘ Trans (iso_morphism N) c)%morphism
    with (Trans ((inverse_morphism N) ∘ (iso_morphism N)) c)%morphism.
    cbn_rewrite (left_inverse N).
    trivial.
  Qed.

  Next Obligation.
    change (Trans (iso_morphism N) c ∘ Trans (inverse_morphism N) c)%morphism
    with (Trans ((iso_morphism N) ∘ (inverse_morphism N)) c)%morphism.
    cbn_rewrite (right_inverse N).
    trivial.
  Qed.

End NatIso_Image.


Require Export Bool.
Require Export Arith.
Require Export Reals.
Require Export Psatz.
Require Export Omega.
Require Export Program.
Require Export List.
Require Export Psatz.
Require Import Monad.

Export ListNotations.

(* Boolean notations, lemmas *)

Notation "¬ b" := (negb b) (at level 10).
Infix  "⊕" := xorb (at level 20).

Search xorb andb.

Lemma xorb_nb_b : forall b, ¬ b ⊕ b = true. Proof. destruct b; easy. Qed.
Lemma xorb_b_nb : forall b, b ⊕ ¬ b = true. Proof. destruct b; easy. Qed.

Lemma xorb_involutive_l : forall b b', b ⊕ (b ⊕ b') = b'. Proof. destruct b, b'; easy. Qed.
Lemma xorb_involutive_r : forall b b', b ⊕ b' ⊕ b' = b. Proof. destruct b, b'; easy. Qed.

Lemma andb_xorb_dist : forall b b1 b2, b && (b1 ⊕ b2) = (b && b1) ⊕ (b && b2).
Proof. destruct b, b1, b2; easy. Qed.

(* A bit of useful reflection from Software Foundations Vol 3 *)

Lemma beq_reflect : forall x y, reflect (x = y) (x =? y).
Proof.
  intros x y.
  apply iff_reflect. symmetry.  apply beq_nat_true_iff.
Qed.

Lemma blt_reflect : forall x y, reflect (x < y) (x <? y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply Nat.ltb_lt.
Qed.

Lemma ble_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply Nat.leb_le.
Qed.

Hint Resolve blt_reflect ble_reflect beq_reflect : bdestruct.

Ltac bdestruct X :=
  let H := fresh in let e := fresh "e" in
   evar (e: Prop);
   assert (H: reflect e X); subst e;
    [eauto with bdestruct
    | destruct H as [H|H];
       [ | try first [apply not_lt in H | apply not_le in H]]].

Ltac bdestructΩ X := bdestruct X; simpl; try omega.

(* Distribute functions over lists *)

Lemma if_dist : forall (A B : Type) (b : bool) (f : A -> B) (x y : A), f (if b then x else y) = if b then f x else f y.
Proof. destruct b; reflexivity. Qed.

(* Currying *)

Definition curry {A B C : Type} (f : A * B -> C) : (A -> B -> C) :=
  fun x y => f (x,y).
Definition uncurry {A B C : Type} (f : A -> B -> C) : (A * B -> C) :=
  fun p => f (fst p) (snd p).

(* Lists *)

(* Precondition: x must appear in li *)
Fixpoint lookup (x : nat) (li : list nat) : nat :=
  match li with
  | nil => 0
  | y :: ys => if x =? y then 0 else S (lookup x ys)
  end.

(*
Fixpoint index {A} (i : nat) (li : list A) : option A :=
  match i, li with
  | _, nil => None
  | 0, x :: _ => Some x
  | S i', _ :: li' => index i' li'
  end.
*)
Notation "l !! i" := (nth_error l i) (at level 20).

Fixpoint remove_at {A} (i : nat) (ls : list A) :=
  match i, ls with
  | _   ,[]        => []
  | 0   , _ :: ls' => ls'
  | S i', a :: ls' => a :: remove_at i' ls'
  end.

Fixpoint update_at {A} (ls : list A) (i : nat) (a : A) : list A :=
  match ls, i with
  | []      , _    => []
  | _ :: ls', 0    => a :: ls'
  | b :: ls', S i' => b :: update_at ls' i' a
  end.

Lemma update_length : forall A (l: list A) (a : A) (n : nat),
    length (update_at l n a) = length l.
Proof.
  induction l; auto.
  simpl.
  destruct n.
  easy.
  simpl.
  rewrite IHl; easy.
Qed.

Fixpoint Injective {A} (ls : list A) :=
  match ls with
  | [] => True
  | x :: ls' => ~ In x ls' /\ Injective ls'
  end.

Lemma nth_nil : forall {A} x, ([] : list A) !! x = None.
Proof.
  destruct x; auto.
Qed.

Lemma repeat_combine : forall A n1 n2 (a : A),
  List.repeat a n1 ++ List.repeat a n2 = List.repeat a (n1 + n2).
Proof.
  induction n1; trivial.
  intros. simpl.
  rewrite IHn1.
  reflexivity.
Qed.

Lemma rev_repeat : forall A (a : A) n, rev (repeat a n) = repeat a n.
Proof.
  induction n; simpl; trivial.
  rewrite IHn.
  rewrite (repeat_combine A n 1).
  rewrite Nat.add_1_r.
  reflexivity.
Qed.

Lemma firstn_repeat_le : forall A (a : A) m n, (m <= n)%nat -> firstn m (repeat a n) = repeat a m.
Proof.
  induction m; trivial.
  intros n L.
  destruct n; [inversion L|].
  simpl.
  rewrite IHm by omega.
  reflexivity.
Qed.

Lemma firstn_repeat_ge : forall A (a : A) m n, (m >= n)%nat -> firstn m (repeat a n) = repeat a n.
Proof.
  intros A a m n H.
  generalize dependent m.
  induction n; intros m L; simpl.
  - apply firstn_nil.
  - destruct m; [inversion L|].
    simpl.
    rewrite IHn by omega.
    reflexivity.
Qed.

Lemma firstn_repeat : forall A (a : A) m n, firstn m (repeat a n) = repeat a (min m n).
Proof.
  intros.
  bdestruct (m <=? n).
  - rewrite firstn_repeat_le, Min.min_l; easy.
  - rewrite firstn_repeat_ge, Min.min_r; try omega; easy.
Qed.

Lemma skipn_repeat : forall A (a : A) m n, skipn m (repeat a n) = repeat a (n-m).
Proof.
  induction m; intros n; simpl.
  - rewrite Nat.sub_0_r. reflexivity.
  - destruct n; trivial.
    simpl.
    apply IHm.
Qed.

Lemma skipn_length : forall {A} (l : list A) n, length (skipn n l) = (length l - n)%nat.
Proof.
  Transparent skipn.
  intros A l.
  induction l.
  intros [|n]; easy.
  intros [|n].
  easy.
  simpl.
  rewrite IHl.
  easy.
  Opaque skipn.
Qed.

(* option type *)

Definition maybe {A} (o : option A) (default : A) : A :=
  match o with
  | Some a => a
  | None => default
  end.

(* Why are we defining this from scratch??? *)
Fixpoint inb (a : nat) (ls : list nat) : bool :=
  match ls with
  | [] => false
  | b :: ls' => (b =? a) || inb a ls'
  end%bool.

Fixpoint subset (ls1 ls2 : list nat) : bool :=
  match ls1 with
  | [] => true
  | a :: ls1' => inb a ls2 && subset ls1' ls2
  end.
Notation "ls1 ⊆ ls2" := (subset ls1 ls2 = true) (at level 30).

Fixpoint disjoint (ls1 ls2 : list nat) : bool :=
  match ls1 with
  | [] => true
  | a :: ls1' => (negb (inb a ls2)) && disjoint ls1' ls2
  end.
Notation "ls1 ⊥ ls2" := (disjoint ls1 ls2 = true) (at level 30).

Lemma disjoint_nil_l : forall ls, nil ⊥ ls. Proof. reflexivity. Qed.
Lemma disjoint_nil_r : forall ls, ls ⊥ nil. Proof. induction ls; trivial. Qed.

Lemma disjoint_cons : forall a ls1 ls2,
    ((negb (inb a ls1)) && disjoint ls1 ls2 = disjoint ls1 (a :: ls2))%bool.
Proof.
  intros a ls1 ls2.
  induction ls1. reflexivity.
  simpl.
  rewrite <- IHls1.
  rewrite Nat.eqb_sym.
  destruct (a =? a0), (inb a ls1), (inb a0 ls2); auto.
Qed.

Lemma disjoint_symm : forall ls1 ls2, disjoint ls1 ls2 = disjoint ls2 ls1.
Proof. intros.
       induction ls1.
       - simpl.
         symmetry.
         apply disjoint_nil_r.
       - simpl.
         rewrite <- disjoint_cons.
         rewrite IHls1.
         reflexivity.
Qed.

Lemma eqb_neq : forall x y, x <> y -> x =? y = false.
Proof.
  induction x as [ | x]; destruct y as [ | y]; intros H; auto.
  - contradiction.
  - simpl.
    apply IHx.
    intros H'.
    subst.
    contradiction.
Qed.

Lemma lookup_app : forall x ls1 ls2,
      lookup x (ls1 ++ ls2) = if inb x ls1 then lookup x ls1
                                           else (lookup x ls2 + length ls1)%nat.
Proof.
  induction ls1; intros; simpl; auto.
  destruct (Nat.eq_dec x a) as [H_x_a | H_x_a].
  * subst.
    rewrite Nat.eqb_refl.
    reflexivity.
  * repeat rewrite eqb_neq; auto. simpl.
    rewrite IHls1.
    destruct (inb x ls1); auto.
Qed.

Lemma subset_app : forall ls1 ls2 ls, (ls1 ++ ls2) ⊆ ls -> ls1 ⊆ ls /\ ls2 ⊆ ls.
Proof.
  induction ls1; intros ls2 ls H; simpl in *; split; auto.
  - apply Bool.andb_true_iff in H.
    destruct H as [H_a_ls H].
    rewrite H_a_ls; simpl.
    apply IHls1 in H.
    destruct H; auto.
  - apply Bool.andb_true_iff in H.
    destruct H as [H_a_ls H].
    apply IHls1 in H.
    destruct H; auto.
Qed.

Lemma seq_app : forall offset1 offset2 start,
      seq start offset1 ++ seq (start + offset1) offset2
    = seq start (offset1 + offset2).
Proof.
  induction offset1; intros; simpl; auto.
  rewrite Nat.add_succ_r.
  rewrite <- Nat.add_succ_l.
  rewrite IHoffset1.
  reflexivity.
Qed.

Lemma inb_fmap_S : forall ls x,
      inb (S x) (fmap S ls) = inb x ls.
Proof.
  induction ls; intros; simpl in *; auto.
  simpl.
  rewrite IHls.
  reflexivity.
Qed.

(************************************)
(* Helpful, general purpose tactics *)
(************************************)

Ltac simpl_rewrite lem :=
  let H := fresh "H" in
  specialize lem as H; simpl in H; rewrite H; clear H.

Ltac simpl_rewrite' lem :=
  let H := fresh "H" in
  specialize lem as H; simpl in H; rewrite <- H; clear H.

Ltac simpl_rewrite_h lem hyp :=
  let H := fresh "H" in
  specialize lem as H; simpl in H; rewrite <- H in hyp; clear H.

Ltac apply_with_obligations H :=
  match goal with
  | [|- ?P ?a]    => match type of H with ?P ?a' =>
    replace a with a'; [apply H|]; trivial end
  | [|- ?P ?a ?b] => match type of H with ?P ?a' ?b' =>
    replace a with a'; [replace b with b'; [apply H|]|]; trivial end
  | [|- ?P ?a ?b ?c ] => match type of H with ?P ?a' ?b' ?c' =>
    replace a with a'; [replace b with b'; [replace c with c'; [apply H|]|]|]; trivial end
  | [|- ?P ?a ?b ?c ?d] => match type of H with ?P ?a' ?b' ?c' ?d' =>
    replace a with a'; [replace b with b'; [replace c with c'; [replace d with d'; [apply H|]|]|]|]; trivial end
  | [|- ?P ?a ?b ?c ?d ?e] => match type of H with ?P ?a' ?b' ?c' ?d' ?e' =>
    replace a with a'; [replace b with b'; [replace c with c'; [replace d with d'; [replace e with e'; [apply H|]|]|]|]|];
    trivial end
  | [|- ?P ?a ?b ?c ?d ?e ?f] => match type of H with ?P ?a' ?b' ?c' ?d' ?e' ?f' =>
    replace a with a'; [replace b with b'; [replace c with c'; [replace d with d'; [replace e with e'; [replace f with f';
    [apply H|]|]|]|]|]|]; trivial end
  | [|- ?P ?a ?b ?c ?d ?e ?f ?g] => match type of H with ?P ?a' ?b' ?c' ?d' ?e' ?f' ?g' =>
    replace a with a'; [replace b with b'; [replace c with c'; [replace d with d'; [replace e with e'; [replace f with f';
    [replace g with g'; [apply H|]|]|]|]|]|]|]; trivial end
  end.

(* From SF - up to five arguments *)
Tactic Notation "gen" ident(X1) :=
  generalize dependent X1.
Tactic Notation "gen" ident(X1) ident(X2) :=
  gen X2; gen X1.
Tactic Notation "gen" ident(X1) ident(X2) ident(X3) :=
  gen X3; gen X2; gen X1.
Tactic Notation "gen" ident(X1) ident(X2) ident(X3) ident(X4) :=
  gen X4; gen X3; gen X2; gen X1.
Tactic Notation "gen" ident(X1) ident(X2) ident(X3) ident(X4) ident(X5) :=
  gen X5; gen X4; gen X3; gen X2; gen X1.

(***************)
(* Powers of 2 *)
(***************)

Lemma double_mult : forall (n : nat), (n + n = 2 * n)%nat. Proof. intros. omega. Qed.
Lemma pow_two_succ_l : forall x, (2^x * 2 = 2 ^ (x + 1))%nat.
Proof. intros. rewrite mult_comm. rewrite <- Nat.pow_succ_r'. intuition. Qed.
Lemma pow_two_succ_r : forall x, (2 * 2^x = 2 ^ (x + 1))%nat.
Proof. intros. rewrite <- Nat.pow_succ_r'. intuition. Qed.
Lemma double_pow : forall (n : nat), (2^n + 2^n = 2^(n+1))%nat.
Proof. intros. rewrite double_mult. rewrite pow_two_succ_r. reflexivity. Qed.
Lemma pow_components : forall (a b m n : nat), a = b -> m = n -> (a^m = b^n)%nat.
Proof. intuition. Qed.

Ltac unify_pows_two :=
  repeat match goal with
  (* NB: this first thing is potentially a bad idea, do not do with 2^1 *)
  | [ |- context[ 4%nat ]]                  => replace 4%nat with (2^2)%nat by reflexivity
  | [ |- context[ (0 + ?a)%nat]]            => rewrite plus_0_l
  | [ |- context[ (?a + 0)%nat]]            => rewrite plus_0_r
  | [ |- context[ (1 * ?a)%nat]]            => rewrite Nat.mul_1_l
  | [ |- context[ (?a * 1)%nat]]            => rewrite Nat.mul_1_r
  | [ |- context[ (2 * 2^?x)%nat]]          => rewrite <- Nat.pow_succ_r'
  | [ |- context[ (2^?x * 2)%nat]]          => rewrite pow_two_succ_l
  | [ |- context[ (2^?x + 2^?x)%nat]]       => rewrite double_pow
  | [ |- context[ (2^?x * 2^?y)%nat]]       => rewrite <- Nat.pow_add_r
  | [ |- context[ (?a + (?b + ?c))%nat ]]   => rewrite plus_assoc
  | [ |- (2^?x = 2^?y)%nat ]                => apply pow_components; try omega
  end.


Require Import Coq.Program.Basics.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Export Coq.Classes.RelationPairs.
Require Import Coq.Setoids.Setoid.

(** * Interface *)

(** Lenses are identified by the corresponding projection, which is
  also used to define the [get] operation. Note that because we use
  the letter [S] to denote the source type, which conflicts with the
  successor function on [nat] from the standard library, we need to
  use a verbose style below to avoid arguments being named [S0] or
  something such. (This is an obvious software engineering quirk
  with the way Coq generates identifier.) *)

Class LensOps {S V: Type} (π: S -> V) := {
  set: V -> S -> S
}.

Arguments set {S V} π {_} _ _ : simpl never.

Class LensSetGet {S V} π
  `{lens_ops: LensOps S V π} :=
{
  lens_set_get s:
    set π (π s) s = s
}.

Class LensGetSet {S V} π
  `{lens_ops: LensOps S V π} :=
{
  lens_get_set v s:
    π (set π v s) = v
}.

Class LensSetSet {S V} π
  `{lens_set: LensOps S V π} :=
{
  lens_set_set u v s:
    set π u (set π v s) = set π u s
}.

Class Lens {S V} π `{lens_ops: LensOps S V π} := {
  lens_lens_set_get :> LensSetGet π;
  lens_lens_get_set :> LensGetSet π;
  lens_lens_set_set :> LensSetSet π
}.

(** * Theory *)

(** ** Getters are measures, cf. [Coq.Classes.RelationPairs] *)

Instance lens_get_measure {S V} `{LensOps S V}:
  Measure (π).

(** ** The [modify] operation *)

Section MODIFY.
  Context {S V π} `{HSV: Lens S V π}.

  Definition modify (f: V -> V) (s: S) :=
    set π (f (π s)) s.

  Lemma lens_unfold_modify f s:
    modify f s = set π (f (π s)) s.
  Proof.
    reflexivity.
  Qed.
End MODIFY.

Arguments modify {S V} π {_} _ _.

(** ** The [same_context] relation *)

Section SAMECONTEXT.
  Context {S V π} `{lens_ops: LensOps S V π} `{HSV: LensSetSet S V π}.

  Definition same_context: relation S :=
    fun s t => forall v, set π v s = set π v t.

  Lemma lens_set_same_context v s:
    same_context (set π v s) s.
  Proof.
    intro u.
    apply lens_set_set.
  Qed.

  Lemma lens_modify_same_context f s:
    same_context (modify π f s) s.
  Proof.
    intro u.
    unfold modify.
    apply lens_set_set.
  Qed.

  Global Instance same_context_equiv: Equivalence same_context.
  Proof.
    split.
    * intros s v.
      reflexivity.
    * intros s t Hst u.
      symmetry; now auto.
    * intros s1 s2 s3 H12 H23 u.
      transitivity (set π u s2); now auto.
  Qed.

  Global Instance same_context_set_mor:
    Proper (eq ==> same_context ==> eq) (set π).
  Proof.
    intros u v Huv s t Hst.
    subst.
    apply Hst.
  Qed.

  Global Instance same_context_modify_mor f:
    Proper (same_context ==> same_context) (modify π f).
  Proof.
    intros s t Hst u.
    unfold modify.
    rewrite !lens_set_set.
    apply Hst.
  Qed.
End SAMECONTEXT.

Arguments same_context {S V} π {_} _ _.

(** ** Consequences of [LensGetSet] *)

Section GETSET.
  Context {S V} `{Hgs: LensGetSet S V}.

  Lemma lens_get_modify f s:
    π (modify π f s) = f (π s).
  Proof.
    apply lens_get_set.
  Qed.

  Theorem lens_eq_set (s: S) (u v: V):
    set π u s = set π v s <-> u = v.
  Proof.
    split; intros.
    * rewrite <- (lens_get_set u s).
      rewrite <- (lens_get_set v s).
      apply f_equal.
      assumption.
    * apply (f_equal (fun x => set π x s)).
      assumption.
  Qed.
End GETSET.

(** ** Consequences of [LensSetGet] *)

Section SETGET.
  Context {S V} `{HSV: LensSetGet S V}.

  (* same_context ∧ (eq @@ π) ⇔ eq *)
  Lemma lens_same_context_eq s1 s2:
    same_context π s1 s2 ->
    π s1 = π s2 ->
    s1 = s2.
  Proof.
    intros Hc Hv.
    rewrite <- (lens_set_get s1).
    rewrite <- (lens_set_get s2).
    rewrite Hv.
    apply Hc.
  Qed.
End SETGET.

(** ** Orthogonal lenses *)

(** We say that two lenses on [S] are orthogonal when they give us
  access to two independent parts of the larger structure [S],
  ie. modifying one will not affect the other. The property
  [lens_ortho_setr_setl] below is sufficient to express this.

  Note that for any two orthogonal lenses [π] and [ρ], you should
  never declare instances of both [OrthogonalLenses π ρ] and
  [OrthogonalLenses ρ π], since that would produce a loop in the
  [autorewrite] rules, which use [ortho_lenses_set_set]. *)

Class Orthogonal {S U V} (π: S -> U) (ρ: S -> V)
  `{πs: !LensOps π}
  `{ρs: !LensOps ρ}: Prop :=
{
  lens_ortho_setr_setl u v s:
    set ρ v (set π u s) = set π u (set ρ v s)
}.

Section ORTHOGONAL_LENSES.
  Context {S U V} (π: S -> U) (ρ: S -> V).
  Context `{πops: !LensOps π}.
  Context `{ρops: !LensOps ρ}.
  Context `{Hπρ: !Orthogonal π ρ}.

  Lemma lens_ortho_getl_setr `{Hπgs: !LensGetSet π} `{Hπsg: !LensSetGet π} s v:
    π (set ρ v s) = π s.
  Proof.
    rewrite <- (lens_set_get (π := π) s) at 1.
    rewrite lens_ortho_setr_setl.
    rewrite lens_get_set.
    reflexivity.
  Qed.

  Lemma lens_ortho_getr_setl `{Hρgs: !LensGetSet ρ} `{Hρsg: !LensSetGet ρ} s u:
    ρ (set π u s) = ρ s.
  Proof.
    rewrite <- (lens_set_get (π := ρ) s) at 1.
    rewrite <- lens_ortho_setr_setl.
    rewrite lens_get_set.
    reflexivity.
  Qed.
End ORTHOGONAL_LENSES.

Hint Rewrite
    @lens_get_set
    @lens_set_get
    @lens_set_set
    @lens_unfold_modify
    @lens_eq_set
    @lens_set_same_context
    @lens_modify_same_context
  using typeclasses eauto : lens.

(** * Tactics *)

(** The [autorewrite] base above can be used for normalization,
  however it is unable to handle some of the theorems related to
  orthogonal lenses.

  For example, we want to use [lens_ortho_getl_setr] to rewrite
  occurences of [α (set β v s)], where [α] and [β] are orthogonal
  lenses, into simply [α s]. However, our usual trick for combining
  [autorewrite] and typeclass resolution does not work, because the
  instance of [LensOps α] cannot be obtained by unification when using
  [@lens_ortho_getl_setr], which means the premises contain
  existentials and we would need [erewrite].

  Furthermore, we wish to normalize series of nested [set] so that
  their order matches the declared instances of [Orthogonal]. However,
  rewriting with [@lens_ortho_setr_setl] will only match the first
  pair, and fail if they are already in the right order (because a
  corresponding instance of [Orthogonal] won't be found).

  So we use the tactic below to apply those explicitely in addition
  to using [autorewrite]. *)

Ltac lens_norm_ortho :=
  repeat progress
    match goal with
      | H: context [set ?β ?v (set ?α ?u ?s)] |- _ =>
        rewrite (lens_ortho_setr_setl u v s) in H
      | |- context [set ?β ?v (set ?α ?u ?s)] =>
        rewrite (lens_ortho_setr_setl u v s)
      | H: context [?α (set ?β ?v ?s)] |- _ =>
        rewrite (lens_ortho_getl_setr α β s v) in H
      | |- context [?α (set ?β ?v ?s)] =>
        rewrite (lens_ortho_getl_setr α β s v)
      | H: context [?β (set ?α ?u ?s)] |- _ =>
        rewrite (lens_ortho_getr_setl α β s u) in H
      | |- context [?β (set ?α ?u ?s)] =>
        rewrite (lens_ortho_getr_setl α β s u)
    end.

Ltac lens_norm :=
  repeat progress (simpl in *;
                   lens_norm_ortho;
                   autorewrite with lens in *).

Ltac lens_simpl :=
  repeat progress (lens_norm; autorewrite with lens_simpl in *).

Ltac lens_unfold :=
  repeat progress (lens_simpl; unfold set in *).

(** * Instances *)

(** ** Pairs *)

Section PAIR.
  Global Instance fst_lensops A B: LensOps (@fst A B) := {
    set a x := (a, snd x)
  }.

  Global Instance fst_lens A B: Lens (@fst A B).
  Proof.
    split; split; intuition.
  Qed.

  Global Instance snd_lensops A B: LensOps (@snd A B) := {
    set b x := (fst x, b)
  }.

  Global Instance snd_lens A B: Lens (@snd A B).
  Proof.
    split; split; intuition.
  Qed.

  (** Here are some product-specific theorems. *)

  Lemma fst_same_context_eq_snd {A B} (x y: A * B):
    same_context (@fst A B) x y <-> snd x = snd y.
  Proof.
    destruct x as [a1 b1].
    destruct y as [a2 b2].
    split; intro H.
    * specialize (H a1).
      inversion H.
      reflexivity.
    * intro a.
      compute in *.
      congruence.
  Qed.

  Lemma snd_same_context_eq_fst {A B} (x y: A * B):
    same_context (@snd A B) x y <-> fst x = fst y.
  Proof.
    destruct x as [a1 b1].
    destruct y as [a2 b2].
    split; intro H.
    * specialize (H b1).
      inversion H.
      reflexivity.
    * intro b.
      compute in *.
      congruence.
  Qed.
End PAIR.

Hint Rewrite
  @fst_same_context_eq_snd
  @snd_same_context_eq_fst
  : lens_simpl.

(** ** Composing lens *)

Section COMPOSE.
  Context {A B C} (π: A -> B) (ρ: B -> C) `{Hπ: Lens _ _ π} `{Hρ: Lens _ _ ρ}.

  Instance compose_lensops: LensOps (compose ρ π) := {
    set c a := modify π (set ρ c) a
  }.

  Lemma lens_compose_get_simpl a:
    compose ρ π a = ρ (π a).
  Proof.
    reflexivity.
  Qed.

  Lemma lens_compose_set_simpl c a:
    set (compose ρ π) c a = modify π (set ρ c) a.
  Proof.
    reflexivity.
  Qed.

  Instance lens_compose_get_set: LensGetSet (compose ρ π).
  Proof.
    constructor; simpl; intros.
    rewrite lens_compose_get_simpl.
    rewrite lens_compose_set_simpl.
    autorewrite with lens.
    reflexivity.
  Qed.

  Instance lens_compose_set_get: LensSetGet (compose ρ π).
  Proof.
    constructor; simpl; intros.
    rewrite lens_compose_get_simpl.
    rewrite lens_compose_set_simpl.
    autorewrite with lens.
    reflexivity.
  Qed.

  Instance lens_compose_set_set: LensSetSet (compose ρ π).
  Proof.
    constructor; simpl; intros.
    rewrite !lens_compose_set_simpl.
    autorewrite with lens.
    reflexivity.
  Qed.

  Instance lens_compose: Lens (compose ρ π) := {}.
End COMPOSE.

Hint Rewrite
    @lens_compose_get_simpl
    @lens_compose_set_simpl
  using typeclasses eauto : lens_simpl.

(** ** Initial and terminal objects *)

Section INITIAL.
  Context {V: Type} (π: Empty_set -> V).

  Global Instance lens_empty_ops: LensOps π := {
    set a := Empty_set_rect _
  }.

  Global Instance lens_empty: Lens π.
  Proof.
    split; split; tauto.
  Qed.
End INITIAL.

Section COPRODUCT.
  Context {A B V} {α: A -> V} {β: B -> V}.
  Context `{αops: LensOps A V α}.
  Context `{βops: LensOps B V β}.

  Definition fcoprod (f: A -> V) (g: B -> V): A + B -> V :=
    fun s => match s with
               | inl a => f a
               | inr b => g b
             end.

  Notation "[ f , g ]" := (fcoprod f g).

  Instance lens_coprod_ops: LensOps [α, β] := {
    set v ab :=
      match ab with
        | inl a => inl (set α v a)
        | inr b => inr (set β v b)
      end
  }.

  Instance lens_coprod_get_set:
    LensGetSet α ->
    LensGetSet β ->
    LensGetSet [α,β].
  Proof.
    constructor.
    intros v [a|b];
    unfold set; simpl.
    * lens_norm; reflexivity.
    * lens_norm; reflexivity.
  Qed.

  Instance lens_coprod_set_get:
    LensSetGet α ->
    LensSetGet β ->
    LensSetGet [α,β].
  Proof.
    constructor.
    intros [a|b];
    unfold set; simpl.
    * lens_norm; reflexivity.
    * lens_norm; reflexivity.
  Qed.

  Instance lens_coprod_set_set:
    LensSetSet α ->
    LensSetSet β ->
    LensSetSet [α,β].
  Proof.
    constructor.
    intros u v [a|b];
    unfold set; simpl;
    f_equal.
    * lens_norm; reflexivity.
    * lens_norm; reflexivity.
  Qed.

  Global Instance lens_coprod:
    Lens α ->
    Lens β ->
    Lens [α,β].
  Proof.
    constructor;
    typeclasses eauto.
  Qed.
End COPRODUCT.

Section TERMINAL.
  Context {S: Type} (π: S -> unit).

  Instance lens_unit_ops: LensOps (S := S) π := {
    set u s := s
  }.

  Instance lens_unit: Lens π.
  Proof.
    assert (forall u v: unit, u = v) by (intros [] []; reflexivity).
    firstorder.
  Qed.
End TERMINAL.

(** Interestingly, the product only works for orthogonal lenses. *)

Section PRODUCT.
  Context {S A B} {α: S -> A} {β: S -> B}.
  Context `{αops: LensOps S A α}.
  Context `{βops: LensOps S B β}.

  Definition fprod (f: S -> A) (g: S -> B): S -> A * B :=
    fun s => (f s, g s).

  Notation "〈  f , g 〉" := (fprod f g).

  Instance lens_prod_ops: LensOps 〈α, β〉 := {
    set ab s := set α (fst ab) (set β (snd ab) s)
  }.

  Ltac go :=
    unfold set, fprod;
    simpl;
    lens_norm;
    try reflexivity.

  Instance lens_prod_get_set:
    Orthogonal α β ->
    LensSetGet β ->
    LensGetSet α ->
    LensGetSet β ->
    LensGetSet 〈α,β〉.
  Proof.
    constructor.
    intros [a b] s.
    go.
  Qed.

  Instance lens_prod_set_get:
    LensSetGet α ->
    LensSetGet β ->
    LensSetGet 〈α,β〉.
  Proof.
    constructor.
    intros s.
    go.
  Qed.

  Instance lens_prod_set_set:
    Orthogonal α β ->
    LensSetSet α ->
    LensSetSet β ->
    LensSetSet 〈α,β〉.
  Proof.
    constructor.
    intros [a1 b1] [a2 b2] s.
    go.
  Qed.

  Global Instance lens_prod:
    Orthogonal α β ->
    Lens α ->
    Lens β ->
    Lens 〈α,β〉.
  Proof.
    constructor;
    typeclasses eauto.
  Qed.
End PRODUCT.


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From adtind Require Import goal41.

Set Printing Depth 1000.
Definition lfind_eval  y x:=
lst_intersection x y.

Compute lfind_eval  (Nil) (Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ (Succ (Succ Zero)))) Nil)) (Cons Zero Nil).

Compute lfind_eval  (Nil) (Cons Zero (Cons (Succ (Succ (Succ Zero))) (Cons Zero Nil))).

Compute lfind_eval  (Cons Zero Nil) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Nil) (Cons Zero (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons (Succ Zero) Nil))) (Nil).

Compute lfind_eval  (Cons (Succ (Succ (Succ (Succ Zero)))) Nil) (Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ Zero) Nil)) (Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) Nil)) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Nil) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) Nil)) (Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons Zero Nil) (Nil).

Compute lfind_eval  (Nil) (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Cons Zero Nil) (Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) Nil)) (Nil).

Compute lfind_eval  (Nil) (Cons Zero Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil))) (Nil).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Nil).

Compute lfind_eval  (Nil) (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Cons (Succ (Succ Zero)) (Cons (Succ (Succ (Succ Zero))) Nil)).

Compute lfind_eval  (Nil) (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Nil) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons Zero Nil) (Nil).

Compute lfind_eval  (Nil) (Cons Zero Nil).

Compute lfind_eval  (Nil) (Nil).

Compute lfind_eval  (Nil) (Nil).


(** Authors Langston Barrett (@siddharthist), November-December 2017 *)

Require Import UniMath.Algebra.Modules.Core.
Require Import UniMath.Algebra.Modules.Multimodules.
Require Import UniMath.Algebra.Monoids.
Require Import UniMath.Algebra.Groups.
Require Import UniMath.Algebra.RigsAndRings.
Require Import UniMath.Foundations.Preamble.
Require Import UniMath.MoreFoundations.Tactics.

(** ** Contents
- Morphisms
- (Multi)modules
 - Bimodules
*)

(** ** Morphisms *)
Local Open Scope ring_scope.

(** The identity function is linear *)
Definition idfun_linear {R : ring} (M : module R) : islinear (idfun M).
Proof. easy. Defined.

(** The identity function is multilinear *)
Definition idfun_multilinear {I : UU} {rings : I -> ring} (MM : multimodule rings) :
  @ismultilinear I rings MM MM (idfun MM) :=
  (fun i => idfun_linear (ith_module MM i)).

(** The identity function is a morphism of modules *)
Definition id_modulefun {R : ring} (M : module R) : ismodulefun (idfun M).
Proof. easy. Defined.

(** The identity function is a morphism of modules *)
Definition idmoduleiso {R : ring} (M : module R) : moduleiso M M.
Proof.
   use make_moduleiso.
   - exact (idweq (pr1module M)).
   - apply make_dirprod.
     + intros x y. apply idpath.
     + intros r x. apply idpath.
Defined.

(** The identity function is a multimodule morphism *)
Definition id_multimodulefun {I : UU} {rings : I -> ring} (MM : multimodule rings)
  : @ismultimodulefun I rings MM MM (idfun MM) :=
  (make_dirprod (λ x y : MM, idpath _) (fun i => idfun_linear (ith_module MM i))).

(** ** (Multi)modules *)

(** The left action of a ring through a ring homomorphism
    See Bourbaki's Algebra, II §1.4, no. 1, Example 1.
 *)
Definition ringfun_left_mult {R S : ring} (f : ringfun R S) (r : R)
: ringofendabgr S.
Proof.
  refine
  (* This is the actual definition of the function *)
  ((λ x : S, (f r * x)),,
   (* And this is the justification that it's a monoid morphism *)
                       (λ _ _, _),, _).
  apply (rigldistr S _ _ _). apply (rigmultx0 S).
Defined.

(** An important special case: the left action of a ring on itself *)
Example ring_left_mult {R : ring} : R -> ringofendabgr R :=
  ringfun_left_mult (rigisotorigfun (idrigiso R)).

(** A ring morphism R -> S defines an R-module structure on the additive abelian
    group of S *)
Definition ringfun_module {R S : ring} (f : ringfun R S) : module R.
  refine (@ringaddabgr S,, _).
  apply (@mult_to_module_struct R S (pr1 ∘ ringfun_left_mult f)%functions);
    unfold funcomp, pr1, ringfun_left_mult.
  - exact (fun r x y => ringldistr S x y (f r)).
  - exact (fun r s x => (maponpaths (λ x, x * _) ((pr1 (pr1 (pr2 f))) r s)) @
                        (ringrdistr _ (f r) (f s) x)).
  - exact (fun r s x => ((maponpaths (fun y => y * x) ((pr1 (pr2 (pr2 f))) r s) @
                         (rigassoc2 S (f r) (f s) x)))).
  - exact (fun x => maponpaths (fun y => y * x) (pr2 (pr2 (pr2 f))) @
                               (@riglunax2 S x)).
Defined.

(** An important special case: a ring is a module over itself *)
Definition ring_is_module (R : ring) : module R :=
  ringfun_module (rigisotorigfun (idrigiso R)).

(** The zero module is the unique R-module structure on the zero group (the
    group with a single element) *)
Definition zero_module (R : ring) : module R.
Proof.
  refine (unitabgr,, _).
  apply (@mult_to_module_struct _ _ (λ _ u, u));
    easy.
Defined.

(** *** Bimodules *)

Local Open Scope ring.

(** An R-S-bimodule is a left R module and a right S module, that is
    With our definitions, this means a multimodule over bool with an R-module
    structre, an S⁰-module structure, and some compatibility between them. *)
Definition bimodule (R S : ring) : UU := @multimodule _ (bool_rect _ R (S⁰)).

(** The more immediate/intuitive description of a bimodule. Below, we provide a
    way to construct a bimodule from this definition (make_bimodule). *)
Definition bimodule_struct' (R S : ring) (G : abgr) : UU :=
  (* A bimodule structure consists of two modules structures... *)
  ∑ (mr : module_struct R G) (ms : module_struct (S⁰) G),
    (* ...and a notion of compatibility between them. *)
    let mulr := module_mult (G,, mr) in
    let muls := module_mult (G,, ms) in
    ∏ (r : R) (s : S), mulr r ∘ muls s = muls s ∘ mulr r.

Definition make_bimodule (R S : ring) {G} (str : bimodule_struct' R S G) : bimodule R S.
  refine (G,, _).

  (** Index the module structs over bool *)
  refine (bool_rect _ (pr1 str) (pr1 (pr2 str)),, _).

  unfold multimodule_struct.
  (** the [ | ] pattern yields cases with hypotheses false ≠ false and
      true ≠ true, so we use them as contradictions or clear the useless
      hypothesis *)
  intros [ | ] [ | ] neq r s;
    try (contradiction (neq (idpath _))); clear neq; cbn in *.

  - exact ((pr2 (pr2 str)) r s).
  - exact (!((pr2 (pr2 str)) s r)).
Defined.

(** A commutative ring is a bimodule over itself *)
Example commring_bimodule (R : commring) : bimodule R R.
  apply (@make_bimodule R R (@ringaddabgr R)).
  unfold bimodule_struct'.
  refine (pr2module (ring_is_module R),, _).

  (** We transport the module structure across the isomorphism R ≅ R⁰ *)
  refine (pr2module
            (ringfun_module
               (rigisotorigfun (invrigiso (iso_commring_opposite R)))),, _).

  simpl.
  intros r s.
  apply funextfun.
  intros x.
  exact (!@rigassoc2 R r s x @ (maponpaths (fun z => z * x) (@ringcomm2 R r s))
                      @ (rigassoc2 R s r x)).
  Defined. (* TODO: this line takes a while, not sure why *)

Local Close Scope ring.


Require Import List.
Import ListNotations.
Require Import Psatz.
Require Import ssreflect ssrbool ssrfun.

From Undecidability.HSC Require Import HSC_prelim HSC_AX HSC.HSC_util.

(* number of nodes in the syntax tree of a formula *)
Fixpoint size s :=
  match s with
  | var _ => 1
  | arr s t => S (size s + size t)
  end.

(* list of first k arguments *)
Fixpoint arguments (k: nat) (t: formula) :=
  match k with
  | 0 => []
  | S k =>
    match t with
    | var _ => []
    | arr s t => s :: (arguments k t)
    end
  end.

(* target after first k arguments *)
Fixpoint target (k: nat) (t: formula) :=
  match k with
  | 0 => t
  | S k =>
    match t with
    | var _ => t
    | arr _ t => target k t
    end
  end.

(* Hilbert-style calculus with derivation depth *)
Inductive der (Gamma: list formula) : nat -> formula -> Prop :=
  | der_var {ζ: nat -> formula} {s t: formula} {k n: nat} :
      In s Gamma ->
      Forall (der Gamma n) (arguments k (substitute ζ s)) ->
      target k (substitute ζ s) = t ->
      der Gamma (S n) t.

(* can be replaced by derE *)
Lemma der_0E {n Gamma t} : der Gamma n t -> n = S (Nat.pred n).
Proof. move=> H. by inversion H. Qed.

Lemma derE {n Gamma t} : der Gamma n t ->
  exists (ζ: nat -> formula) (s: formula) (k: nat),
    n = S (Nat.pred n) /\
    In s Gamma /\
    Forall (der Gamma (Nat.pred n)) (arguments k (substitute ζ s)) /\
    target k (substitute ζ s) = t.
Proof.
  move=> H. inversion H. do 3 eexists. by eauto.
Qed.

Lemma der_mon {n m t Gamma} : der Gamma n t -> n <= m -> der Gamma m t.
Proof.
  elim: n m Gamma t.
    by move=> > /der_0E.
  move=> n IH m Gamma t.
    move /derE => [ζ [s' [k']]].
    move=> [_ [? [? ?]]] ?.
    have -> : m = S (Nat.pred m) by lia.
    apply: der_var; try eassumption.
    apply: Forall_impl; last by eassumption.
    move=> ? /IH. apply. by lia.
Qed.

Lemma target_S {r s t k} : target k r = arr s t -> target (S k) r = t.
Proof.
  elim: k r s t.
    by move=> > /= ->.
  move=> k IH. case.
    by move=> > /=.
  by move=> > /= /IH <-.
Qed.

Lemma arguments_S {r s t k} : target k r = arr s t -> arguments (S k) r = (arguments k r) ++ [s].
Proof.
  elim: k r s t.
    by move=> > /= ->.
  move=> k IH. case.
    by move=> > /=.
  by move=> > /= /IH <-.
Qed.

(* every hsc derivation has a depth *)
Lemma hsc_der {Gamma t} : hsc Gamma t -> exists n, der Gamma n t.
Proof.
  elim.
    move=> ζ s /der_var => /(_ ζ (substitute ζ s) 0 0).
    move /(_ ltac:(by constructor)). move /(_ ltac:(done)).
    move=> ?. by exists 1.
  move=> s' t' _ [n1 /derE +] _ [n2 /derE].
  move=> [ζ1 [s1 [k1 [-> [Hs1 [? Hk1]]]]]].
  move=> [ζ2 [s2 [k2 [-> [? [? ?]]]]]].
  exists (S (S (n1+n2))). apply: (der_var _ (ζ := ζ1) (s := s1) (k := S k1)).
    - done.
    - rewrite (arguments_S ltac:(eassumption)). rewrite ? Forall_norm. constructor.
        apply: Forall_impl; last eassumption.
        move=> ? /der_mon. apply. by lia.
      apply: der_var; last eassumption; first done.
      apply: Forall_impl; last eassumption.
      move=> ? /der_mon. apply. by lia.
    - apply: target_S. by eassumption.
Qed.

(* every compound derivation can be decomposed *)
Lemma der_hsc {Gamma t n} : der Gamma n t -> hsc Gamma t.
Proof.
  elim: n Gamma t.
    by move=> > /der_0E.
  move=> n IH Gamma t /derE.
  move=> [ζ [s [k [-> [? [+ +]]]]]].
  have : hsc Gamma (substitute ζ s) by apply: hsc_var.
  move: IH. clear. move: (substitute ζ s) => {}s. clear.
  move=> IH. elim: k s.
    move=> s /= *. by subst t.
  move=> k IHk. case.
    move=> ? /= *. by subst t.
  move=> s1 s2 /=. rewrite ? Forall_norm.
  move=> /hsc_arr + [/IH +]. move=> + H. by move=> /(_ H){H} /IHk.
Qed.


Definition e:=Set.
Definition t:= Prop.
Definition Ident:= fun x:e=>  fun y:e=>  x=y.
Check Ident.
Definition Lift:= fun x: e=> fun P:e->t=>  P x.
Definition THE:= fun P Q:e->t=>  exists x: e, (forall y,  P y <-> x=y /\ Q x).
(**Lowering**)
Definition BE:= fun P:(e->t)->t=> fun x:e=> P (fun y:e=>(y=x)).
Check BE.

(**Polymorphic BE**)
Inductive Onebe : Set := be.
Definition BSem1 := e->e->t.
Definition BSem2 := (e->t)->e->t.
Definition be1 : BSem1:= fun x y=> x = y.
Definition be2 : BSem2:= fun P:e->t=>  fun x:e=>  P x.
Definition b1 (b:Onebe) : BSem1 := be1. Coercion b1 : Onebe >-> BSem1.
Definition b2 (b:Onebe) : BSem2 := be2. Coercion b2 : Onebe >-> BSem2.

(**In action, checking lift ident and BE**)
Parameter man woman human: e->t.
Parameter j m h: e.
Check Lift j.
Eval compute in Ident j.
Definition a:= fun P Q:e->t=> exists x:e, P x /\ Q x.
Check BE (a man) j.
Eval compute in BE (a man) j.
Definition every:= fun P Q:e->t=> forall x, P x->Q x.
Eval compute in BE (every man) j.

(**Checking Polymorphism**)
Eval compute in (be:BSem1) (m) j.
Eval compute in (be:BSem2) (man) j.


From mathcomp Require Export ssreflect eqtype ssrbool.
From discprob.basic Require Export classic_proof_irrel.

Lemma sval_inj_pred {A: Type} (P: pred A) (a b: {x : A | P x}):
  sval a = sval b -> a = b.
Proof.
  destruct a, b. rewrite /sval. intros. subst; f_equal. apply bool_irrelevance.
Qed.

Lemma sval_inj_pi {A: Type} (P: A -> Prop) (a b: {x : A | P x}):
  sval a = sval b -> a = b.
Proof.
  destruct a, b. rewrite /sval. intros. subst; f_equal. apply classical_proof_irrelevance.
Qed.


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

Set Implicit Arguments.

Section Acc_irrelevance.

  Variable (X : Type) (R : X -> X -> Prop).

  (* Equivalence of two accessibility proofs kind of hereditary
     closure under FunExt *)

  Inductive Acc_eq : forall x, Acc R x -> Acc R x -> Prop :=
    | in_Acc_eq : forall x A1 A2, (forall y H, @Acc_eq y (A1 y H) (A2 y H))
                               -> @Acc_eq x (Acc_intro _ A1) (Acc_intro _ A2).

  (** All accessibility proofs are equivalent !!
      But equality between those proofs cannot be proved w/o FunExt
      Notice that we use a dependent induction principle here *)

  Fact Acc_eq_total x H1 H2 : @Acc_eq x H1 H2.
  Proof.
    revert H2.
    induction H1 as [ ? ? IH ] using Acc_inv_dep.
    intros []; constructor; intros; apply IH.
  Qed.

  (** This provides a way to show that a dependent function
               forall x, Acc R x -> P x
      is Acc irrelevant *)

  Variables (P : X -> Type) (f : forall x, Acc R x -> P x)
            (Hf : forall x H1 H2, (forall y Hy, f (H1 y Hy) =  f (H2 _ Hy))
                               ->  f (Acc_intro x H1) = f (Acc_intro x H2)).

  Theorem Acc_irrelevance x H1 H2 : @f x H1 = f H2.
  Proof.
    generalize (Acc_eq_total H1 H2).
    induction 1 as [ x H1 H2 _ IH ].
    apply Hf, IH.
  Qed.

End Acc_irrelevance.


From Undecidability.Shared.Libs.PSL Require Import Base FinTypes.
From Undecidability.Shared.Libs.PSL Require Import Vectors.Vectors.
From Complexity.Libs.CookPrelim Require Import MorePrelim FlatFinTypes.
From Complexity.NP.SAT.CookLevin Require Import BinaryCC CC CC_homomorphisms.
Require Import Lia.

(** * CC to BinaryCC *)
(** We reduce arbitrary CC instances to a binary alphabet by using the results on uniform homomorphisms. *)

Section fixInstance.
  (** we first do the reduction for wellformed instances, satisfying the syntactic requirements *)
  Variable (pr : CC).

  Notation Sigma := (Sigma pr).
  Notation offset := (offset pr).
  Notation width := (width pr).
  Notation init := (init pr).
  Notation cards := (cards pr).
  Notation final := (final pr).
  Notation steps := (steps pr).

  Context (A : CC_wellformed pr).
  Context (A1 : |elem Sigma| > 0). (*instances without this property are trivial no-instances *)

  (*we fix the homomorphism on natural numbers *)
  (*it just encodes the alphabet using a unary encoding: there is one indicator bit for each element of the alphabet*)
  Definition hNat (Sig : nat) (x : nat) := if leb (S x) Sig then repeat false x ++ [true] ++ repeat false (Sig - x -1)
                                                else repeat false Sig.

  Lemma hNat_length (Sig x : nat) : |hNat Sig x| = Sig.
  Proof using.
    clear A A1 pr.
    unfold hNat. destruct leb eqn:H.
    - rewrite !app_length, !repeat_length. apply leb_complete in H. cbn. nia.
    - apply repeat_length.
  Qed.

  Lemma hP_inv1 (Sig x n : nat) : hNat Sig x = repeat false n ++ [true] ++ repeat false (Sig - n -1) -> x = n.
  Proof.
    intros. unfold hNat in H.
    destruct leb eqn:H1.
    - clear H1. revert H.  generalize (Sig - x- 1). generalize (Sig - n -1).
      revert n. induction x; intros.
      + destruct n; cbn in H; [reflexivity | congruence].
      + destruct n; cbn in H; [ congruence | ]. inv H. now apply IHx in H1.
    - destruct (le_lt_dec n Sig).
      + assert (|repeat false n| <= |repeat false Sig|) by (now rewrite !repeat_length).
        apply list_length_split1 in H0 as (s1 & s2 & H0 & _ & H2). rewrite H2 in H.
        apply app_eq_length in H as (_ & H); [ | apply H0].
        apply repEl_app_inv in H2 as (n1 & n2 & -> & -> & H2).
        destruct n2; cbn in H; congruence.
      + match type of H with ?a = ?b => assert (|a| = |b|) by congruence end.
        rewrite !app_length, !repeat_length in H0. lia.
  Qed.

  (** now, the homomorphism for finite types is defined by composing hNat and index *)
  Definition h' (x : Sigma) := hNat (|elem Sigma|) (index x).

  Lemma hP_injective : injective h'.
  Proof.
    intros x y H. unfold h', hNat in H.
    erewrite (leb_correct (S (index y))) in H. 2: apply index_le.
    now apply hP_inv1, injective_index in H.
  Qed.

  Lemma hP_length x : |h' x| = |elem Sigma|.
  Proof.
    unfold h'. now rewrite hNat_length.
  Qed.

  Definition h := h h'.

  Notation hoffset := (@hoffset pr (|elem Sigma|)).
  Notation hwidth := (@hwidth pr (|elem Sigma|)).
  Notation hinit := (@hinit (FinType (EqType bool)) pr h').
  Notation hcards := (@hcards (FinType (EqType bool)) pr h').
  Notation hfinal := (@hfinal (FinType (EqType bool)) pr h').
  Notation hsteps := (@hsteps pr).

  Definition hBinaryCC := @BinaryCC.Build_BinaryCC hoffset hwidth hinit hcards hfinal hsteps.

  Lemma h_multiplier_sp x : |h x| = (|elem Sigma|) * |x|.
  Proof.
    unfold h. erewrite h_multiplier. 2: apply hP_length. easy.
  Qed.

  Lemma CC_homomorphism_wf : CC_wellformed pr -> BinaryCC.BinaryCC_wellformed hBinaryCC.
  Proof.
    intros (H1 & H2 & H3 & H4 & H5 & H6).
    unfold BinaryCC_wellformed; repeat match goal with [ |- _ /\ _] => split end; cbn.
    + unfold hwidth. nia.
    + unfold hoffset. nia.
    + unfold hwidth, hoffset. destruct H3 as (k' & H3 & H3'). exists k'. split; nia.
    + unfold hinit, hwidth. rewrite h_multiplier_sp. nia.
    + unfold hwidth. intros [] H. unfold hcards in H. apply in_map_iff in H as (card' & <- & H).
      destruct card'. apply H5 in H. destruct H as (H & H0); cbn in *.
      split; cbn; now rewrite h_multiplier_sp.
    + destruct H6 as (k' & H6). unfold hinit, hoffset. exists k'.
      rewrite h_multiplier_sp, H6. nia.
  Qed.

  (** we now get the reduction for the case that the instance we reduce from is wellformed *)
  Lemma reduction_wf : CCLang pr <-> BinaryCCLang hBinaryCC.
  Proof.
    split; intros.
    - destruct H as (_ & sf & H1 & H2).
      split; [ apply CC_homomorphism_wf; auto | ].
      apply CC_homomorphism_iff; eauto; [ apply hP_length | apply hP_injective].
    - destruct H as (_ & H1).
      split; [ apply A | ].
      apply (CC_homomorphism_iff hP_length A1 hP_injective) in H1; [apply H1 | apply A].
  Qed.
End fixInstance.

(** for non-wellformed instances, we map to a trivial no-instance *)
Definition trivialNoInstance := Build_BinaryCC 0 0 [] [] [] 0.
Lemma trivialNoInstance_isNoInstance : not (BinaryCCLang trivialNoInstance).
Proof.
  intros (H & _). destruct H as (H & _). cbn in H. lia.
Qed.

Definition reduction (pr : CC) := if CC_wf_dec pr then hBinaryCC pr else trivialNoInstance.

Lemma CC_to_BinaryCC (pr : CC) : CCLang pr <-> BinaryCCLang (reduction pr).
Proof.
  unfold reduction.
  destruct (CC_wf_dec pr) eqn:H1.
  - apply CC_wf_dec_correct in H1. remember H1 as H0. clear HeqH0. destruct H1 as (H1 & _ & _ & H2 & _).
    destruct init; cbn in H2; [ lia | ].
    assert (|elem (Sigma pr)| > 0).
    { specialize (@elem_spec _ e). destruct elem; cbn; [eauto | lia]. }
    apply reduction_wf; easy.
  - assert (not (CC_wf_dec pr = true)) as H by eauto. rewrite CC_wf_dec_correct in H.
    split; intros.
    + destruct H0; tauto.
    + exfalso; apply trivialNoInstance_isNoInstance, H0.
Qed.


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

Set Implicit Arguments.

Require Import ZArith Znumtheory Zpow_facts.
Require Import CyclicAxioms Cyclic63 Int63Compat.
From Bignums Require Import DoubleCyclic BigN.
Require Import ZCAux.
Require Import W.
Require Import Mod_op.
Require Import LucasLehmer.
Require Import Bits.
Import CyclicAxioms DoubleType DoubleBase.

Open Scope Z_scope.

Section test.

Variable w: univ_of_cycles.
Variable w_op: ZnZ.Ops w.
Variable op_spec: ZnZ.Specs w_op.
Variable p: positive.
Variable b: w.

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

Hypothesis p_more_1: 2 < Zpos p.
Hypothesis b_p: [|b|] = 2 ^ Zpos p - 1.

Lemma b_pos: 0 < [|b|].
rewrite b_p.
assert (2 ^ 0 < 2 ^ Zpos p).
apply Zpower_lt_monotone; auto with zarith.
rewrite Zpower_0_r in H; auto with zarith.
Qed.

Hint Resolve b_pos : core.

Variable m_op: mod_op w.
Variable m_op_spec: mod_spec w_op b m_op.

Let w2 := m_op.(add_mod) ZnZ.one ZnZ.one.

Lemma w1_b: [|ZnZ.one|] = 1 mod [|b|].
rewrite ZnZ.spec_1; simpl; auto.
rewrite Zmod_small; auto with zarith.
split; auto with zarith.
rewrite b_p.
assert (H : 2 ^ 1 < 2 ^ Zpos p)
by (apply Zpower_lt_monotone; auto with zarith).
rewrite Zpower_1_r in H; auto with zarith.
Qed.

Lemma w2_b: [|w2|] = 2 mod [|b|].
unfold w2; rewrite (add_mod_spec m_op_spec _ _ _ _ w1_b w1_b).
rewrite w1_b; rewrite <- Zplus_mod; auto with zarith.
Qed.

Let w4 := m_op.(add_mod) w2 w2.

Lemma w4_b: [|w4|] = 4 mod [|b|].
unfold w4; rewrite (add_mod_spec m_op_spec _ _ _ _ w2_b w2_b).
rewrite w2_b; rewrite <- Zplus_mod; auto with zarith.
Qed.

Let square_m2 :=
   let square := m_op.(square_mod) in
   let sub := m_op.(sub_mod) in
   fun x => sub (square x) w2.

Definition lucastest_step x p := iter_pos _ square_m2 x p.

Lemma square_m2_bounded x : 0 <= [|x|] < [|b|] -> 0 <= [|square_m2 x|] < [|b|].
Proof.
intro H.
unfold square_m2.
rewrite (sub_mod_spec m_op_spec _ _  [|square_mod m_op x|] 2).
apply Z.mod_pos_bound; auto with zarith.
rewrite Z.mod_small; auto with zarith.
rewrite (square_mod_spec m_op_spec x [|x|]); auto.
apply Z.mod_pos_bound; auto with zarith.
rewrite Z.mod_small; auto with zarith.
exact w2_b.
Qed.

Lemma lucastest_bounded x p1 : 0 <= [|x|] < [|b|] ->
  0 <= [|lucastest_step x p1|] < [|b|].
Proof.
unfold lucastest_step.
revert p1 x.
intros p1; pattern p1; apply Pind; simpl iter_pos; simpl s; clear p1.
exact square_m2_bounded.
intros p1 IH x Hx.
rewrite Pos.iter_succ.
apply square_m2_bounded.
apply IH; auto.
Qed.

Lemma square_m2_eq x1 x2 :
 [|x1|] < [|b|] ->
[|x1|] = [|x2|] -> [|square_m2 x1|] = [|square_m2 x2|].
Proof.
intros Hx1 Ex1.
assert (H1 : [|x1|] = [|x1|] mod [|b|]).
rewrite Z.mod_small; auto with zarith.
case (ZnZ.spec_to_Z x1); auto with zarith.
assert (H2 : [|x2|] = [|x2|] mod [|b|]).
rewrite <- Ex1; auto.
unfold square_m2.
rewrite (sub_mod_spec m_op_spec _ _  [|square_mod m_op x1|] 2).
rewrite (sub_mod_spec m_op_spec _ _  [|square_mod m_op x2|] 2).
rewrite (square_mod_spec m_op_spec x1 [|x1|]); auto.
rewrite (square_mod_spec m_op_spec x2 [|x2|]); auto.
rewrite Ex1; auto.
rewrite Z.mod_small; auto with zarith.
rewrite (square_mod_spec m_op_spec x2 [|x2|]); auto.
apply Z.mod_bound_pos; auto with zarith.
apply Z.square_nonneg.
exact w2_b.
rewrite Z.mod_small; auto with zarith.
rewrite (square_mod_spec m_op_spec x1 [|x1|]); auto.
apply Z.mod_bound_pos; auto with zarith.
apply Z.square_nonneg.
exact w2_b.
Qed.

Lemma lucastest_eq x1 x2 p1 : [|x1|] < [|b|] ->
  [|x1|] = [|x2|] -> [|lucastest_step x1 p1|] =  [|lucastest_step x2 p1|].
Proof.
unfold lucastest_step.
revert p1 x1 x2.
intros p1; pattern p1; apply Pind; simpl iter_pos; simpl s; clear p1.
exact square_m2_eq.
intros p1 IH x1 x2 Hx1 Hx2.
rewrite !Pos.iter_succ.
apply square_m2_eq.
assert (F : 0 <= [|x1|] < [|b|]).
case (ZnZ.spec_to_Z x1); auto with zarith.
generalize (lucastest_bounded _ p1 F).
unfold lucastest_step; auto with zarith.
apply IH; auto.
Qed.

Theorem lucastest_step_add :
 forall p1 p2 z z1 z2, lucastest_step z p1 = z1 ->
        lucastest_step z1 p2 = z2 -> lucastest_step z (p2 + p1) = z2.
Proof.
unfold lucastest_step.
intros p1 p2 z z1 z2 H1 H2.
rewrite Pos.iter_add, H1; auto.
Qed.

Theorem lucastest_step_correct:
 forall p1 z n, 0 <= n -> [|z|] = fst (s n) mod (2 ^ Zpos p - 1) ->
       [|lucastest_step z p1|] = fst (s (n + Zpos p1)) mod (2 ^ Zpos p - 1).
unfold lucastest_step.
intros p1; pattern p1; apply Pind; simpl iter_pos; simpl s; clear p1.
intros z p1 Hp1 H.
unfold square_m2.
rewrite <- b_p in H.
generalize (square_mod_spec m_op_spec _ _ H); intros H1.
rewrite (sub_mod_spec m_op_spec _ _ _ _ H1 w2_b).
rewrite H1; rewrite w2_b.
rewrite H; rewrite <- Zmult_mod.
rewrite <- Zminus_mod.
rewrite sn by assumption; simpl.
rewrite b_p; auto.
intros p1 Rec w1 z Hz Hw1.
rewrite Pplus_one_succ_l; rewrite iter_pos_plus;
 simpl iter_pos.
match goal with |- context[square_m2 ?X] =>
  set (tmp := X); unfold square_m2; unfold tmp; clear tmp
end.
generalize (Rec _ _ Hz Hw1); intros H1.
rewrite <- b_p in H1.
generalize (square_mod_spec m_op_spec _ _ H1); intros H2.
rewrite (sub_mod_spec m_op_spec _ _ _ _ H2 w2_b).
rewrite H2; rewrite w2_b.
rewrite H1; rewrite <- Zmult_mod.
rewrite <- Zminus_mod.
replace (z + Zpos (1 + p1)) with ((z + Zpos p1) + 1).
rewrite sn; simpl fst; try rewrite b_p; auto with zarith.
rewrite Zpos_plus_distr; auto with zarith.
Qed.

Definition lucastest := [|lucastest_step w4 (Pminus p 2)|].

Theorem lucastest_prop: lucastest = fst(s (Zpos p -2)) mod (2 ^ Zpos p - 1).
unfold lucastest.
assert (F: 0 <= 0); auto with zarith.
generalize (lucastest_step_correct (p -2) w4 F); simpl Zplus;
   rewrite Zpos_minus; auto with zarith.
rewrite Zmax_right; auto with zarith.
intros tmp; apply tmp; clear tmp.
rewrite <- b_p; simpl; exact w4_b.
Qed.

Theorem lucastest_prop_cor: lucastest = 0 -> (2 ^ Zpos p - 1 | fst(s (Zpos p - 2)))%Z.
intros H.
apply Zmod_divide.
assert (H1: 2 ^ 1 < 2 ^ Zpos p).
apply Zpower_lt_monotone; auto with zarith.
rewrite Zpower_1_r in H1; auto with zarith.
apply trans_equal with (2:= H); apply sym_equal; apply lucastest_prop; auto.
Qed.

Theorem lucastest_prime:  lucastest = 0 -> prime (2 ^ Zpos p - 1).
intros H1; case (prime_dec (2 ^ Zpos p - 1)); auto; intros H2.
case Zdivide_div_prime_le_square with (2 := H2).
assert (H3: 2 ^ 1 < 2 ^ Zpos p).
apply Zpower_lt_monotone; auto with zarith.
rewrite Zpower_1_r in H3; auto with zarith.
intros q (H3, (H4, H5)).
contradict H5; apply Zlt_not_le.
generalize q_more_than_square; unfold Mp; intros tmp; apply tmp;
  auto; clear tmp.
apply lucastest_prop_cor; auto.
case (Zle_lt_or_eq 2 q); auto.
apply prime_ge_2; auto.
intros H5; subst.
absurd (2 <= 1); auto with arith.
apply Zdivide_le; auto with zarith.
case H4; intros x Hx.
exists (2 ^ (Zpos p -1) - x).
rewrite Zmult_minus_distr_r; rewrite <- Hx; unfold Mp.
pattern 2 at 2; rewrite <- Zpower_1_r; rewrite <- Zpower_exp; auto with zarith.
replace (Zpos p - 1 + 1) with (Zpos p); auto with zarith.
Qed.

End test.

Definition znz_of_Z (w: univ_of_cycles) (op: ZnZ.Ops w) z :=
 match z with
 | Zpos p => snd (ZnZ.of_pos p)
 | _ => ZnZ.zero
 end.

Definition lucas p :=
 let op := cmk_op (Peano.pred (nat_of_P (get_height 63 p))) in
 let b := znz_of_Z op (Zpower 2 (Zpos p) - 1) in
 let zp := znz_of_Z op (Zpos p) in
 let mod_op := mmake_mod_op op b zp in
  lucastest op p mod_op.

Section LucasStep.

Let op p  := cmk_op (Peano.pred (nat_of_P (get_height 63 p))).
Let b p := znz_of_Z (op p) (2 ^ (Zpos p) - 1).
Let zp p := znz_of_Z (op p) (Zpos p).
Let mod_op p := mmake_mod_op (op p) (b p) (zp p).

Let lucas_f1 p : (2 < p)%positive -> Zpos p <= Zpos (ZnZ.digits (op p)).
Proof.
intros Hp.
unfold op, base; rewrite cmk_op_digits.
generalize (get_height_correct 63 p).
replace (Z_of_nat (Peano.pred (nat_of_P (get_height 63 p)))) with
       ((Zpos (get_height 63 p) - 1) ). auto with zarith.
rewrite <- Nat.sub_1_r; rewrite inj_minus1.
rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P; auto with zarith.
generalize (lt_O_nat_of_P (get_height 63 p)); auto with zarith.
Qed.

Let lucas_f2 p : (2 < p)%positive -> @ZnZ.to_Z _ (op p) (b p) = 2 ^ (Zpos p) - 1.
Proof.
unfold b; intros Hp.
assert (F1: 0 < 2 ^ (Zpos p) - 1).
assert (F2: 2 ^ 0 < 2 ^ (Zpos p)).
apply Zpower_lt_monotone; auto with zarith.
rewrite Zpower_0_r in F2; auto with zarith.
case_eq (2 ^ (Zpos p) - 1); simpl ZnZ.to_Z.
intros HH; contradict F1; rewrite HH; auto with zarith.
2: intros p1 HH; contradict F1; rewrite HH;
  apply Zle_not_lt; red; simpl; intros; discriminate.
intros p1 Hp1; apply (@ZnZ.of_pos_correct _ (op p)); auto.
apply cmk_spec.
rewrite <- Hp1.
unfold base.
apply Z.lt_le_trans with (2 ^ (Zpos p)); auto with zarith.
apply Zpower_le_monotone; auto with zarith.
Qed.

Let lucas_f3 p :(2 < p)%positive -> mod_spec (op p) (b p) (mod_op p).
Proof.
intro Hp.
assert (F1 : ZnZ.Specs (op p)).
  apply cmk_spec; auto.
apply mmake_mod_spec with (p := p); auto.
rewrite lucas_f2; auto.
assert (F2: 2 ^ 1 < 2 ^ (Zpos p)).
apply Zpower_lt_monotone. auto with zarith.
assert (2 < Z.pos p); auto with zarith.
rewrite Zpower_1_r in F2; auto with zarith.
unfold zp.
apply ZnZ.of_Z_correct.
split. auto with zarith.
apply Z.le_lt_trans with (1 := lucas_f1 Hp).
unfold base; apply Zpower2_lt_lin; auto with zarith.
Qed.

Theorem lucas_prime:
 forall p, 2 < Zpos p -> lucas p = 0 -> prime (2 ^ Zpos p - 1).
intros p Hp H.
assert(A1: ZnZ.Specs (op p)).
apply cmk_spec; auto.
apply (lucastest_prime A1 Hp (lucas_f2 Hp) (lucas_f3 Hp) H).
Qed.

Definition lucas_step p x p1 :=
 let op := cmk_op (Peano.pred (nat_of_P (get_height 63 p))) in
 let b := znz_of_Z op (Zpower 2 (Zpos p) - 1) in
 let zp := znz_of_Z op (Zpos p) in
 let mod_op := mmake_mod_op op b zp in
  ZnZ.to_Z (lucastest_step op mod_op (znz_of_Z op x) p1).

Lemma lucasE p : 2 < Zpos p -> lucas_step p 4 (p - 2) = 0 -> lucas p = 0.
Proof.
intros H.
unfold lucas, lucas_step, lucastest.
set (o := cmk_op _).
set (m := mmake_mod_op _ _ _).
assert (F0 : 1 < ZnZ.to_Z (b p)).
replace (ZnZ.to_Z (b p)) with (2 ^ Z.pos p - 1).
assert (2 ^ 1 <  2 ^ Z.pos p).
apply Zpower_lt_monotone; auto with zarith.
replace (2 ^ 1) with 2 in H0; auto with zarith.
rewrite <-(lucas_f2 H); auto.
assert (F1 : ZnZ.to_Z ZnZ.one = 1).
rewrite w1_b with (p := p) (b := b p); [..|auto| ].
rewrite Z.mod_small; auto with zarith.
apply cmk_spec; auto.
rewrite <-(lucas_f2 H); auto.
assert (F2 : ZnZ.to_Z ZnZ.one = 1 mod ZnZ.to_Z (b p)).
rewrite Z.mod_small; auto with zarith.
intro H1; rewrite <-H1.
assert (F3 : ZnZ.to_Z (add_mod m ZnZ.one ZnZ.one) = 2 mod ZnZ.to_Z (b p)).
rewrite (add_mod_spec (lucas_f3 H) _ _ 1 1); auto.
replace (ZnZ.to_Z ZnZ.one) with 1; auto.
apply lucastest_eq with (p := p) (b := b p); [ |auto|..].
apply cmk_spec; auto.
apply lucas_f2; auto.
apply lucas_f3; auto.
rewrite (add_mod_spec (lucas_f3 H) _ _ 2 2); auto.
match goal with |- ?X < ?Y => enough (0 <= X < Y) by auto with zarith end.
apply Z.mod_pos_bound; auto with zarith.
rewrite (add_mod_spec (lucas_f3 H) _ _ 2 2); auto.
replace ((ZnZ.to_Z (add_mod m ZnZ.one ZnZ.one))) with (2 mod ZnZ.to_Z (b p)).
rewrite <-Z.add_mod.
rewrite Z.mod_small.
simpl.
apply sym_equal.
apply (@ZnZ.of_pos_correct _ o).
apply cmk_spec; auto.
change 4 with (2 ^ 2).
apply Zpower_lt_monotone. auto with zarith.
split. auto with zarith.
assert (F := lucas_f1 H).
unfold op in F; simpl in F; unfold o; auto with zarith.
split. auto with zarith.
change (2 + 2) with (2 ^ 2).
replace (ZnZ.to_Z (b p)) with (2 ^ Z.pos p - 1).
assert (2 ^ 3 <=  2 ^ Z.pos p).
apply Zpower_le_monotone; auto with zarith.
change (2 ^ 3) with 8 in H0.
change (2 ^ 2) with 4; auto with zarith.
rewrite <-(lucas_f2 H); auto.
generalize F0.
set (u := ZnZ.to_Z _).
auto with zarith.
Qed.

Theorem lucas_step_add p p1 p2 z z1 z2 :
   (2 < Zpos p) -> 0 <= z < 2 ^ (Zpos p) - 1 ->
   lucas_step p z p1 = z1 -> lucas_step  p z1 p2 = z2 -> lucas_step p z (p2 + p1) = z2.
Proof.
intros H H0 H1 H2.
assert(A1: ZnZ.Specs (op p)).
apply cmk_spec; auto.
unfold lucas_step.
set (o := cmk_op _).
set (m := mmake_mod_op _ _ _).
assert (F1 : forall z3, 0 <= z3 < ZnZ.to_Z (b p) -> ZnZ.to_Z (znz_of_Z o z3) = z3).
intro z3.
case z3; simpl.
rewrite ZnZ.spec_0; auto.
intros p3 [H3 H4].
apply ZnZ.of_pos_correct.
apply Z.lt_le_trans with (1 := H4).
replace (ZnZ.to_Z (b p)) with (2 ^ Z.pos p - 1).
enough (2 ^ Zpos p <= base (ZnZ.digits o)) by auto with zarith.
apply Zpower_le_monotone. auto with zarith.
assert (F := lucas_f1 H); auto with zarith.
rewrite <-(lucas_f2 H); auto.
intros p3 [[]]; unfold Z.le; simpl; auto.
unfold lucastest_step.
rewrite Pos.iter_add; auto.
change (@ZnZ.to_Z _ o (lucastest_step o m (lucastest_step o m (znz_of_Z o z) p1) p2) = z2).
assert (F :  ZnZ.to_Z (lucastest_step  o m (znz_of_Z o z) p1) =
            ZnZ.to_Z (znz_of_Z o z1)).
unfold lucas_step in H1; fold o in H1; fold m in H1; rewrite H1.
rewrite F1. reflexivity.
rewrite <- H1.
apply (lucastest_bounded A1 H (lucas_f2 H) (lucas_f3 H)).
rewrite F1.
rewrite (lucas_f2 H); auto with zarith.
replace (ZnZ.to_Z (b p)) with (2 ^ Z.pos p - 1). auto with zarith.
rewrite <-(lucas_f2 H); auto with zarith.
rewrite lucastest_eq with (p := p) (b := b p) (6 := F); [auto..| | | ].
apply lucas_f2; auto.
apply lucas_f3; auto.
assert (0 <=  ZnZ.to_Z (lucastest_step o m (znz_of_Z o z) p1) < ZnZ.to_Z (b p)).
apply (lucastest_bounded A1 H (lucas_f2 H) (lucas_f3 H)).
rewrite F1.
replace (ZnZ.to_Z (b p)) with (2 ^ Z.pos p - 1). auto with zarith.
rewrite <-(lucas_f2 H); auto with zarith.
replace (ZnZ.to_Z (b p)) with (2 ^ Z.pos p - 1). auto with zarith.
rewrite <-(lucas_f2 H); auto with zarith.
auto with zarith.
Qed.

Lemma lucas_step_same_p : forall p x p1 p2 z,
   p1 = p2 -> lucas_step p x p1 = z -> lucas_step p x p2 = z.
Proof.
intros p x p1 p2 z Hp Hz.
apply trans_equal with (2 := Hz).
apply f_equal2 with (f := lucas_step p); auto.
Qed.

End LucasStep.

Ltac vmtac :=
match goal with |- _ = ?x =>
vm_cast_no_check  (refl_equal x)
end.

Lemma lucas_Zpos p : 2 < Zpos p -> 0 <= 4 < 2 ^ (Zpos p) - 1.
Proof.
intros H; split; auto with zarith.
assert (8 <= 2 ^Zpos p); auto with zarith.
replace 8 with (2 ^ 3); auto with zarith.
apply Zpow_facts.Zpower_le_monotone; auto with zarith.
Qed.


(* c= *)
Definition Subq : set->set->Prop :=
fun X Y => forall x:set, x :e X -> x :e Y.

Lemma Subq_ref : forall X:set, X c= X.
Qed.

Lemma Subq_tra : forall X Y Z:set, X c= Y -> Y c= Z -> X c= Z.
Qed.

Axiom set_ext : forall X Y:set, X c= Y -> Y c= X -> X == Y.
Theorem set_ext_inv : forall X Y:set, X == Y -> (X c= Y /_\ Y c= X).
(* HW *)
Qed.

Parameter Empty : set.
Axiom EmptyAx : ~' exists x, x :e Empty.

Lemma EmptyE : forall x:set, x /:e Empty.
(* CW *)
Qed.

Parameter Union : set->set.
Axiom UnionEq : forall X:set, forall x:set, x :e Union X <=> exists Y, x :e Y /_\ Y :e X.

Lemma UnionE :
forall X x:set, x :e (Union X) -> exists Y, x :e Y /_\ Y :e X.
(* CW *)
Qed.

Lemma UnionI :
forall X x Y:set, x :e Y -> Y :e X -> x :e (Union X).
(* CW *)
Qed.

Parameter Power : set->set.
Axiom PowerEq : forall X Y:set, Y :e Power X <=> Y c= X.

Lemma PowerE : forall X Y:set, Y :e Power X -> Y c= X.
(* CW *)
Qed.

Lemma PowerI : forall X Y:set, Y c= X -> Y :e (Power X).
(* CW *)
Qed.

Lemma In_Power : forall X:set, X :e Power X.
(* CW *)
Qed.

(* { x :i X | P } *)
Parameter Sep : set -> (set -> Prop) -> set.
Axiom SepEq : forall X:set, forall P:set -> Prop, forall x, x :e {z :i X | P z} <=> x :e X /_\ P x.

Lemma SepI : forall X:set, forall P:set -> Prop, forall x:set,
 x :e X -> P x -> x :e {z :i X|P z}.
(* CW *)
Qed.

Lemma SepE : forall X:set, forall P:set -> Prop, forall x:set,
x :e {z :i X|P z} -> x :e X /_\ P x.
(* CW *)
Qed.

Lemma SepE1 : forall X:set, forall P:set -> Prop, forall x:set,
 x :e {z :i X|P z} -> x :e X.
(* CW *)
Qed.

Lemma SepE2 : forall X:set, forall P:set -> Prop, forall x:set,
 x :e {z :i X|P z} -> P x.
(* CW *)
Qed.

Parameter Repl : set->(set->set)->set.
Axiom ReplEq :
forall X:set, forall F:set->set, forall y:set, y :e {F z|z :i X} <=> exists x, x :e X /_\ y == F x.

(* HW *)
Lemma ReplE :
forall X:set, forall F:set->set, forall y:set, y :e {F z|z :i X} -> exists x, x :e X /_\ y == F x.
Qed.
Lemma ReplI :
forall X:set, forall F:set->set, forall x:set, x :e X -> F x :e {F x|x :i X}.
Qed.

Lemma Subq_Empty : forall X:set, Empty c= X.
(* CW *)
Qed.
Lemma Empty_Power : forall X:set, Empty :e Power X.
(* CW *)
Qed.
Lemma Repl_Empty : forall F:set -> set, {F x|x :i Empty} == Empty.
(* CW *)
Qed.

Parameter Descr : ((set->Prop)->set).
Axiom DescrR : forall P:set->Prop, (exists! x, P x) -> P (Descr P).

(* {x, y} *)
Definition TSet : set := {X :i Power (Power Empty) | Empty :e X \_/ Empty /:e X}.
Definition UPair : set->set->set :=
 fun y z:set =>
 {Descr (fun w:set => forall p:set->Prop, (Empty /:e X -> p y) -> (Empty :e X  -> p z) -> p w)|X :i TSet}.

(* HW *)
Lemma UPairE :
forall x y z:set, x :e {y,z} -> x == y \_/ x == z.
Qed.
Lemma UPairI1 :
forall y z:set, y :e {y,z}.
Qed.
Lemma UPairI2 :
forall y z:set, z :e {y,z}.
Qed.

(* CW *)
Lemma UPairEq :
forall x y z, x :e {y,z} <=> x == y \_/ x == z.
Qed.

(* {| y |} *)
Definition Sing : set->set := fun y:set => {y,y}.

Lemma SingI : forall y, y :e {| y |}.
Qed.
Lemma SingE : forall x y, x :e {| y |} -> x == y.
Qed.
Lemma SingEq : forall x y, x :e {| y |} <=> x == y.
(* CW *)
Qed.

(* :u: *)
Definition binunion : set -> set -> set := fun X Y => Union {X,Y}.
Lemma binunionI1 : forall X Y z, z :e X -> z :e X :u: Y.
(* CW *)
Qed.

Lemma binunionI2 : forall X Y z, z :e Y -> z :e X :u: Y.
(* CW *)
Qed.

Lemma binunionE : forall X Y z, z :e X :u: Y -> z :e X \_/ z :e Y.
(* HW *)
Qed.

Lemma binunionEq : forall X Y z, z :e X :u: Y <=> z :e X \_/ z :e Y.
(* CW *)
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

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

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

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (lf1 : natural) (lf2 : lst) : natural := len (append Nil lf2).


Set Implicit Arguments.
Require Import ZArith MSets.
Require Import mgraphs_ind pair_UOT.

Module g : Graphs PositiveOrderedTypeBits.

  Module mset := MSetAVL.Make PositiveOrderedTypeBits.
  Module NodePair := (PairUsualOrderedType
                        PositiveOrderedTypeBits PositiveOrderedTypeBits).
  Module msetPair := MSetAVL.Make (NodePair).

  Module mset_facts := WFacts (mset).
  Module msetPair_facts := WFacts (msetPair).
  Module mset_prop := WProperties (mset).
  Module msetPair_prop := WProperties (msetPair).

  Definition node := positive.
  Definition nodePair := NodePair.t.
  Definition node_set := mset.t.
  Definition node_setPair := msetPair.t.

  (* Notation "[ ]" := mset.empty. *)

  (* Notation "[ elt0 , .. , eltn ]" := (mset.add elt0 .. (mset.add eltn (mset.empty )) .. ) (at level 60, right associativity). *)

  Inductive graph : Type :=
  | Empty : graph
  | Node :
      node -> (** this node's id *)
      node_set -> (** its neighbors *)
      graph -> (** the rest of the graph *)
      graph.
(*vert to graph_vert*)
    Fixpoint graph_vertices' g : node_set :=
    match g with
      | Empty => mset.empty
      | Node x s g' => mset.add x (graph_vertices' g')
    end.

  Inductive graph_ok : graph -> Prop :=
  | EmptyOk : graph_ok Empty
  | NodeOk : forall (x : node) (adj : node_set) (g : graph),
      graph_ok g ->
      (forall (y : node), mset.In y adj -> mset.In y (graph_vertices' g)) ->
      graph_ok (Node x adj g).
  Definition valid_graph := {g : graph | graph_ok g}.

  Definition proj1 (vg : valid_graph) : graph :=
    let (g, pf) := vg in g.

  Definition project1 T: (graph -> T) -> (valid_graph -> T).
    intros.
    destruct X0.
    apply X.
    auto.
    Defined.

  Definition graph_vertices (vg: valid_graph) := (project1 graph_vertices') vg.

  Definition ok T: forall (vg : valid_graph) (g : graph) (f : graph -> T), f (proj1 vg) = (project1 f) vg.
    intros.
    destruct vg.
    auto.
    Defined.

Print ok.

  (* Fixpoint edges' g : node_setPair := *)
  (*   match g with *)
  (*     | Empty => msetPair.empty *)
  (*     | Node x s g' =>  msetPair.union (mset.fold (fun x' s'=> msetPair.add (x,x') s') s msetPair.empty) (edges' g') *)
  (*   end. *)

(*   Lemma node_ok_graph_ok : forall n adj g, graph_ok (Node n adj g) -> graph_ok g /\   (forall (y : node), mset.In y adj -> mset.In y (graph_vertices g)). *)
(*   Proof. *)
(*     intros. *)
(*     split. *)
(*     inversion H. *)
(*     auto. *)
(*     inversion H. *)
(*     auto. *)
(* Qed.     *)
  Lemma emptyOk : graph_ok Empty.
  Proof.
    constructor.
  Qed.

  Definition t := valid_graph.
  Definition empty : valid_graph.
  assert (graph_ok Empty).
  constructor.
  exists (Empty).
  exact H.
  Defined.

    Fixpoint edges' ( g : graph) : node_setPair :=
      match g with
      | Empty => msetPair.empty
      | Node x s g' => mset.fold (fun x' s' => msetPair.add (x,x') s')
                        s (edges' g')
    end.

  Definition edges (vg : t) : node_setPair := edges' (proj1 vg).

  Definition add_vertex' : graph -> node -> graph :=
    fun t x => Node x mset.empty t.

  Theorem add_vertex_ok : forall v g, graph_ok g -> graph_ok (add_vertex' g v).
  Proof.
    intros.
    induction g.
    constructor.
    auto.
    intros y H1.
    auto.
    unfold add_vertex'.
    constructor; auto.
    intros y H1.
    inversion H1.
Qed.

  Definition add_vertex (vg : valid_graph) (v : node) : valid_graph.
  Proof.
    exists (add_vertex' (proj1 vg) v).
    apply add_vertex_ok.
    destruct vg.
    simpl.
    exact g.
    Defined.

  Definition add_edge': graph -> node * node -> graph :=
    fun g (x : node*node)  =>
      let (x1, x2) := x in
      if (mset.mem x1 (graph_vertices' g) && mset.mem x2 (graph_vertices' g))
      then Node x1 (mset.add x2 mset.empty) g
      else g.

  Theorem add_edge_ok : forall e g, graph_ok g -> graph_ok (add_edge' g e).
  Proof.
    intros e g H.
    destruct e.
    induction g.
    auto.
    simpl.
    destruct (mset.mem n (mset.add n1 (graph_vertices' g)) &&
                        mset.mem n0 (mset.add n1 (graph_vertices' g))) eqn:H1.
    apply andb_true_iff in H1.
    destruct H1.
    constructor.
    auto.
    intros y H2.
    apply mset_prop.singleton_equal_add in H2.
    apply mset_prop.Dec.F.singleton_1 in H2.
    simpl.
    subst.
    apply mset.mem_spec.
    auto.
    auto.
  Qed.

  Definition add_edge : valid_graph ->  node * node -> valid_graph.
    intros.
    exists (add_edge' (proj1 X) H).
    apply add_edge_ok.
    destruct X.
    simpl.
    exact g.
    Defined.

  Fixpoint remove_vertex' (g : graph) (n : node) :=
  match g with
  |Empty => Empty
  |Node n' adj g' => if Pos.eqb n' n then remove_vertex' g' n
      else  Node n' adj (remove_vertex' g' n)
  end.

    Lemma remove_vertex_ok : forall g v, graph_ok g -> graph_ok (remove_vertex' g v).
    Proof.
      induction g.
      constructor.
      simpl.
      intros.
      destruct ((n =? v)%positive) eqn:H1.
      apply IHg.
      inversion H.
      auto.
      constructor.
      inversion H.
      auto.
      intros.
      inversion H.
      subst.
      apply (IHg v) in H4.

    Admitted.

  Definition remove_vertex (vg : t) (v : node) : t.
    exists (remove_vertex' (proj1 vg) v).
    apply remove_vertex_ok.
    destruct vg.
    exact g.
    Defined.

  Fixpoint remove_edge' (g : graph) (e : (node * node) ) :=
    let x := (fst e) in
    let y := (snd e) in
    match g with
    |Empty => Empty
    |Node n adj g' => if Pos.eqb n x  then Node n (mset.remove y adj) (remove_edge' g' e)
                      else Node n adj (remove_edge' g' e)
    end.

  Lemma remove_edge_ok : forall (g : graph) ( e : (node * node)),
      graph_ok g -> graph_ok (remove_edge' g e).
  Proof.
    Admitted.

  Definition remove_edge (vg : t) (e : node * node ) : t.
    exists (remove_edge' (proj1 vg) e).
    apply remove_edge_ok.
    destruct vg.
    exact g.
    Defined.

  Fixpoint neighborhood' (g : graph) (x : node) : node_set:=
    match g with
    | Empty => mset.empty
    | Node y adj g' =>
      if Pos.eqb x y then  mset.union adj (neighborhood' g' x)
      else if mset.mem x adj then mset.add y (neighborhood' g' x)
           else neighborhood' g' x
    end.
  Definition neighborhood := (project1 neighborhood').

  Definition is_vertex' : graph -> node -> bool :=
    fun g x => mset.mem x (graph_vertices' g).
  Definition is_vertex := (project1 is_vertex').
  Definition is_edge' : graph -> node * node -> bool :=
    fun g x => msetPair.mem x (edges' g).

  Definition is_edge := (project1 is_edge').

  Lemma empty_vertices : graph_vertices empty = mset.empty.
  Proof. reflexivity. Qed.
  Lemma empty_edges : edges empty = msetPair.empty.
  Proof. reflexivity. Qed.

  Definition pairset_of_nodes (n : node) (e : node_set) :=
    mset.fold (fun (x : node) l => msetPair.add (n, x) l) e msetPair.empty.

  Lemma folds_equal : forall n n0 s ,
      msetPair.Equal
        ((mset.fold
          (fun (x' : mset.elt) (s' : msetPair.t) =>
             msetPair.add (n, x') s') n0 (s)))
      ((msetPair.union (pairset_of_nodes n n0) (s))).
    Proof.
      intros.
      unfold pairset_of_nodes.
      apply mset_prop.fold_rec_bis.
      {
        intros. rewrite H0.
        apply mset_prop.fold_equal with (s := s0) (s' := s').
        constructor.
        constructor;
        intros; auto.
        constructor.
        unfold msetPair.Equal in H1.
        apply H1.
        unfold msetPair.Equal in H1.
        apply H1.
        constructor.
        unfold msetPair.Equal in H1,H2.
        intros.
        apply H1 in H3.
        apply H2 in H3.
        auto.
        unfold msetPair.Equal in H1,H2.
        intros.
        apply H2 in H3.
        apply H1 in H3.
        auto.
        (*rewrite  msetPair_prop.Dec.F.union_m.*)
        admit.
        admit.
        apply H.
      }
      {
        rewrite mset_prop.fold_1b.
        rewrite msetPair_prop.empty_union_1.
        reflexivity.
        auto.
        auto.
      }
      {
        intros.
        split. simpl.
        intros. rewrite mset_prop.fold_add.
        rewrite msetPair.union_spec.
    Admitted.

    (*   Open Scope positive_scope.*)
  (*  Example ex1 : graph := *)
  (* Node 1 ([2,  3]) *)
  (*      (Node 2 ([3]) *)
  (*            (Node 3 [] Empty)). *)

  (*  Compute (msetPair.elements (edges ex1)). *)
  (*  Compute (msetPair.elements (edges' ex1)). *)

  Lemma add_vertices :
    forall (x : node) (g : t), mset.In x (graph_vertices (add_vertex g x)).
  Proof.
    intros.
    induction g; simpl; apply mset.add_spec;
    left; reflexivity.
  Qed.

  Lemma add_edges_aux :
    forall n n0 n1 g,  n = n1 /\ mset.In n0 (graph_vertices' g) \/ n1 = n0 /\ mset.In n (graph_vertices' g) ->
       mset.mem n (mset.add n1 (graph_vertices' g)) &&                              mset.mem n0 (mset.add n1 (graph_vertices' g)) = true.
    Proof.
      intros.
      subst.
      apply andb_true_iff.
      destruct H;
      destruct H;
      split;
      rewrite mset.mem_spec;
      rewrite mset.add_spec;
      auto.
      Qed.

  Lemma add_edges :
    forall (e : node * node) (g : t),
      mset.In (fst e) (graph_vertices g) ->
      mset.In (snd e) (graph_vertices g) ->
      msetPair.In e (edges (add_edge g e)).
  Proof.
    intros. destruct e.
    destruct g as [g  pf].
    unfold edges; unfold add_edge;
    induction g; simpl.
    simpl in H, H0.
    inversion H.
    simpl in H, H0.
    apply mset.add_spec in H.
    apply mset.add_spec in H0.
    destruct H, H0.
    {
      assert ( mset.mem n (mset.add n1 (graph_vertices' g)) = true).
      rewrite mset.mem_spec.
      apply mset_prop.Dec.F.add_iff.
      auto. subst.
      rewrite H1.
      simpl ( _ && _).
      cbv iota.
      apply msetPair.add_spec.
      auto.
    }

      rewrite add_edges_aux; auto.
      generalize (Node n1 n2 g);
      intro g0;
      simpl;
      apply msetPair.add_spec;
      auto.
    {
      rewrite add_edges_aux; auto.
      generalize (Node n1 n2 g).
      intro g0;
      simpl;
      apply msetPair.add_spec;
      auto.
    }
    {
      assert ( mset.mem n (mset.add n1 (graph_vertices' g)) = true).
      rewrite mset.mem_spec.
      apply mset_prop.Dec.F.add_iff.
      auto.
      rewrite H1.
      assert (mset.mem n0 (mset.add n1 (graph_vertices' g)) = true).
      rewrite mset.mem_spec.
      apply mset_prop.Dec.F.add_iff.
      auto.
      rewrite H2.
      simpl ( _ && _); cbv iota.
      generalize (Node n1 n2 g).
      intro g0.
      simpl.
      apply msetPair.add_spec.
      auto.
    }
  Qed.

    Lemma add_vertices_other :
      forall (x y : node) (g : t),
        x <> y -> mset.In y (graph_vertices g) <-> mset.In y (graph_vertices (add_vertex g x)).
    Proof.
      split; intros; induction g.
      inversion H0.
      {
       unfold add_vertex.
       simpl. apply mset.add_spec.
       auto.
      }
      {
       simpl in H0.
       inversion H0.
       subst.
       simpl.
       apply mset.add_spec.
       auto.
       simpl.
       apply mset.add_spec.
       auto.
       simpl.
       apply mset.add_spec.
       auto.
      }
       simpl. apply mset.add_spec.
       unfold add_vertex in H0.
       simpl in H0. auto.
       simpl.
       simpl in H0.
       apply mset.add_spec in H0.
       destruct H0.
       symmetry in H0.
       contradiction.
       auto.
    Qed.

    Lemma add_edges_other :
      forall (e1 e2 : node * node) (g : t),
        e1 <> e2 -> msetPair.In e2 (edges g) <-> msetPair.In e2 (edges (add_edge g e1)).
    Proof.
      intros; split.  destruct g as [g pf]. induction g; unfold edges in *; unfold add_edge in *; simpl.
      {
        inversion 1.
      }
      {
        intros. unfold add_edge.
        simpl.  destruct e1.
        case_eq (mset.mem n1 (mset.add n (graph_vertices' g)));
          case_eq ( mset.mem n2 (mset.add n (graph_vertices' g)));
       simpl;
        intros;
        rewrite H1, H2;
        simpl (_ && _); cbv iota;
        simpl; auto;
        apply msetPair.add_spec; auto.
      }
      {
        simpl.
        unfold edges, add_edge.
        simpl.
        intros.
        unfold add_edge' in H0.
        apply msetPair_prop.Dec.F.add_3 with (x := e1).
        auto. rewrite msetPair.add_spec.
        right.
        destruct e1, e2.
        destruct g as [g pf].
        simpl in *.
        destruct (mset.mem n (graph_vertices' g) && mset.mem n0 (graph_vertices' g)) eqn:H1.
        apply folds_equal in H0.
        apply msetPair.union_spec in H0.
        fold edges' in H0.
        destruct H0.
        unfold pairset_of_nodes in H0.
        rewrite mset.fold_spec in H0.
        simpl in H0.
        Focus 2.
        auto.
        Focus 2.
        auto.
        apply msetPair.add_spec in H0.
        destruct H0.
        symmetry in H0.
        apply H in H0.
        destruct H0.
        inversion H0.
        }
    Qed.

    Lemma add_vertices_pres_edges :
      forall (x : node) (g : t), msetPair.Equal (edges (add_vertex g x)) (edges g).
    Proof.
      intros.
      reflexivity.
    Qed.

    Lemma add_edges_pres_vertices :
      forall (x : node * node) (g : t),
        mset.Equal (graph_vertices (add_edge g x)) (graph_vertices g).
    Proof.
      intros.
      destruct g as [g pf].
      unfold add_edge. destruct x.
      simpl.
      case_eq (mset.mem n (graph_vertices' g));
      case_eq ( mset.mem n0 (graph_vertices' g)); try (reflexivity).
      {
        intros H1 H2; simpl.
        apply mset.mem_spec in H2.
        apply mset_prop.add_equal.
        auto.
      }
    Qed.

    Lemma remove_vertices :
      forall (x : node) (g : t), ~ mset.In x (graph_vertices (remove_vertex g x)).
    Proof.
      intros.
      unfold graph_vertices, remove_vertex.
      destruct g as [ g pf].
      induction g.
      simpl.
      inversion 1.
      unfold not in *.
      intros.
      simpl in H.
      case_eq ((n =? x)%positive).
      intros.
      rewrite H0 in H.
      simpl in IHg.
      apply Peqb_true_eq in H0.
      inversion pf. subst.
      auto.
      intros.
      rewrite H0 in H.
      simpl in H.
      rewrite mset.add_spec in H.
      destruct H.
      apply Pos.eqb_neq in H0.
      unfold not in H0.
      auto.
      simpl in *.
      inversion pf. subst.
      auto.
    Qed.

    Lemma remove_edges :
      forall (e : node * node) (g : t), ~ msetPair.In e (edges (remove_edge g e)).
    Proof.
      intros.
      destruct e.
      unfold not, remove_edge. intros. destruct g as [g pf].
      induction g.
      inversion H.
      simpl in *.
      inversion pf. subst.
      apply IHg with (pf := H2).
      case_eq ((n1 =? n)%positive).
      intros.
      apply Peqb_true_eq in H0.
      subst.
      assert ((n =? n)%positive = true).
      apply Pos.eqb_refl.
      unfold edges in *.
      simpl in *.

      Focus 2.
      intros.
      apply Pos.eqb_neq in H0.
      apply Pos.eqb_neq in H0.
    Admitted.

    Lemma remove_vertices_edges_l :
        forall (x1 : node) (g : t) (x2 : node),
          ~ msetPair.In (x1, x2) (edges (remove_vertex g x1)).
    Proof.
      intros. unfold edges, remove_vertex. unfold not. intros.
      destruct g as [ g pf].
      simpl in H.
      induction g.
      inversion H.
      apply IHg.
      inversion pf.
      auto.
      simpl in H.
      case_eq ((n =? x1)%positive);
      intros.
      rewrite H0 in H.
      auto.
      rewrite H0 in H.
      simpl in H.
      rewrite folds_equal in H.
      rewrite msetPair.union_spec in H.
      destruct H.
      Focus 2.
      auto.
      unfold pairset_of_nodes in H.
    Admitted.

    Lemma remove_vertices_edges_r :
        forall (x1 : node) (g : t) (x2 : node),
          ~ msetPair.In (x2, x1) (edges (remove_vertex g x1)).
    Proof.
      unfold not.
      intros.
      induction g.
      inversion H.
      simpl in H.

    Admitted.

    Lemma remove_vertices_other :
        forall (x y : node) (g : t),
          x <> y ->  mset.In y (graph_vertices g) <-> mset.In y (graph_vertices (remove_vertex g x)).
    Proof.
      intros.
      destruct g as [g pf].
      unfold graph_vertices, remove_vertex.
      simpl.
      split. intros.
      induction g.
      auto. simpl.
      simpl in H0.
      rewrite mset.add_spec in H0.
      destruct H0.
      {
        destruct ((n =? x)%positive) eqn:H1.
        apply Peqb_true_eq in H1.
        rewrite H1 in H0.
        unfold not in H.
        symmetry in H0.
        apply H in H0.
        destruct H0.
        simpl.
        apply mset.add_spec.
        auto.
      }
      {
        apply IHg in H0.
        destruct ((n =? x)%positive) eqn:H1.
        auto.
        simpl.
        apply mset.add_spec.
        auto.
        inversion pf.
        auto.
      }
      induction g.
      intro H0.
      inversion H0.
      intro H0.
      unfold remove_vertex in H0.
      simpl in *.
      case_eq ((n =? x)%positive); intros H1.
      rewrite H1 in H0.
      apply mset.add_spec.
      right.
      inversion pf. subst.
      apply IHg; auto.
      rewrite H1 in H0.
      simpl in *.
      rewrite mset.add_spec.
      rewrite mset.add_spec in H0.
      destruct H0.
      auto.
      right.
      inversion pf.
      apply IHg; auto.
    Qed.

Lemma remove_edges_other :
      forall (e1 e2 : node * node) (g : t),
        e1 <> e2 -> msetPair.In e2 (edges g) <-> msetPair.In e2 (edges (remove_edge g e1)).
    Proof.
      intros. destruct e1,e2.
      unfold edges, remove_edge.
      destruct g as [g pf].
      simpl.
      induction g.
      {
        split.
        auto.
        auto.
      }
      {
        split.
        intro H1.
        simpl.
        destruct ((n3 =? n)%positive).
        Focus 2.
        unfold edges' in *.
        fold edges' in *.
        apply folds_equal.
        apply msetPair.union_spec.
        apply folds_equal in H1.
        apply msetPair.union_spec in H1.
        destruct H1.
        auto.
        apply IHg in H0.
        auto.
        inversion pf.
        auto.
        unfold edges' in *.
        fold edges' in *.
        apply folds_equal in H1.
        apply folds_equal.
        apply msetPair.union_spec.
        apply msetPair.union_spec in H1.
        destruct H1.
        unfold pairset_of_nodes.
        unfold edges' in *.
        fold edges' in *.
      Admitted.

      Lemma is_vertex_vertices :
        forall (x : node) (g : t), mset.In x (graph_vertices g) <-> is_vertex g x = true.
      Proof.
        destruct g as [g pf].
        intros;
        split; apply mset.mem_spec.
      Qed.

      Lemma is_edge_edges :
        forall (e : node * node ) (g : t), msetPair.In e (edges g) <-> is_edge g e = true.
      Proof.
        intros. destruct g as [g pf].
        split; apply msetPair.mem_spec.
      Qed.

      Lemma neighborhood_prop :
        forall (x : node) (y : node) (g : t),
          mset.In y (neighborhood g x) <-> msetPair.In (x, y) (edges g).
      Proof.
        intros.
        unfold neighborhood, edges.
        destruct g as  [g pf].
        simpl.
        split.
        intros.
        induction g.
        inversion H.
        unfold edges'.
        fold edges'.
        rewrite folds_equal.
        rewrite msetPair.union_spec.
        right.
        apply IHg.
        inversion pf.
        auto.
        simpl in H.
      Admitted.

      Lemma node_edges_weaken : forall (g : graph) (n x y : node) n0  (e :=(x, y) : node * node), graph_ok g ->
      msetPair.In (x,y) (edges' (Node n n0 g)) ->
      x = n /\ mset.In y n0 \/ msetPair.In e (edges' g).
    Proof.
      intros. destruct e.
      induction g.
      simpl in *.
      left.
      rewrite folds_equal in H0.
      rewrite msetPair.union_spec in H0.
      Admitted.

      Lemma edges_proper_l :
        forall (e : node * node) (g : t), msetPair.In e (edges g) -> mset.In (fst e) (graph_vertices g).
      Proof.
        intros.
        destruct g as [g pf].
        induction g.
        inversion H.
        destruct e.
        apply node_edges_weaken in H.
        destruct H.
        simpl.
        apply mset.add_spec.
        destruct H.
        auto.
        inversion pf.
        apply IHg with (pf := H2) in H.
        simpl.
        apply mset.add_spec.
        auto.
        inversion pf. auto.
Qed.
      Lemma edges_proper_r :
        forall (e : node * node ) (g : t), msetPair.In e (edges g) -> mset.In (snd e) (graph_vertices g).
      Proof.
        intros.
        unfold edges in *.
        unfold graph_vertices in *.
        destruct g as [g pf].
        simpl in *.
        induction g.
        intros.
        inversion H.
        simpl.
        destruct e.
        rewrite mset.add_spec.
        simpl in IHg.
        simpl.
        inversion pf.
        subst.
        apply node_edges_weaken in H.
        right.
        destruct H; auto.
        apply H4.
        destruct H; auto.
        auto.
      Qed.
      Open Scope positive_scope.

Example a : (graph_vertices (add_vertex empty 1)) = mset.add 1 mset.empty.
auto.
Qed.

End g.
Print Graphs.
Open Scope positive_scope.
Definition add_vertex := g.add_vertex.
Definition empty := g.empty.
Definition edges := g.edges.
Definition vertices := g.graph_vertices.

Example a : (vertices (add_vertex empty 1)) = g.mset.add 1 g.mset.empty.
Proof.
  unfold vertices. unfold add_vertex.
  Admitted.

Module graph_prop := graph_properties  PositiveOrderedTypeBits g.
Print graph_prop.
Print g.


Inductive list (a : Type) : Type :=
| empty
| cons (x : a) (l : list a).

Arguments empty {a}.
Arguments cons {a}.

Compute (cons 2 (cons 42 empty)).

Definition l1 : list nat := cons 1 (cons 2 (cons 3 (cons 4 empty))).
Definition l2 : list nat := cons 1
                             (cons 2
                                (cons 3
                                   (cons 3
                                      (cons 4
                                         (cons 1
                                            (cons 5 empty)))))).

(* l3 := [1,2,3]
 * f : nat -> nat       foo<a><b>
 * f x := x + 3
 * map f l3 = [f 1, f 2, f 3]
 *          = [1 + 3, 2 + 3, 3 + 3] *)
Fixpoint map {a b : Type} (f : a -> b) (l : list a) : list b :=
  match l with
  | empty => empty
  | cons x l' => cons (f x) (map f l')
  end.

Import Nat.

Compute map (add 3) l1.

(*
 * lfold (reduce) : Left folds a list to a value.
 *                  Accumilator pattern
 *
 * l4 = [5,6,7,8]
 * f auc x =
 *
 * *)
Fixpoint append {a : Type} (l1 l2 : list a) : list a :=
  match l1 with
  | empty => l2
  | cons n l' => cons n (append l' l2)
  end.

Definition id {a : Type} (x : a) : a := x.
Definition comp {a b c : Type} (f : a -> b) (g : b -> c) : a -> c :=
  fun (x : a) => g (f x).

Compute (id comp).
Compute (id list).

(* Not tail recursive  *)
Fixpoint slow_reverse (l : list nat) : list nat :=
  match l with
  | empty _ => empty
  | cons _ n l' => append (slow_reverse l') (cons n empty)
  end.

(* Accumulator Pattern : use "state"
 *
 * Add an extra argument to reverse that holds onto the reversed list.
 *   - The type of the accumilator must be the same type as the output type.
 *
 * *)

Fixpoint reverse' (acc : list nat) (l : list nat) : list nat :=
  match l with
  | empty _ => acc
  | cons _ n l' => reverse' (cons n acc) l'
  end.

Compute (reverse' empty l1).

Definition reverse (l : list nat) : list nat :=
  reverse' empty l.

Lemma append_empty_left : forall l, append empty l = l.
Proof.
  intros l.
  simpl.  reflexivity.
Qed.

Lemma append_empty_right : forall l, append l empty = l.
Proof.
  intro l.
  induction l as [_ | x l' IH].
  - simpl. reflexivity.
  - simpl. rewrite -> IH. reflexivity.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

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

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

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (n : natural) (x : lst) : natural := Succ (double (len x)).


(****************************************************************)
(*  On monadic parametricity of second-order functionals        *)
(*  by Bauer A., Hofmann M., Karbyshev A.                       *)
(*                                                              *)
(*  Aleksandr Karbyshev                                         *)
(*  May 2012                                                    *)
(*  Build with Coq 8.4 + Ssreflect 1.4                          *)
(****************************************************************)

(* typedparam.v
   Parametricity theorem
*)

Require Import ssreflect seq.
Require Import relations.
Require Import typeddensem.
Require Import Coq.Program.Equality.

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

Section TypesRSem.

Variables T T' : monadType.
Variable TRacc : TRaccType T T'.

Parameter RSem_Base : forall (o : baseType), Rel (semBase o T) (semBase o T').

Fixpoint TRSemTy (ty : Ty) : Rel (SemTy T ty) (SemTy T' ty) :=
  match ty with
    | Base o => @RSem_Base o
    | ty1 --> ty2 =>
      (@TRSemTy ty1) =R=> (TR TRacc (@TRSemTy ty2))
    | ty1 ** ty2 => (@TRSemTy ty1) *R* (@TRSemTy ty2)
  end.

End TypesRSem.

Implicit Arguments TRSemTy [T T'].

Lemma parametricity
        T T' (TRacc : TRaccType T T') env
        (eta : SemEnv T env) (eta' : SemEnv T' env) :
    (forall ty (c : Const ty),
      TRSemTy TRacc _ (SemConst T c) (SemConst T' c)) ->
    (forall (ty : Ty) (v : Var env ty),
      TRSemTy TRacc _ (SemVar v eta) (SemVar v eta')) ->
    forall ty (e : Exp env ty),
    TR TRacc (TRSemTy TRacc ty) (SemExp e eta) (SemExp e eta').
Proof.
move => Hconst Hvar ty e.
induction e.

(* TCONST *)
- by apply: (proj1 (Acc TRacc)).

(* TVAR *)
- by apply: (proj1 (Acc TRacc)).

(* TABS *)
- move => /=.
  apply: (proj1 (Acc TRacc)).
  move => x x' Hxx'.
  apply: IHe => // ty v.
  by dependent destruction v => //=.

(* TAPP *)
- move => /=.
  apply: (proj2 (Acc TRacc)); first by auto.
  move => f f' Hff'.
  by apply: (proj2 (Acc TRacc)); auto.

(* TPROD *)
- move => /=.
  apply: (proj2 (Acc TRacc)); first by auto.
  move => x x' Hxx' /=.
  apply: (proj2 (Acc TRacc)); first by auto.
  move => y y' Hyy' /=.
  by apply: (proj1 (Acc TRacc)).

(* TFST *)
- move => /=.
  apply: (proj2 (Acc TRacc)); first by auto.
  move => x x' Hxx' /=.
  apply: (proj1 (Acc TRacc)).
  by apply: (proj1 (ProdR_elim Hxx')).

(* TSND *)
- move => /=.
  apply: (proj2 (Acc TRacc)); first by auto.
  move => x x' Hxx' /=.
  apply: (proj1 (Acc TRacc)).
  by apply: (proj2 (ProdR_elim Hxx')).

(* TLET *)
- move => /=.
  apply: (proj2 (Acc TRacc)); first by auto.
  move => x x' Hxx' /=.
  apply: IHe2 => // ty v.
  by dependent destruction v => //=.
Qed.

Corollary ParametricityTheorem
            T T' (TRacc : TRaccType T T')
            (eta : SemEnv T [::]) (eta' : SemEnv T' [::]) :
    (forall ty (c : Const ty),
      TRSemTy TRacc _ (SemConst T c) (SemConst T' c)) ->
    forall ty (e : CExp ty),
    TR TRacc (TRSemTy TRacc ty) (SemExp e eta) (SemExp e eta').
Proof.
move => Hconst ty e.
apply: parametricity => //=.
move => {ty e Hconst} ty v.
by dependent destruction v.
Qed.