Require Import Le.
Require Import List.

Require Import Logic.Class.Eq.

Require Import Logic.Nat.Max.
Require Import Logic.Nat.Leq.

Require Import Logic.List.In.
Require Import Logic.List.Include.

Require Import Logic.Fol.Eq.
Require Import Logic.Fol.Order.
Require Import Logic.Fol.Bound.
Require Import Logic.Fol.Syntax.
Require Import Logic.Fol.Functor.
Require Import Logic.Fol.Variable.

Declare Scope Fol_Subformula_scope.

(* Defines the 'list' of sub-formulas of a given formula. We do not have        *)
(* sets here, so using lists instead, being understood that the order is        *)
(* irrelevant as are duplicate entries. Hopefully results which are true        *)
(* for sets can be extended for lists as is.                                    *)

Fixpoint Sub (v:Type) (p:P v) : list (P v) :=
    match p with
    | Bot       => cons Bot nil
    | Elem x y  => cons (Elem x y) nil
    | Imp p1 p2 => cons (Imp p1 p2) (Sub v p1 ++ Sub v p2)
    | All x p1  => cons (All x p1)  (Sub v p1)
    end.

Arguments Sub {v} _.

(* p is a sub-formula of q if it belongs to the list of sub-formulas of q       *)
Notation "p <<= q" := (p :: Sub q)
    (at level 50, no associativity) : Fol_Subformula_scope.

Open Scope Fol_Subformula_scope.

Lemma Sub_refl : forall (v:Type) (p:P v), p <<= p.
Proof.
    intros v.
    induction p as [|x y|p1 IH1 p2 IH2|x p1 IH1]; simpl; left; reflexivity.
Qed.

(* This lemma will allow us to get transitivity                                 *)
Lemma Sub_incl : forall (v:Type) (p1 p2:P v),
    Sub p1 <= Sub p2 <-> p1 <<= p2.
Proof.
    intros v p1 p2. split.
    - intros H.  apply H. apply Sub_refl.
    - revert p1. induction p2 as [|x y|p2 IH2 p2' IH2'|x p1' IH1].
        + simpl. intros p1 [H|H]; intros t.
            { subst. simpl. tauto. }
            { exfalso. assumption. }
        + intros p1 H p H'. simpl in H. destruct H as [H|H]; subst.
            { assumption. }
            { exfalso. assumption. }
        + simpl. intros p1 [H|H]; intros p.
            { subst. simpl. tauto. }
            { intros H'. right. apply in_or_app.
              apply in_app_or in H. destruct H as [H|H].
                { left.  apply IH2  with p1; assumption. }
                { right. apply IH2' with p1; assumption. }
            }
        + simpl. intros p1 [H|H]; intros p.
            { subst. simpl. tauto. }
            { intros H'. right. apply IH1 with p1; assumption. }
Qed.

(* transitivity follows from Sub_incl and transitity of incl                    *)
Lemma Sub_tran : forall (v:Type) (p q r:P v),
    p <<= q -> q <<= r -> p <<= r.
Proof.
    intros v p q r Hpq Hqr. apply Sub_incl.
    apply incl_tran with (Sub q); apply Sub_incl; assumption.
Qed.

(* This lemma will allow us to get anti-symmetry                                *)
Lemma ord_monotone : forall (v:Type) (p1 p2:P v),
    p1 <<= p2  -> le (ord p1) (ord p2).
Proof.
    intros v p1 p2. revert p1.
    induction p2 as [|x y|p2 IH2 p2' IH2'|x p1' IH1];
    simpl; intros p1 [H|H].
    - subst. apply le_n.
    - exfalso. assumption.
    - subst. apply le_n.
    - exfalso. assumption.
    - subst. apply le_n.
    - apply in_app_or in H. destruct H as [H|H].
        { apply le_trans with (ord p2).
            { apply IH2. assumption. }
            { apply le_S. apply n_le_max. }}
        { apply le_trans with (ord p2').
            { apply IH2'. assumption. }
            { apply le_S. apply m_le_max. }}
    - subst. apply le_n.
    - apply le_S, IH1. assumption.
Qed.

(* Anti-symmentry follows from Lemma ord_monotone                               *)
Lemma Sub_anti : forall (v:Type) (p1 p2:P v),
    p1 <<= p2 -> p2 <<= p1 -> p1 = p2.
Proof.
    intros v p1 p2. revert p1.
    induction p2 as [|x y|p2 IH2 p2' IH2'|x p1' IH1];
    simpl; intros p1 [H|H].
    - subst. tauto.
    - exfalso. assumption.
    - subst. tauto.
    - exfalso. assumption.
    - subst. tauto.
    - intros H'. exfalso. apply in_app_or in H. destruct H as [H|H];
      apply ord_monotone in H; apply ord_monotone in H';
      simpl in H'; apply not_le_Sn_n with (ord p1).
        { apply le_trans with (S (ord p2)).
            { apply le_n_S. assumption. }
            { apply le_trans with (S (max (ord p2) (ord p2'))).
                { apply le_n_S. apply n_le_max. }
                { assumption. }
            }
        }
        { apply le_trans with (S (ord p2')).
            { apply le_n_S. assumption. }
            { apply le_trans with (S (max (ord p2) (ord p2'))).
                { apply le_n_S. apply m_le_max. }
                { assumption. }
            }
        }
    - subst. tauto.
    - intros H'. exfalso.
      apply ord_monotone in H. apply ord_monotone in H'.
      simpl in H'. apply not_le_Sn_n with (ord p1).
      apply le_trans with (S (ord p1')).
        { apply le_n_S. assumption. }
        { assumption. }
Qed.

(* A set theoretic formulation of the same result is Sub (f p) = f (Sub p)      *)
(* with the customary abuse of notations, whereby 'f p' denotes the function    *)
(* f acting on the formula p (formally fmap f p), Sub (f p) is simply the       *)
(* function Sub applied to the formula (f p), and 'f (Sub p)' denotes the       *)
(* direct image of the set (Sub p) (a list for us) by function f acting on      *)
(* formulas (so fmap f). The direct image is expressed by 'map'. In heuristic   *)
(* terms, the following lemma expresses the fact that sub-formulas of the       *)
(* formula 'fmap f p' are the images of the sub-formulas of p by (fmap f).      *)

(* We could have a point-free version of this lemma                             *)
Lemma Sub_fmap : forall (v w:Type) (f:v -> w) (p:P v),
    Sub (fmap f p) = map (fmap f) (Sub p).
Proof.
    intros v w f.
    induction p as [|x y|p1 IH1 p2 IH2|x p1 IH1]; simpl.
    - reflexivity.
    - reflexivity.
    - rewrite IH1, IH2, map_app. reflexivity.
    - rewrite IH1. reflexivity.
Qed.

(* We defined (p <<= q) in Haskell as a function:                               *)
(* (<<=) :: (Eq v) => P v -> P v -> Bool                                        *)
(* Hence we expect that (p <<= q) is a decidable propostion in coq, provided    *)
(* the type v has decidable equality.                                           *)
Lemma SubDecidable : forall (v:Type) (e:Eq v),
   forall (p q:P v), {p <<= q} + {~ p <<= q}.
Proof.
    intros v e p q. revert p. revert q.
    induction q as [|x y|q1 IH1 q2 IH2|x q1 IH1].
    - destruct p as [|x' y'|p1 p2|x' p1].
        + left. apply Sub_refl.
        + right. intros H. destruct H as [H|H]; inversion H.
        + right. intros H. destruct H as [H|H]; inversion H.
        + right. intros H. destruct H as [H|H]; inversion H.
    - destruct p as [|x' y'|p1 p2|x' p1].
        + right. intros H. destruct H as [H|H]; inversion H.
        + destruct (eqDec x x') as [Ex|Ex], (eqDec y y') as [Ey|Ey].
            { subst. left. apply Sub_refl. }
            { right. intros H. destruct H as [H|H]; inversion H.
              subst. apply Ey. reflexivity.
            }
            { right. intros H. destruct H as [H|H]; inversion H.
              inversion H. subst. apply Ex. reflexivity.
            }
            { right. intros H. destruct H as [H|H]; inversion H.
              inversion H. subst. apply Ex. reflexivity.
            }
        + right. intros H. destruct H as [H|H]; inversion H.
        + right. intros H. destruct H as [H|H]; inversion H.
    - intros p. destruct (eqDec p (Imp q1 q2)) as [E|E].
        + subst. left. apply Sub_refl.
        + destruct (IH1 p) as [E1|E1], (IH2 p) as [E2|E2].
            { left. right. apply in_or_app. left.  assumption. }
            { left. right. apply in_or_app. left.  assumption. }
            { left. right. apply in_or_app. right. assumption. }
            { right. intros H. destruct H as [H|H].
                { subst. apply E. reflexivity. }
                { apply in_app_or in H. destruct H as [H|H].
                    { apply E1. assumption. }
                    { apply E2. assumption. }
                }
            }
    - intros p. destruct (eqDec p (All x q1)) as [E|E].
        + subst. left. apply Sub_refl.
        + destruct (IH1 p) as [E1|E1].
            { left. right. assumption. }
            { right. intros H. destruct H as [H|H].
                { subst. apply E. reflexivity. }
                { apply E1. assumption. }
            }
Qed.

Lemma Sub_var : forall (v:Type) (p q:P v),
    p <<= q -> var p <= var q.
Proof.
    intros v p q. revert q p.
    induction q as [|x y|p1 IH1 p2 IH2|x p1 IH1]; intros p [H|H].
    - subst. apply incl_refl.
    - inversion H.
    - subst. apply incl_refl.
    - inversion H.
    - subst. apply incl_refl.
    - apply in_app_or in H. destruct H as [H|H].
        + apply incl_tran with (var p1).
            { apply IH1. assumption. }
            { apply incl_appl, incl_refl. }
        + apply incl_tran with (var p2).
            { apply IH2. assumption. }
            { apply incl_appr, incl_refl. }
    - subst. apply incl_refl.
    - apply incl_tl, IH1. assumption.
Qed.

Lemma Sub_bnd : forall (v:Type) (p q:P v),
    p <<= q -> bnd p <= bnd q.
Proof.
    intros v p q. revert q p.
    induction q as [|x y|q1 IH1 q2 IH2|x q1 IH1]; intros p [H|H].
    - subst. apply incl_refl.
    - inversion H.
    - subst. apply incl_refl.
    - inversion H.
    - subst. apply incl_refl.
    - apply in_app_or in H. destruct H as [H|H].
        + apply incl_tran with (bnd q1).
            { apply IH1. assumption. }
            { apply incl_appl, incl_refl. }
        + apply incl_tran with (bnd q2).
            { apply IH2. assumption. }
            { apply incl_appr, incl_refl. }
    - subst. apply incl_refl.
    - apply incl_tl, IH1. assumption.
Qed.


(******************************************************************************)
(* Chapter 1.6.2: Opposite Categories                                         *)
(******************************************************************************)

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

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

Require Import Notations.
Require Import Categories.
Require Import Functors.
Require Import Isomorphisms.

Check @Category.

Generalizable Variables Obj Hom a b c d.

Lemma ref_eqv `{C : Category} `(f : a ~> b) `(g : a ~> b) :
  f === g -> g === f.
Proof.
  move=> H.
  rewrite H.
  reflexivity.
Qed.

Program Instance Opposite `(C : @Category Obj Hom) : @Category Obj (fun x y => Hom y x).
Obligation 1.                               (* Hom a a *)
Proof.
    by apply: id.
Defined.
Obligation 2.                               (* Hom c a *)
Proof.
  Check @comp _ _ C c b a X0 X : Hom c a.
    by apply: (@comp _ _ C c b a X0 X : Hom c a).
Defined.
Obligation 3.
Proof.
  rewrite /Opposite_obligation_2 /=.
  move=> f g H.
  move=> f' g' H' /=.
  Check @comp_respects Obj Hom C c b a f' g' H' f g H.
    by apply (@comp_respects Obj Hom C c b a f' g' H' f g H).
Defined.
Obligation 4.
  rewrite /Opposite_obligation_1 /Opposite_obligation_2 /=.
  Check right_identity.
    by apply right_identity.
Defined.
Obligation 5.
  rewrite /Opposite_obligation_1 /Opposite_obligation_2 /=.
    by apply left_identity.
Defined.
Obligation 6.
  rewrite /Opposite_obligation_2 /=.
  apply ref_eqv.
    by apply associativity.
Defined.

(* Notation "dual C" := (Opposite C)  : category_scope. *)

Generalizable Variables C D Fobj.

(* every functor between two categories determines a functor between their opposites *)
(* 双対の圏どうしの関手を定義する。 *)
Program Instance func_op `(F : @Functor _ _ C _ _ D Fobj) :
  @Functor _ _ (Opposite C) _ _ (Opposite D) Fobj :=
  {|
    fmor := (fun a b f => fmor F f)
  |}.
Obligation 2.
Proof.
  done.
Defined.
Obligation 3.
Proof.
  done.
Defined.

(* we could do this by simply showing that (Opposite (Opposite C)) is
 isomorphic to C, but Coq distinguishes between two categories being
 *equal* versus merely isomorphic, so it's handy to be able to do
 this *)

Program Instance func_opop `(F : @Functor _ _ (Opposite C) _ _ (Opposite D) Fobj) :
  @Functor _ _ C _ _ D Fobj :=
  {|
    fmor := (fun a b f => fmor F f)
  |}.
Obligation 2.
Proof.
  done.
Defined.
Obligation 3.
Proof.
  done.
Defined.

Program Instance func_op1 `(F : @Functor _ _ (Opposite C) _ _ D Fobj) :
  @Functor _ _ C _ _ (Opposite D) Fobj :=
  {|
    fmor := (fun a b f => fmor F f)
  |}.
Obligation 2.
Proof.
  done.
Defined.
Obligation 3.
Proof.
  done.
Defined.

Program Instance func_op2 `(F : @Functor _ _ C _ _ (Opposite D) Fobj) :
  @Functor _ _ (Opposite C) _ _ D Fobj :=
  {|
    fmor := (fun a b f => fmor F f)
  |}.
Obligation 2.
Proof.
  done.
Defined.
Obligation 3.
Proof.
  done.
Defined.

(* END *)


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section DeMorgan_B.

Coq < Goal forall p q:Prop, ~(p \/ q) <-> (~p /\ ~q).
1 subgoal

  ============================
   forall p q : Prop, ~ (p \/ q) <-> ~ p /\ ~ q

Unnamed_thm < intros.
1 subgoal

  p : Prop
  q : Prop
  ============================
   ~ (p \/ q) <-> ~ p /\ ~ q

Unnamed_thm < tauto.
No more subgoals.

Unnamed_thm < Qed.
intros.
tauto.

Unnamed_thm is defined

Coq <

*)

Section DeMorgan_B.
Goal forall p q:Prop, ~(p \/ q) <-> (~p /\ ~q).
intros.
tauto.
Qed.


Require Import HoTT.
From HoTT.Categories Require Import Functor NaturalTransformation.
From GR.bicategories Require Import
     bicategory.univalent
     bicategory.bicategory_laws
     lax_functor.lax_functor
     lax_transformation.lax_transformation
     lax_transformation.examples.identity
     modification.modification
     general_category
     lax_functor.examples.representable
     lax_transformation.examples.representable
     modification.examples.representable.
From GR.bicategories.bicategory.examples Require Import
     precat
     cat
     opposite
     pseudo_functors_bicat.

Section RepresentableId.
  Context `{Univalence}
          {C : BiCategory}.
  Variable (X : C).

  Definition representable_id_d
    : Modification_d (identity_transformation _) (representable1 (id₁ X)).
  Proof.
    intros Y.
    simple refine (Build_NaturalTransformation _ _ _ _).
    - intros h ; cbn in *.
      exact (left_unit_inv h).
    - intros h₁ h₂ α ; cbn in *.
      apply left_unit_inv_natural.
  Defined.

  Definition representable_id_is_modification
    : is_modification representable_id_d.
  Proof.
    intros Y₁ Y₂ f.
    apply path_natural_transformation.
    intros h ; cbn in *.
    rewrite !left_identity, !right_identity.
    rewrite left_unit_inv_assoc.
    rewrite <- associativity.
    rewrite <- inverse_of_assoc, right_inverse.
    apply left_identity.
  Qed.

  Definition representable_id
    : Modification (identity_transformation _) (representable1 (id₁ X))
    := Build_Modification representable_id_d representable_id_is_modification.
End RepresentableId.

Section RepresentableIdInv.
  Context `{Univalence}
          {C : BiCategory}.
  Variable (X : C).

  Definition representable_id_inv_d
    : Modification_d (representable1 (id₁ X)) (identity_transformation _).
  Proof.
    intros Y.
    simple refine (Build_NaturalTransformation _ _ _ _).
    - intros h ; cbn in *.
      exact (left_unit h).
    - intros h₁ h₂ α ; cbn in *.
      apply left_unit_natural.
  Defined.

  Definition representable_id_inv_is_modification
    : is_modification representable_id_inv_d.
  Proof.
    intros Y₁ Y₂ f.
    apply path_natural_transformation.
    intros h ; cbn in *.
    unfold bc_whisker_l.
    rewrite hcomp_id₂, !left_identity, !right_identity.
    apply left_unit_assoc.
  Qed.

  Definition representable_id_inv
    : Modification (representable1 (id₁ X)) (identity_transformation _)
    := Build_Modification representable_id_inv_d representable_id_inv_is_modification.
End RepresentableIdInv.


Require Import String.
Require Import ZArith.

Inductive val : Type :=
| Vbool : bool -> val
| Vint  : Z -> val
| Vstr  : string -> val
| Vaddr : Z -> val.

Inductive op1 : Type :=
| Oneg
| Onot.

Inductive op2 : Type :=
| Oadd
| Osub
| Omul
| Odiv
| Omod
| Oeq
| Olt
| Ole
| Oconj
| Odisj.

Inductive expr : Type :=
| Eval : val -> expr
| Evar : string -> expr
| Eop1 : op1 -> expr -> expr
| Eop2 : op2 -> expr -> expr -> expr
| Elen : expr -> expr
| Eidx : expr -> expr -> expr.

Definition store : Type :=
  list (string * val).

Definition heap : Type :=
  list val.

Inductive stmt : Type :=
| Snop : stmt
| Sset : string -> expr -> stmt
| Salloc : string -> expr -> expr -> stmt
| Swrite : string -> expr -> expr -> stmt
| Scall : string -> string -> list expr -> stmt
| Sifelse : expr -> stmt -> stmt -> stmt
| Swhile : expr -> stmt -> stmt
| Sseq : stmt -> stmt -> stmt.

Inductive func : Type :=
| Func : string -> list string -> stmt -> expr -> func.

Inductive prog : Type :=
| Prog : list func -> stmt -> expr -> prog.


Require Import HoTT.
From HoTT.Categories Require Import Functor NaturalTransformation.
From GR.bicategories Require Import
     bicategory.univalent
     bicategory.bicategory_laws
     lax_functor.lax_functor
     lax_transformation.lax_transformation
     lax_transformation.examples.composition
     modification.modification
     general_category
     lax_functor.examples.representable
     lax_transformation.examples.representable
     modification.examples.representable.
From GR.bicategories.bicategory.examples Require Import
     precat
     cat
     opposite
     pseudo_functors_bicat.

Section RepresentableComp.
  Context `{Univalence}
          {C : BiCategory}
          {X₁ X₂ X₃ : C}.
  Variable (g : C⟦X₂,X₃⟧)
           (f : C⟦X₁,X₂⟧).

  Definition representable_comp_d
    : Modification_d
        (composition.compose (representable1 f) (representable1 g))
        (representable1 (g · f)).
  Proof.
    intros Z.
    simple refine (Build_NaturalTransformation _ _ _ _).
    - intros h ; cbn in *.
      apply assoc_inv.
    - intros h₁ h₂ α ; cbn in *.
      unfold bc_whisker_l.
      rewrite <- hcomp_id₂.
      apply assoc_inv_natural.
  Defined.

  Definition representable_comp_is_modification
    : is_modification representable_comp_d.
  Proof.
    intros Z₁ Z₂ h.
    apply path_natural_transformation.
    intros φ ; cbn in *.
    unfold bc_whisker_l, bc_whisker_r.
    rewrite !hcomp_id₂, !left_identity, !right_identity.
    rewrite <- !associativity.
    apply inverse_pentagon_5.
  Qed.

  Definition representable_comp
    : Modification
        (composition.compose (representable1 f) (representable1 g))
        (representable1 (g · f))
    := Build_Modification representable_comp_d representable_comp_is_modification.
End RepresentableComp.

Section RepresentableCompInv.
  Context `{Univalence}
          {C : BiCategory}
          {X₁ X₂ X₃ : C}.
  Variable (g : C⟦X₂,X₃⟧)
           (f : C⟦X₁,X₂⟧).

  Definition representable_comp_inv_d
    : Modification_d
        (representable1 (g · f))
        (composition.compose (representable1 f) (representable1 g)).
  Proof.
    intros Z.
    simple refine (Build_NaturalTransformation _ _ _ _).
    - intros h ; cbn in *.
      apply assoc.
    - intros h₁ h₂ α ; cbn in *.
      unfold bc_whisker_l.
      rewrite <- hcomp_id₂.
      apply assoc_natural.
  Defined.

  Definition representable_comp_inv_is_modification
    : is_modification representable_comp_inv_d.
  Proof.
    intros Z₁ Z₂ h.
    apply path_natural_transformation.
    intros φ ; cbn in *.
    unfold bc_whisker_l, bc_whisker_r.
    rewrite !hcomp_id₂, !left_identity, !right_identity.
    symmetry.
    apply pentagon.
  Qed.

  Definition representable_comp_inv
    : Modification
        (representable1 (g · f))
        (composition.compose (representable1 f) (representable1 g))
    := Build_Modification representable_comp_inv_d representable_comp_inv_is_modification.
End RepresentableCompInv.


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

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

Print Assumptions square.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e448m2e224m1_7limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e216m2e108m1_7limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


From mathcomp Require Import all_ssreflect.

Section Rename.

  Definition upren r x :=
    if x is x.+1 then (r x).+1 else 0.
  Definition upnren r n := iter n upren r.

  Corollary upnrenS r n x : upren (upnren r n) x = upnren (upren r) n x.
  Proof. by rewrite /upnren -iterSr. Qed.

  Lemma upnren_unfold r n : forall x,
    upnren r n x = if x < n then x else n + r (x - n).
  Proof.
    induction n => [ ? | [ | ? ] ] //=.
    - by rewrite subn0.
    - by rewrite IHn (fun_if succn).
  Qed.

  Lemma eq_upren r r' : forall x,
    (0 < x -> r x.-1 = r' x.-1) ->
    upren r x = upren r' x.
  Proof. by rewrite /upren => [ [ | ? /= -> ] ]. Qed.

  Lemma eq_upnren r r' n x :
    (n <= x -> r (x - n) = r' (x - n)) ->
    upnren r n x = upnren r' n x.
  Proof.
    rewrite !upnren_unfold.
    by case: (leqP n x) => [ ? -> | ].
  Qed.

  Lemma upren_id : forall x, upren id x = x.
  Proof. by move => [ | ? ]. Qed.

  Lemma upnren_id n : forall x, upnren id n x = x.
  Proof.
    induction n => ? //=.
    by rewrite (eq_upren _ id _ (fun _ => IHn _)) upren_id.
  Qed.

  Lemma upren_comp r r' :
    upren (r \o r') =1 upren r \o upren r'.
  Proof. by move => [ | ? ]. Qed.

  Lemma upnren_comp n : forall r r',
    upnren (r \o r') n =1 upnren r n \o upnren r' n.
  Proof.
    induction n => ? ? ? //=.
    by rewrite (eq_upren _ _ _ (fun _ => IHn _ _ _)) upren_comp.
  Qed.

  Class Rename (term : Set) :=
    { Var : nat -> term;
      rename : (nat -> nat) -> term -> term;
      rename_Var : forall r x, rename r (Var x) = Var (r x);
      eq_rename : forall t r r', (forall x, r x = r' x) -> rename r t = rename r' t }.

  Class RenameLemmas (term : Set) {RenameTerm : Rename term} :=
    { rename_id : forall t, rename id t = t;
      rename_rename_comp : forall t r r', rename r (rename r' t) = rename (r \o r') t }.

  Context {term : Set} {RenameTerm : Rename term}.

  Lemma rename_id_upren t :
    rename id t = t ->
    rename (upren id) t = t.
  Proof. by rewrite (eq_rename _ _ _ upren_id). Qed.

  Lemma rename_id_upnren t
    (_ : rename id t = t) n :
    rename (upnren id n) t = t.
  Proof. by rewrite (eq_rename _ _ _ (upnren_id _)). Qed.

  Lemma rename_rename_comp_upren t
    (_ : forall r r', rename r (rename r' t) = rename (r \o r') t) r r' :
    rename (upren r) (rename (upren r') t) = rename (upren (r \o r')) t.
  Proof. by rewrite (eq_rename _ _ _ (upren_comp _ _)). Qed.

  Lemma rename_rename_comp_upnren t
    (_ : forall r r', rename r (rename r' t) = rename (r \o r') t) r r' n :
    rename (upnren r n) (rename (upnren r' n) t) = rename (upnren (r \o r') n) t.
  Proof. by rewrite (eq_rename _ _ _ (upnren_comp _ _ _)). Qed.

End Rename.

Section Subst.
  Context {term : Set} {RenameTerm : Rename term} {RenameLemmaTerm : RenameLemmas term}.

  Definition up s x :=
    if x is x.+1 then rename succn (s x) else Var 0.
  Definition upn s n := iter n up s.

  Corollary upnS s n x : up (upn s n) x = upn (up s) n x.
  Proof. by rewrite /upn -iterSr. Qed.

  Lemma upn_unfold s n : forall x,
    upn s n x = if x < n then Var x else rename (addn n) (s (x - n)).
  Proof.
    induction n => [ ? | [ | ? ] ] //=.
    - by rewrite subn0 (eq_rename _ _ id) ?rename_id.
    - rewrite ltnS subSS IHn (fun_if (rename succn)) rename_Var rename_rename_comp.
      congr (if _ then _ else _).
  Qed.

  Lemma eq_up s s' : forall x,
    (0 < x -> s x.-1 = s' x.-1) ->
    up s x = up s' x.
  Proof. by move => [ | ? /= -> ]. Qed.

  Lemma eq_upn s s' n x :
    (n <= x -> s (x - n) = s' (x - n)) ->
    upn s n x = upn s' n x.
  Proof. rewrite !upn_unfold. by case: (leqP n x) => [ ? -> | ]. Qed.

  Lemma up_Var : forall x, up Var x = Var x.
  Proof. move => [ | ? ] //=. by rewrite rename_Var. Qed.

  Lemma upn_Var n : forall x, upn Var n x = Var x.
  Proof.
    induction n => ? //=.
    by rewrite (eq_up _ Var _ (fun _ => IHn _)) up_Var.
  Qed.

  Lemma up_upren r : Var \o upren r =1 up (Var \o r).
  Proof. move => [ | ? ] //=. by rewrite rename_Var. Qed.

  Lemma upn_upnren r n : Var \o upnren r n =1 upn (Var \o r) n.
  Proof.
    induction n => ? //=.
    by rewrite -(eq_up _ _ _ (fun _ => IHn _)) -up_upren.
  Qed.

  Lemma up_upren_comp s r :
    up (s \o r) =1 up s \o upren r.
  Proof. by move => [ | ? ]. Qed.

  Lemma upn_upnren_comp s r n :
    upn (s \o r) n =1 upn s n \o upnren r n.
  Proof.
    induction n => ? //=.
    by rewrite (eq_up _ _ _ (fun _ => IHn _)) up_upren_comp.
  Qed.

  Lemma upren_up_comp r s :
    up (rename r \o s) =1 rename (upren r) \o up s.
  Proof.
    move => [ | ? ] /=.
    - by rewrite rename_Var.
    - rewrite !rename_rename_comp.
      exact: eq_rename.
  Qed.

  Lemma upnren_upn_comp r s n :
    upn (rename r \o s) n =1 rename (upnren r n) \o upn s n.
  Proof.
    induction n => ? //=.
    by rewrite (eq_up _ _ _ (fun _ => IHn _)) upren_up_comp.
  Qed.

  Class Subst :=
    { subst : (nat -> term) -> term -> term;
      subst_Var : forall s x, subst s (Var x) = s x;
      eq_subst : forall t s s', (forall x, s x = s' x) -> subst s t = subst s' t }.

  Context {SubstTerm : Subst}.

  Lemma rename_subst_up t
    (_ : forall r, rename r t = subst (Var \o r) t) r :
    rename (upren r) t = subst (up (Var \o r)) t.
  Proof. by rewrite -(eq_subst _ _ _ (up_upren _)). Qed.

  Lemma rename_subst_upn t
    (_ : forall r, rename r t = subst (Var \o r) t) r n :
    rename (upnren r n) t = subst (upn (Var \o r) n) t.
  Proof. by rewrite -(eq_subst _ _ _ (upn_upnren _ _)). Qed.

  Lemma subst_id_up t
    (_ : subst Var t = t) :
    subst (up Var) t = t.
  Proof. by rewrite (eq_subst _ _ _ up_Var). Qed.

  Lemma subst_id_upn t
    (_ : subst Var t = t) n :
    subst (upn Var n) t = t.
  Proof. by rewrite (eq_subst _ _ _ (upn_Var _)). Qed.

  Lemma subst_rename_comp_up t
    (_ : forall r s, subst s (rename r t) = subst (s \o r) t) r s :
    subst (up s) (rename (upren r) t) = subst (up (s \o r)) t.
  Proof. by rewrite (eq_subst _ _ _ (up_upren_comp _ _)). Qed.

  Lemma subst_rename_comp_upn t
    (_ : forall r s, subst s (rename r t) = subst (s \o r) t) r s n :
    subst (upn s n) (rename (upnren r n) t) = subst (upn (s \o r) n) t.
  Proof. by rewrite (eq_subst _ _ _ (upn_upnren_comp _ _ _)). Qed.

  Lemma rename_subst_comp_up t
    (_ : forall r s, rename r (subst s t) = subst (rename r \o s) t) r s :
    rename (upren r) (subst (up s) t) = subst (up (rename r \o s)) t.
  Proof. by rewrite (eq_subst _ _ _ (upren_up_comp _ _)). Qed.

  Lemma rename_subst_comp_upn t
    (_ : forall r s, rename r (subst s t) = subst (rename r \o s) t) r s n :
    rename (upnren r n) (subst (upn s n) t) = subst (upn (rename r \o s) n) t.
  Proof. by rewrite (eq_subst _ _ _ (upnren_upn_comp _ _ _)). Qed.

  Class SubstLemmas :=
    { subst_id t : subst Var t = t;
      rename_subst t : forall r, rename r t = subst (Var \o r) t;
      subst_rename_comp : forall t r s, subst s (rename r t) = subst (s \o r) t;
      rename_subst_comp : forall t r s, rename r (subst s t) = subst (rename r \o s) t }.

  Context {SubstLemmasTerm : SubstLemmas}.

  Lemma up_up_comp s s' :
    up (subst s \o s') =1 subst (up s) \o up s'.
  Proof.
    move => [ | ? ] /=.
    - by rewrite subst_Var.
    - rewrite rename_subst_comp subst_rename_comp.
      exact: eq_subst.
  Qed.

  Lemma upn_upn_comp s s' n :
    upn (subst s \o s') n =1 subst (upn s n) \o upn s' n.
  Proof.
    induction n => ? //=.
    by rewrite (eq_up _ _ _ (fun _ => IHn _)) up_up_comp.
  Qed.

  Lemma subst_subst_comp_up t
    (_ : forall s s', subst s (subst s' t) = subst (subst s \o s') t) s s' :
    subst (up s) (subst (up s') t) = subst (up (subst s \o s')) t.
  Proof. by rewrite (eq_subst _ _ _ (up_up_comp _ _)). Qed.

  Lemma subst_subst_comp_upn t
    (_ : forall s s', subst s (subst s' t) = subst (subst s \o s') t) s s' n :
    subst (upn s n) (subst (upn s' n) t) = subst (upn (subst s \o s') n) t.
  Proof. by rewrite (eq_subst _ _ _ (upn_upn_comp _ _ _)). Qed.

  Class SubstLemmas' :=
    { subst_subst_comp : forall t s s', subst s (subst s' t) = subst (subst s \o s') t }.

End Subst.

Arguments Subst term {RenameTerm}.
Arguments SubstLemmas term {RenameTerm SubstTerm}.
Arguments SubstLemmas' term {RenameTerm SubstTerm}.

Definition scons {A} (a : A) s x :=
  if x is x.+1 then s x else a.

Definition scat {A} l := (foldr (@scons A))^~l.

Lemma nth_scat {A} l s : forall x, @scat A l s x = nth (s (x - size l)) l x.
Proof.
  induction l => [ ? | [ | ? ] ] //=.
  - by rewrite subn0 nth_nil.
  - by rewrite subSS.
Qed.


Require Import OrderedType.
Require Import ProjectedOrderedType.

Inductive accessRight  :=
| wk : accessRight
| rd : accessRight
| wr : accessRight
| tx : accessRight.

Module ProjectedAccessRight <: ProjectedToNat.

  Definition t := accessRight.

  Definition project_to_nat r:=
    match r with
      | wk => 0
      | rd => 1
      | wr => 2
      | tx => 3
    end.

  Theorem project_to_nat_unique: forall x y:t,
    (project_to_nat x) = (project_to_nat y) <-> x = y.
  Proof.
    intros x y; split; intros H;
      unfold project_to_nat in *;
        destruct x; destruct y; auto; discriminate.
  Qed.

End ProjectedAccessRight.

Module AccessRight := POT_to_OT ProjectedAccessRight.

(* Module AccessRightOT : OrderedType := AccessRight. *)


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

(** This file contains some definitions, lemmas and tactics that
    are missing from the Arith section of the Coq standard library.
 *)

Require Import Classical Epsilon Arith Even Div2 Omega.
Require Import MiscLogic.

Lemma double_minus: forall n m : nat, double (n - m) = double n - double m.
Proof.
induction n as [ | n IH].
reflexivity.
destruct m as [ | m].
reflexivity.
simpl.
rewrite IH.
unfold double.
omega.
Qed.

Lemma even_even_minus: forall n m : nat, even n -> even m -> even (n - m).
Proof.
intros n m Hn Hm.
destruct (even_2n _ Hm) as [m' Hm'].
destruct (even_2n _ Hn) as [n' Hn'].
subst m.
subst n.
rewrite <- double_minus.
cutrewrite (double (n'-m')= 2*(n'-m'))%nat.
auto with arith.
unfold double.
omega.
Qed.

Lemma odd_even_minus: forall n m : nat, odd n -> odd m -> even (n - m).
Proof.
intros n m Hn Hm.
destruct (odd_S2n _ Hm) as [m' Hm'].
destruct (odd_S2n _ Hn) as [n' Hn'].
subst m.
subst n.
simpl.
rewrite <- double_minus.
cutrewrite (double (n'-m')= 2*(n'-m'))%nat.
auto with arith.
unfold double.
omega.
Qed.

Definition IsLeast (P:nat->Prop)(n:nat) : Prop :=
  P n /\ forall m, m<n -> ~P m.

Definition least (P:nat->Prop) : nat :=
  iota (inhabits 0) (IsLeast P).

Lemma least_exists : forall (P:nat->Prop), (exists n, P n) -> exists! m, IsLeast P m.
Proof.
intros P H.
apply NNPP.
contradict H.
apply all_not_not_ex.
apply well_founded_ind with (R:=lt).
auto with arith.
intros n H0.
contradict H.
exists n.
unfold IsLeast.
split.
tauto.
intros m [H1 H2].
generalize (H0 m).
generalize (H2 n).
clear H0 H2.
intros H2 H0.
destruct (lt_eq_lt_dec m n) as [ [H3 | H3] | H3].
tauto.
congruence.
tauto.
Qed.

Lemma least_unique :
  forall n (P:nat -> Prop), P n -> n < least P -> n = least P.
Proof.
intros n P H.
unfold least.
apply iota_ind.
apply least_exists.
exists n.
assumption.
unfold IsLeast.
intros m [H1 H2] H3.
generalize (H2 n).
tauto.
Qed.


Set Warnings "-notation-overridden,-parsing".
Require Import maps.
Require Import smallstep2.
Require Import typerevise.

Module STLC.

Inductive ty : Type :=
  | TBool : ty
  | TArrow : ty -> ty -> ty.  (* Functy *)

Inductive tm : Type :=
  | tvar : string -> tm
  | tapp : tm -> tm -> tm
  | tabs : string -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.

Open Scope string_scope.
Definition x := "x".
Definition y := "y".
Definition z := "z".
Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

Notation idB :=
  (tabs x TBool (tvar x)).
Notation idBB :=
  (tabs x (TArrow TBool TBool) (tvar x)).
Notation idBBBB :=
  (tabs x (TArrow (TArrow TBool TBool)
                      (TArrow TBool TBool))(tvar x)).
Notation k := (tabs x TBool (tabs y TBool (tvar x))).
Notation notB := (tabs x TBool (tif (tvar x) tfalse ttrue)).

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_true :
      value ttrue
  | v_false :
      value tfalse.
Hint Constructors value.

Reserved Notation "'[' x ':=' s ']' t" (at level 20).
Fixpoint subst (x:string) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if beq_string x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if beq_string x x' then t1 else ([x:=s] t1))
  | tapp t1 t2 =>
      tapp ([x:=s] t1) ([x:=s] t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

Inductive substi (s:tm) (x:string) : tm -> tm -> Prop :=
  | s_var1 :
      substi s x (tvar x) s
  | s_var2 : forall x', x <> x' ->
      substi s x (tvar x') (tvar x')
  | s_abs1 : forall T t1 t1', t1 = tabs x T t1' ->
              substi s x (tabs x T t1') t1
  | s_abs2 : forall x' T t1 t1', x<>x'->
    substi s x t1 t1' ->
    substi s x (tabs x' T t1) (tabs x' T t1')
  | s_app : forall t1 t1' t2 t2',
       substi s x t1' t1 ->  substi s x t2' t2 ->
         substi s x (tapp t1' t2') (tapp t1 t2)
  | s_true : substi s x ttrue ttrue
  | s_false : substi s x tfalse tfalse
  | s_if :  forall t1 t2 t3 t1' t2' t3',
     substi s x t1 t1' -> substi s x t2 t2'
     -> substi s x t3 t3' ->
     substi s x (tif t1 t2 t3) (tif t1' t2' t3').

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
Admitted.

Hint Constructors substi.

Theorem substi_correct : forall s x t t',
  [x:=s]t = t' <-> substi s x t t'.
Proof.
intros s x t t'.
split.
- generalize dependent t'. induction t.
 + intros.
   simpl in H. unfold beq_string in H.
   destruct (string_dec x s0) in H.
  * rewrite e,H. apply s_var1.
  * rewrite <- H. apply s_var2.
    assumption.
 + intros. simpl in H. rewrite <- H.
   apply s_app.
  * apply IHt1. reflexivity.
  * apply IHt2. reflexivity.
 + intros. simpl in H.
   unfold beq_string in H.
   destruct (string_dec x s0) in H.
  * rewrite <- e. apply s_abs1.
    rewrite e,H. reflexivity.
  * rewrite <- H. apply s_abs2.
    apply n. apply IHt. reflexivity.
 + intros. rewrite <- H. simpl.
   apply s_true.
 + intros. rewrite <-H. simpl.
   apply s_false.
 + intros. rewrite <- H.
   simpl. apply s_if.
  * apply IHt1. reflexivity.
  * apply IHt2. reflexivity.
  * apply IHt3. reflexivity.
- generalize dependent t'.
  induction t; intros t' H.
 + inversion H. subst.
  * simpl. unfold beq_string.
    destruct (string_dec s0 s0).
    reflexivity. apply ex_falso_quodlibet.
    apply n. reflexivity.
  * simpl. unfold beq_string.
    destruct (string_dec x s0).
    subst. apply ex_falso_quodlibet.
    apply H1. reflexivity.
    reflexivity.
 + inversion H. subst. simpl.
   apply IHt1 in H2. apply IHt2 in H4.
   rewrite H2, H4. reflexivity.
 + inversion H. subst. simpl.
   unfold beq_string.
   destruct (string_dec s0 s0).
   reflexivity.
   apply ex_falso_quodlibet. apply n.
   reflexivity. subst. apply IHt in H5.
   rewrite <- H5. simpl.
   unfold beq_string.
   destruct (string_dec x s0).
   apply ex_falso_quodlibet. apply H4. apply e.
   reflexivity.
 + simpl. inversion H. reflexivity.
 + simpl. inversion H. reflexivity.
 + simpl. inversion H. subst.
   apply IHt1 in H3. apply IHt2 in H5.
   apply IHt3 in H6. subst. reflexivity.
Qed.

Reserved Notation "t1 '-->' t2" (at level 40).
Inductive step : tm ->tm ->Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) --> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         tapp t1 t2 --> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         tapp v1 t2 --> tapp v1 t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) --> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) --> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 --> t1' ->
      (tif t1 t2 t3) --> (tif t1' t2 t3)

where "t1 '-->' t2" := (step t1 t2).
Hint Constructors step.
Notation multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Lemma step_example1 :
  (tapp idBB idB) -->* idB.
Proof.
  eapply multi_step.
    apply ST_AppAbs.
    apply v_abs.
  simpl.
  apply multi_refl. Qed.

Lemma step_example2 :
  (tapp idBB (tapp idBB idB)) -->* idB.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto.
  eapply multi_step.
    apply ST_AppAbs. simpl. auto.
  simpl. apply multi_refl. Qed.

Lemma step_example3 :
  tapp (tapp idBB notB) ttrue -->* tfalse.
Proof.
  eapply multi_step.
    apply ST_App1. apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_IfTrue. apply multi_refl. Qed.

Lemma step_example4 :
  tapp idBB (tapp notB ttrue) -->* tfalse.
Proof.
eapply multi_step.
apply ST_App2. auto.
apply ST_AppAbs. auto.
eapply multi_step. simpl.
apply ST_App2. auto.
apply ST_IfTrue.
eapply multi_step.
apply ST_AppAbs. auto.
simpl. apply multi_refl.
Qed.

Lemma step_example5 :
   tapp (tapp idBBBB idBB) idB
  -->* idB.
Proof.
eapply multi_step.
apply ST_App1.
apply ST_App2.
Admitted.

(* Lemma step_example1' :
  (tapp idBB idB) -->* idB.
Proof. normalize. Qed.
Lemma step_example2' :
  (tapp idBB (tapp idBB idB)) -->* idB.
Proof. normalize. Qed. *)
(* Lemma step_example3' :
  tapp (tapp idBB notB) ttrue -->* tfalse.
Proof. normalize. Qed.
Lemma step_example4' :
  tapp idBB (tapp notB ttrue) -->* tfalse.
Proof. normalize. Qed.

Lemma step_example5_with_normalize :
       tapp (tapp idBBBB idBB) idB
  -->* idB.
Proof.
normalize.
Qed. *)

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t 'in' T" (at level 40).
Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- tvar x in T
  | T_Abs : forall Gamma x T11 T12 t12,
      (update Gamma x T11) |- t12 in T12 ->
      Gamma |- tabs x T11 t12 in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 in TArrow T11 T12 ->
      Gamma |- t2 in T11 ->
      Gamma |- tapp t1 t2 in T12
  | T_True : forall Gamma,
       Gamma |- ttrue in TBool
  | T_False : forall Gamma,
       Gamma |- tfalse in TBool
  | T_If : forall t1 t2 t3 T Gamma,
       Gamma |- t1 in TBool ->
       Gamma |- t2 in T ->
       Gamma |- t3 in T ->
       Gamma |- tif t1 t2 t3 in T

where "Gamma '|-' t 'in' T" := (has_type Gamma t T).
Hint Constructors has_type.

Example typing_example_1 :
  empty |- tabs x TBool (tvar x) in TArrow TBool TBool.
Proof.
  apply T_Abs. apply T_Var. reflexivity. Qed.

Example typing_example_2 :
  empty |-
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof with auto using update_eq.
  apply T_Abs.
  apply T_Abs.
  eapply T_App. apply T_Var...
  eapply T_App. apply T_Var...
  apply T_Var...
Qed.

(* types is not done totally*)

End STLC.


Require Import
  Coq.Classes.CRelationClasses
  Coq.micromega.Lia
  Coq.Program.Program
  Coq.Unicode.Utf8
  Coq.Vectors.Fin
  Coq.Structures.Equalities
  Coq.Structures.DecidableType
  Coq.Sets.Finite_sets
  Coq.Logic.Classical
  Coq.Logic.ClassicalFacts
  Coq.Sets.Ensembles.

From Equations Require Import Equations.
Set Equations With UIP.

Generalizable All Variables.

(************************************************************************
 ** Types with finite inhabitants.
 ************************************************************************)

Definition Iso (a b : Type) : Type :=
  { h : iffT a b | fst h ∘ snd h = id ∧ snd h ∘ fst h = id }.

(* [a] is a finite type (and thus, enumerable) if there is a bijection from
   that type to the finite naturals for some value of [n]. *)
Class Finite (a : Type) : Type := {
    cardinality : nat;
    (* There is a drawback to this definition, which is that it decides a
       single ordering, when in fact there are combinatorially many witness to
       this proof. What we should really have here is the space of all such
       isomorphisms. *)
    cardinality_witness : Iso a (Fin.t cardinality)
}.

(* We can enumerate all inhabitants of a finite type by induction on the
   cardinality and asking for the witness. *)
Definition enumerate `{F : Finite k} : list k.
Proof.
  destruct F as [n [[_ h] [_ _]]]; simpl in *.
  induction n.
  - exact nil.
  - pose proof (@of_nat_lt 0 (S n) ltac:(lia)) as H.
    apply cons.
    + apply h.
      exact H.
    + apply IHn.
      intros.
      apply h.
      apply FS.
      exact H0.
Defined.

(************************************************************************
 ** Helper tactics used below.
 ************************************************************************)

Ltac breakdown :=
  repeat lazymatch goal with
         | [ H : context[eq_dec ?X ?Y] |- _ ] =>
             destruct (eq_dec X Y); subst; firstorder eauto
         | [ |- context[eq_dec ?X ?Y] ] =>
             destruct (eq_dec X Y); subst; firstorder eauto
         end.

(************************************************************************
 ** Map interface
 ************************************************************************)

Definition remove {k v} (i : k) (m : Ensemble (k * v)) :=
  Setminus _ m (λ '(j, _), i = j).

Definition add {k v} (i : k) (x : v) (m : Ensemble (k * v)) :=
  Add _ m (i, x).

Definition insert {k v} (i : k) (x : v) (m : Ensemble (k * v)) :=
  Add _ (remove i m) (i, x).

Definition find {k v} (i : k) (m : Ensemble (k * v)) :=
  (λ x, In _ m (i, x)) : Ensemble v.

Definition mem {k v} (i : k) (m : Ensemble (k * v)) :=
  ∃ x, In _ m (i, x).

Definition has_val {k v} (i : k) (x : v) (m : Ensemble (k * v)) :=
  In _ m (i, x).

Definition keys {k v} (m : Ensemble (k * v)) := λ i, ∃ x, In _ m (i, x).

Definition elements {k v} (m : Ensemble (k * v)) := m.

Definition map {k v v'} (f : v → Ensemble v') (m : Ensemble (k * v)) :=
  λ '(i, x), ∃ y, In _ m (i, y) ∧ f y = x.

Definition mapi {k v v'} (f : k → v → Ensemble v') (m : Ensemble (k * v)) :=
  λ '(i, x), ∃ y, In _ m (i, y) ∧ f i y = x.

Definition equal {k v} : relation (Ensemble (k * v)) :=
  Same_set _.

Definition equal_f {k v} (f : relation v) : relation (Ensemble (k * v)) :=
  λ m1 m2, ∀ i x y, In _ m1 (i, x) → In _ m2 (i, y) → f x y.

Definition cardinal {k v} (m : Ensemble (k * v)) :=
   Coq.Sets.Finite_sets.cardinal k (keys m).

(************************************************************************
 ** Dependent Map interface
 ************************************************************************)

Definition remove_dep {k v} (i : k) (m : Ensemble { j : k & v j }) :=
  Setminus _ m (λ '(existT _ j _), i = j).

Definition add_dep {k v} (i : k) (x : v i) (m : Ensemble { j : k & v j }) :=
  Add _ m (existT _ i x).

Definition insert_dep {k v} (i : k) (x : v i) (m : Ensemble { j : k & v j }) :=
  Add _ (remove_dep i m) (existT _ i x).

Definition find_dep {k v} (i : k) (m : Ensemble { j : k & v j }) :=
  (λ x, In _ m (existT _ i x)) : Ensemble (v i).

Definition mem_dep {k v} (i : k) (m : Ensemble { j : k & v j }) :=
  ∃ x, In _ m (existT _ i x).

Definition has_val_dep {k v} (i : k) (x : v i) (m : Ensemble { j : k & v j }) :=
  In _ m (existT _ i x).

Definition keys_dep {k v} (m : Ensemble { j : k & v j }) :=
  λ i, ∃ x, In _ m (existT _ i x).

Definition elements_dep {k v} (m : Ensemble { j : k & v j }) := m.

Definition map_dep {k v v'} (f : ∀ j, v j → Ensemble (v' j)) (m : Ensemble { j : k & v j }) :=
  λ '(existT _ i x), ∃ y, In _ m (existT _ i y) ∧ f i y = x.

Definition equal_dep {k v} : relation (Ensemble { j : k & v j }) :=
  Same_set _.

Definition equal_f_dep {k v} (f : ∀ j, relation (v j)) :
  relation (Ensemble { j : k & v j }) :=
  λ m1 m2, ∀ i x y, In _ m1 (existT _ i x) → In _ m2 (existT _ i y) → f i x y.

Definition cardinal_dep {k v} (m : Ensemble { j : k & v j }) :=
   Coq.Sets.Finite_sets.cardinal k (keys_dep m).