From mathcomp Require Import
  ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype.

From deriving Require Import base.

From Coq Require Import ZArith NArith String Ascii.

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

(* Backwards compatibility for hint locality attributes *)
Set Warnings "-unsupported-attributes".

Open Scope deriving_scope.

Record fun_split n (R : Type) (T : R) (Ts : fin n -> R) := FunSplit {
  fs_fun :> fin n.+1 -> R;
  _      :  T = fs_fun None;
  _      :  forall i, Ts i = fs_fun (Some i);
}.

Definition fsE1 n R T Ts (TTs : @fun_split n R T Ts) : T = TTs None :=
  let: FunSplit _ e _ := TTs in e.

Definition fsE2 n R T Ts (TTs : @fun_split n R T Ts) :
  forall i, Ts i = TTs (Some i) :=
  let: FunSplit _ _ e := TTs in e.

Canonical fun_split1 n R (TTs : fin n.+1 -> R) :=
  @FunSplit n R (TTs None) (fun i => TTs (Some i)) TTs erefl (fun=> erefl).

#[global]
Hint Unfold fs_fun : deriving.
#[global]
Hint Unfold fsE1 : deriving.
#[global]
Hint Unfold fsE2 : deriving.
#[global]
Hint Unfold fun_split1 : deriving.

Section LiftClass.

Import PolyType.

Variables (K : Type) (sort : K -> Type).

Definition eq_class X := {sX : K | sort sX = X}.

Record tagged_sort n := TaggedSort {
  untag_sort :> fin n -> Type;
}.

Definition ts_nil_tag n Ts := @TaggedSort n Ts.
Canonical ts_cons_tag n Ts := @ts_nil_tag n Ts.

Record lift_class n := LiftClass {
  lift_class_sort  :> tagged_sort n;
  _ :  forall i, eq_class (lift_class_sort i);
}.

Definition lift_class_class n (sTs : lift_class n) :=
  let: LiftClass _ cTs := sTs return forall i, eq_class (sTs i) in cTs.

Canonical nil_lift_class f :=
  @LiftClass 0 (ts_nil_tag f) (fun i => match i with end).

Canonical cons_lift_class n
  (sT : K) (f : lift_class n) (g : fun_split (sort sT) f) :=
  @LiftClass n.+1 (ts_cons_tag g)
             (fun i =>
                match i with
                | None   => cast eq_class (fsE1 g)   (exist _ sT erefl)
                | Some i => cast eq_class (fsE2 g i) (lift_class_class f i)
                end).

Definition lift_class_proj n cK
           (class : forall sT, cK (sort sT))
           (sTs : lift_class n) (i : fin n)
  : cK (sTs i) :=
  cast cK (svalP (lift_class_class sTs i)) (class _).

End LiftClass.

#[global]
Hint Unfold eq_class : deriving.
#[global]
Hint Unfold untag_sort : deriving.
#[global]
Hint Unfold ts_nil_tag : deriving.
#[global]
Hint Unfold ts_cons_tag : deriving.
#[global]
Hint Unfold lift_class_sort : deriving.
#[global]
Hint Unfold lift_class_class : deriving.
#[global]
Hint Unfold nil_lift_class : deriving.
#[global]
Hint Unfold cons_lift_class : deriving.
#[global]
Hint Unfold lift_class_proj : deriving.

Arguments lift_class_proj {K sort n cK} class sTs i.

Notation "T -F> S" :=
  (forall i, T i -> S i)
  (at level 30, only parsing, no associativity)
  : deriving_scope.

Notation "T *F S"  :=
  (fun i => T i * S i)%type
  (at level 20, only parsing, no associativity)
  : deriving_scope.

Set Universe Polymorphism.

Section Signature.

Import PolyType.

Variable n : nat.
Implicit Types (T S : fin n -> Type).

Variant arg := NonRec of Type | Rec of fin n.

Definition type_of_arg T (A : arg) : Type :=
  match A with
  | NonRec X => X
  | Rec i => T i
  end.

Definition type_of_arg_map T S (f : T -F> S) A :
  type_of_arg T A -> type_of_arg S A :=
  match A with
  | NonRec X => id
  | Rec i => f i
  end.

Definition is_rec A := if A is Rec _ then true else false.

Definition arity        := seq arg.
Definition signature    := seq arity.
Definition declaration  := fin n -> signature.

Identity Coercion seq_of_arity : arity >-> seq.
Identity Coercion seq_of_sig   : signature >-> seq.

Definition empty_decl : declaration :=
  fun _ => [::].

Definition add_arity (D : declaration) i As : declaration :=
  fun j => if leq_fin i j is inl _ then As :: D i
           else D j.

Definition add_arity_ind (P : fin n -> signature -> Type) D i As j :
  P i (As :: D i) -> P j (D j) -> P j (add_arity D i As j) :=
  fun H1 H2 =>
    match leq_fin i j
    as X
    return P j (if X is inl _ then As :: D i else D j) with
    | inl e => cast (fun k => P k (As :: D i)) e H1
    | inr _ => H2
    end.

Variables (K : Type) (sort : K -> Type).

Definition arg_class A :=
  if A is NonRec T then eq_class sort T else unit.

Record arg_inst := ArgInst {
  arg_inst_sort  :> arg;
  arg_inst_class :  arg_class arg_inst_sort
}.
Arguments ArgInst : clear implicits.

Definition arity_class (As : arity) :=
  hlist' arg_class As.

Record arity_inst := ArityInst {
  arity_inst_sort  :> arity;
  arity_inst_class :  arity_class arity_inst_sort;
}.
Arguments ArityInst : clear implicits.

Definition sig_class (Σ : signature) :=
  hlist' arity_class Σ.

Record sig_inst := SigInst {
  sig_inst_sort  :> signature;
  sig_inst_class :  sig_class sig_inst_sort;
}.
Arguments SigInst : clear implicits.

Record tagged_decl k := TaggedDecl {
  untag_decl :> fin k -> signature;
}.

Record decl_inst k := DeclInst {
  decl_inst_sort  :> tagged_decl k;
  _               :  forall i, sig_class (decl_inst_sort i)
}.
Arguments DeclInst : clear implicits.

Definition decl_inst_class k (d : decl_inst k) :
  forall i, sig_class (@decl_inst_sort k d i) :=
  let: DeclInst _ d := d in d.

Implicit Types (A : arg) (As : arity) (Σ : signature).
Implicit Types (Ai : arg_inst) (Asi : arity_inst) (Σi : sig_inst).

Canonical NonRec_arg_inst sX :=
  ArgInst (NonRec (sort sX)) (exist _ sX erefl).

Canonical Rec_arg_inst i :=
  ArgInst (Rec i) tt.

Canonical nth_fin_arg_inst Asi (i : fin (size Asi)) :=
  ArgInst (nth_fin i) (arity_inst_class Asi i).

Canonical nil_arity_inst :=
  ArityInst nil tt.

Canonical cons_arity_inst Ai Asi :=
  ArityInst (arg_inst_sort Ai :: arity_inst_sort Asi)
            (arg_inst_class Ai ::: arity_inst_class Asi).

Canonical nth_fin_arity_inst Σi (i : fin (size Σi)) :=
  ArityInst (nth_fin i) (sig_inst_class Σi i).

Canonical nil_sig_inst :=
  SigInst nil tt.

Canonical cons_sig_inst Asi Σi :=
  SigInst (arity_inst_sort Asi :: sig_inst_sort Σi)
          (arity_inst_class Asi ::: sig_inst_class Σi).

Definition nil_decl_tag k (D : fin k -> signature) := TaggedDecl D.
Canonical cons_decl_tag k (D : fin k -> signature) := nil_decl_tag D.

Canonical nil_decl_inst f :=
  DeclInst 0 (nil_decl_tag f) (fun i => match i with end).

Canonical cons_decl_inst k Σi Di
  (D : fun_split (sig_inst_sort Σi) (untag_decl (@decl_inst_sort k Di))) :=
  DeclInst k.+1
           (cons_decl_tag (fs_fun D))
           (fun i =>
              match i with
              | None => cast sig_class (fsE1 D) (sig_inst_class Σi)
              | Some i => cast sig_class (fsE2 D i) (@decl_inst_class k Di i)
              end).

Definition arity_rec (P : arity -> Type)
  (Pnil    : P [::])
  (PNonRec : forall (sX : K) (As : arity), P As -> P (NonRec (sort sX) :: As))
  (PRec    : forall i        (As : arity), P As -> P (Rec i            :: As)) :=
  fix arity_rec As : arity_class As -> P As :=
    match As with
    | [::]               => fun cAs =>
      Pnil
    | NonRec X :: As => fun cAs =>
      cast (fun X => P (NonRec X :: As)) (svalP cAs.(hd))
           (PNonRec (sval cAs.(hd)) As (arity_rec As cAs.(tl)))
    | Rec i :: As    => fun cAs =>
      PRec i As (arity_rec As cAs.(tl))
    end.

Lemma arity_ind (P : forall As, hlist' arg_class As -> Type)
  (Pnil : P [::] tt)
  (PNonRec : forall sX As cAs,
      P As cAs -> P (NonRec (sort sX) :: As) (exist _ sX erefl ::: cAs))
  (PRec : forall i As cAs,
      P As cAs -> P (Rec i :: As) (tt ::: cAs))
  As cAs : P As cAs.
Proof.
elim: As cAs=> [|[X|i] As IH] => /= [[]|[[xS e] cAs]|[[] cAs]] //.
  by case: X / e cAs => ?; apply: PNonRec.
by apply: PRec.
Qed.

End Signature.

#[global]
Hint Unfold type_of_arg : deriving.
#[global]
Hint Unfold type_of_arg_map : deriving.
#[global]
Hint Unfold is_rec : deriving.
#[global]
Hint Unfold arity : deriving.
#[global]
Hint Unfold signature : deriving.
#[global]
Hint Unfold declaration : deriving.
#[global]
Hint Unfold empty_decl : deriving.
#[global]
Hint Unfold add_arity : deriving.
#[global]
Hint Unfold add_arity_ind : deriving.
#[global]
Hint Unfold arg_class : deriving.
#[global]
Hint Unfold arg_inst_sort : deriving.
#[global]
Hint Unfold arg_inst_class : deriving.
#[global]
Hint Unfold arity_class : deriving.
#[global]
Hint Unfold arity_inst_sort : deriving.
#[global]
Hint Unfold arity_inst_class : deriving.
#[global]
Hint Unfold sig_class : deriving.
#[global]
Hint Unfold sig_inst_sort : deriving.
#[global]
Hint Unfold sig_inst_class : deriving.
#[global]
Hint Unfold untag_decl : deriving.
#[global]
Hint Unfold decl_inst_sort : deriving.
#[global]
Hint Unfold decl_inst_class : deriving.
#[global]
Hint Unfold NonRec_arg_inst : deriving.
#[global]
Hint Unfold Rec_arg_inst : deriving.
#[global]
Hint Unfold nth_fin_arg_inst : deriving.
#[global]
Hint Unfold nil_arity_inst : deriving.
#[global]
Hint Unfold cons_arity_inst : deriving.
#[global]
Hint Unfold nil_sig_inst : deriving.
#[global]
Hint Unfold cons_sig_inst : deriving.
#[global]
Hint Unfold nil_decl_tag : deriving.
#[global]
Hint Unfold cons_decl_tag : deriving.
#[global]
Hint Unfold nil_decl_inst : deriving.
#[global]
Hint Unfold cons_decl_inst : deriving.
#[global]
Hint Unfold arity_rec : deriving.

Definition arg_class_map
  n K1 K2 (sort1 : K1 -> Type) (sort2 : K2 -> Type)
  (f : K1 -> K2) (p : forall cT, sort2 (f cT) = sort1 cT) (A : arg n) :
  arg_class sort1 A -> arg_class sort2 A :=
  match A with
  | NonRec T => fun cT =>
    PolyType.exist _
      (f (PolyType.sval cT)) (p (PolyType.sval cT) * PolyType.svalP cT)
  | Rec i    => fun _  => tt
  end.

#[global]
Hint Unfold arg_class_map : deriving.

Definition pack_decl_inst
  n (D : declaration n) (Di : decl_inst n Equality.sort n)
  of phant_id D (untag_decl (decl_inst_sort Di)) := Di.

Unset Universe Polymorphism.

Arguments add_arity_ind {n} P D i As j H1 H2.
Arguments empty_decl {n}.
Arguments arity_rec {n K} _ _ _ _ _.

Module Ind.

Section Basic.

Variable n : nat.
Implicit Types (A : arg n) (As : arity n) (Σ : signature n).
Implicit Types (D : declaration n).
Implicit Types (T S : fin n -> Type).

Import PolyType.

Definition Cidx D i := fin (size (D i)).
Arguments Cidx : clear implicits.

Definition args D T i (j : Cidx D i) : Type :=
  hlist' (type_of_arg T) (nth_fin j).

Definition args_map D T S (f : T -F> S) i j (xs : @args D T i j) :
  args S j :=
  hmap' (type_of_arg_map f) xs.

Definition constructors D T :=
  forall (Ti : fin n) (Ci : Cidx D Ti),
    hfun' (type_of_arg T) (nth_fin Ci) (T Ti).

Definition empty_cons T : constructors empty_decl T :=
  fun Ti Ci => match Ci with end.

Definition add_cons D T (Cs : constructors D T) Ti As
  (C : hfun' (type_of_arg T) As (T Ti))
  : constructors (add_arity D Ti As) T :=
  fun Ti' =>
    add_arity_ind
      (fun Ti' Σ =>
         forall Ci : fin (size Σ),
           hfun' (type_of_arg T) (nth_fin Ci) (T Ti'))
      D Ti As Ti'
      (fun Ci => if Ci is Some Ci then Cs Ti Ci else C)
      (Cs Ti').

Fixpoint rec_branch' T S i As : Type :=
  match As with
  | NonRec X :: As => X          -> rec_branch' T S i As
  | Rec    j :: As => T j -> S j -> rec_branch' T S i As
  | [::]           => S i
  end.

Definition rec_branch D T S i (j : Cidx D i) : Type :=
  rec_branch' T S i (nth_fin j).

Definition recursor D T :=
  forall S, hfun2 (@rec_branch D T S) (hlist1 (fun i => T i -> S i)).

Fixpoint rec_branch'_of_hfun' T S i As :
  hfun' (type_of_arg (T *F S)) As (S i) -> rec_branch' T S i As :=
  match As with
  | NonRec R :: As => fun f x   => rec_branch'_of_hfun' (f x)
  | Rec    j :: As => fun f x y => rec_branch'_of_hfun' (f (x, y))
  | [::]           => fun f     => f
  end.

Fixpoint hfun'_of_rec_branch' T S i As :
  rec_branch' T S i As -> hfun' (type_of_arg (T *F S)) As (S i) :=
  match As with
  | NonRec R :: As => fun f x => hfun'_of_rec_branch' (f x)
  | Rec    j :: As => fun f p => hfun'_of_rec_branch' (f p.1 p.2)
  | [::]           => fun f   => f
  end.

Coercion hfun'_of_rec_branch' : rec_branch' >-> hfun'.

Lemma rec_branch_of_hfunK T S i As f xs :
  @rec_branch'_of_hfun' T S i As f xs = f xs.
Proof. by elim: As f xs => [|[R|j] As IH] f //= [[x y] xs]. Qed.

Definition recursor_eq D T (Cs : constructors D T) (r : recursor D T) :=
  forall S,
  all_hlist2 (fun bs : hlist2 (rec_branch T S) =>
  all_fin    (fun i  : fin n                   =>
  all_fin    (fun j  : Cidx D i                =>
  all_hlist  (fun xs : args T j                =>
    r S bs _ (Cs i j xs) =
    bs i j (args_map (fun k x => (x, r S bs k x)) xs))))).

Definition des_branch D T S i (j : Cidx D i) :=
  hfun' (type_of_arg T) (nth_fin j) (S i).

Definition destructor D T :=
  forall S, hfun2 (@des_branch D T S) (hlist1 (fun i => T i -> S i)).

Definition destructor_eq D T (Cs : constructors D T) (d : destructor D T) :=
  forall S,
  all_hlist2 (fun bs : hlist2 (des_branch T S) =>
  all_fin    (fun i  : fin n                   =>
  all_fin    (fun j  : Cidx D i                =>
  all_hlist  (fun xs : args T j                =>
    d S bs _ (Cs i j xs) = bs i j xs)))).

Definition rec_of_des_branch D T S i (j : Cidx D i) (b : des_branch T S j) :
  rec_branch T S j :=
  rec_branch'_of_hfun' (hcurry (fun xs => b (args_map (fun _ => fst) xs))).

Definition destructor_of_recursor D T (r : recursor D T) : destructor D T :=
  fun S => hcurry2 (fun bs : hlist2 (@des_branch D T S) =>
    r S (hmap2 (@rec_of_des_branch D T S) bs)).

Fixpoint ind_branch' T (P : forall i, T i -> Type) i As :
  hfun' (type_of_arg T) As (T i) -> Type :=
  match As with
  | NonRec R :: As => fun C => forall x : R,            ind_branch' P (C x)
  | Rec    j :: As => fun C => forall x : T j, P j x -> ind_branch' P (C x)
  | [::]           => fun C => P i C
  end.

Definition ind_branch D T P (Cs : constructors D T) i (j : Cidx D i) :=
  @ind_branch' T P i (nth_fin j) (Cs i j).

Definition induction D T (Cs : constructors D T) :=
  @hdfun n (fun i => T i -> Type) (fun P : hlist (fun i => T i -> Type) =>
  hfun2 (@ind_branch D T P Cs) (hlist1 (fun i => forall x, P i x))).

End Basic.

Module Def.

Set Primitive Projections.
Record class_of n sorts (decl : declaration n) := Class {
  Cons      : constructors decl sorts;
  rec       : recursor decl sorts;
  case      : destructor decl sorts;
  recE      : recursor_eq Cons rec;
  caseE     : destructor_eq Cons case;
  indP      : induction Cons;
}.

Record type := Pack {
  n : nat;
  sorts : fin n -> Type;
  decl : declaration n;
  class : class_of sorts decl;
}.
Unset Primitive Projections.

End Def.

Section ClassDef.

Set Primitive Projections.
Record mixin_of T := Mixin {
  def  : Def.type;
  idx  : fin (Def.n def);
  idxE : T = Def.sorts idx;
}.
Unset Primitive Projections.

Record type := Pack {sort : Type; _ : mixin_of sort}.
Local Coercion sort : type >-> Sortclass.
Local Notation class_of := mixin_of.

Variables (T : Type) (cT : type).
Definition class := let: Pack _ c as cT' := cT return class_of cT' in c.
Definition clone n Ts D cTs i iE :=
  let sTs := @Mixin T (@Def.Pack n Ts D cTs) i iE in
  fun & phant_id class sTs => @Pack T sTs.
Let xT := let: Pack T _ := cT in T.
Notation xclass := (class : class_of xT).

End ClassDef.

Notation class_of := mixin_of.

Module Exports.
Identity Coercion hdfun_of_induction : induction >-> hdfun.
Coercion Def.sorts : Def.type >-> Funclass.
Coercion Def.class : Def.type >-> Def.class_of.
Notation indDef := Def.type.
Notation IndDef := Def.Pack.
Coercion sort : type >-> Sortclass.
Coercion class : type >-> class_of.
Coercion def : class_of >-> indDef.
Notation indType := type.
Notation "[ 'indType' 'of' T ]" := (@clone T _ _ _ _ _ _ _ id)
  (at level 0, format "[ 'indType'  'of'  T ]") : form_scope.
End Exports.

End Ind.
Export Ind.Exports.

Arguments Ind.Def.decl : clear implicits.

Class find_idx n (Ts : fin n -> Type) (T : Type) i (e : T = Ts i) :=
  make_find_idx { }.
Arguments find_idx : clear implicits.
Arguments make_find_idx {_ _ _ _ _}.

Definition find_idx_here n (Ts : fin n.+1 -> Type) :
  find_idx n.+1 Ts (Ts None) None erefl := make_find_idx.

Definition find_idx_there n (Ts : fin n.+1 -> Type) T i e
  (_ : find_idx n (fun i => Ts (Some i)) T i e) :
  find_idx n.+1 Ts T (Some i) e :=
  make_find_idx.

#[global]
Hint Extern 1 (find_idx ?m ?Ts ?T _ _) =>
  match eval hnf in m with
  | ?n.+1 => eapply (@find_idx_here n Ts)
  end : typeclass_instances.

#[global]
Hint Extern 2 (find_idx ?m ?Ts ?T _ _) =>
  match eval hnf in m with
  | ?n.+1 => eapply (@find_idx_there n Ts)
  end : typeclass_instances.

Definition pack_indType
  T (Ts : indDef) i e
  of find_idx (Ind.Def.n Ts) Ts T i e :=
  Ind.Pack (@Ind.Mixin T Ts i e).

Notation IndType T Ts := (@pack_indType T Ts _ _ _).

#[global]
Hint Unfold Ind.Cidx : deriving.
#[global]
Hint Unfold Ind.args : deriving.
#[global]
Hint Unfold Ind.args_map : deriving.
#[global]
Hint Unfold Ind.constructors : deriving.
#[global]
Hint Unfold Ind.empty_cons : deriving.
#[global]
Hint Unfold Ind.add_cons : deriving.
#[global]
Hint Unfold Ind.rec_branch' : deriving.
#[global]
Hint Unfold Ind.rec_branch : deriving.
#[global]
Hint Unfold Ind.recursor : deriving.
#[global]
Hint Unfold Ind.rec_branch'_of_hfun' : deriving.
#[global]
Hint Unfold Ind.hfun'_of_rec_branch' : deriving.
#[global]
Hint Unfold Ind.recursor_eq : deriving.
#[global]
Hint Unfold Ind.des_branch : deriving.
#[global]
Hint Unfold Ind.destructor : deriving.
#[global]
Hint Unfold Ind.destructor_eq : deriving.
#[global]
Hint Unfold Ind.rec_of_des_branch : deriving.
#[global]
Hint Unfold Ind.destructor_of_recursor : deriving.
#[global]
Hint Unfold Ind.ind_branch' : deriving.
#[global]
Hint Unfold Ind.ind_branch : deriving.
#[global]
Hint Unfold Ind.induction : deriving.
#[global]
Hint Unfold Ind.Def.Cons : deriving.
#[global]
Hint Unfold Ind.Def.rec : deriving.
#[global]
Hint Unfold Ind.Def.case : deriving.
#[global]
Hint Unfold Ind.Def.n : deriving.
#[global]
Hint Unfold Ind.Def.sorts : deriving.
#[global]
Hint Unfold Ind.Def.decl : deriving.
#[global]
Hint Unfold Ind.Def.class : deriving.
#[global]
Hint Unfold Ind.class : deriving.
#[global]
Hint Unfold Ind.def : deriving.
#[global]
Hint Unfold Ind.idx : deriving.
#[global]
Hint Unfold Ind.idxE : deriving.
#[global]
Hint Unfold Ind.sort : deriving.
#[global]
Hint Unfold Ind.clone : deriving.
#[global]
Hint Unfold find_idx_here : deriving.
#[global]
Hint Unfold find_idx_there : deriving.
#[global]
Hint Unfold pack_indType : deriving.

Module IndF.

Section FunctorDef.

Variables (n : nat) (D : declaration n).

Implicit Types (T S : fin n -> Type).

Notation size := PolyType.size.

Record fobj T (i : fin n) := Cons {
  constr : Ind.Cidx D i;
  args : hlist' (type_of_arg T) (nth_fin constr)
}.

Arguments Cons {_ i} _ _.

Local Notation F := fobj.

Definition fmap T S (f : T -F> S) i (x : F T i) : F S i :=
  Cons (constr x) (hmap' (type_of_arg_map f) (args x)).

Lemma fmap_eq T S (f g : T -F> S) :
  (forall i x, f i x = g i x) ->
  (forall i (x : F T i), fmap f x = fmap g x).
Proof.
move=> e i [j args]; congr Cons; apply: hmap_eq => /= k.
by case: (nth_fin k).
Qed.

Lemma fmap1 T i : @fmap T T (fun _ => id) i =1 id.
Proof.
move=> [j args] /=; congr Cons; rewrite -[RHS]hmap1.
by apply: hmap_eq=> /= k; case: (nth_fin k).
Qed.

Lemma fmap_comp T S R (f : T -F> S) (g : S -F> R) i :
  @fmap _ _ (fun j x => g j (f j x)) i =1
  @fmap _ _ g i \o @fmap _ _ f i.
Proof.
move=> [j args] /=; congr Cons; rewrite /= /hmap' hmap_comp.
by apply: hmap_eq=> /= k; case: (nth_fin k).
Qed.

Lemma inj T (i : fin n) (j : Ind.Cidx D i)
  (a b : hlist' (type_of_arg T) (nth_fin j)) :
  Cons j a = Cons j b -> a = b.
Proof.
pose get x :=
  if leq_fin (constr x) j is inl e then
    cast (fun j : Ind.Cidx D i =>
            hlist' (type_of_arg T) (nth_fin j)) e (args x)
  else a.
by move=> /(congr1 get); rewrite /get /= leq_finii /=.
Qed.

End FunctorDef.

Section TypeDef.

Variable (T : indDef).

Notation D := (Ind.Def.decl T).
Notation F := (@fobj _ D).

Arguments Cons {n D T i} _ _.

Definition Roll i (x : F T i) : T i :=
  @Ind.Def.Cons _ _ _ T i (constr x) (args x).

Definition rec_branches_of_fun S (body : F (T *F S) -F> S) :
  hlist2 (@Ind.rec_branch _ D T S) :=
  hlist_of_fun (fun i =>
  hlist_of_fun (fun j : Ind.Cidx D i =>
    Ind.rec_branch'_of_hfun'
      (hcurry
         (fun l => body i (Cons j l))))).

Definition rec S (body : F (T *F S) -F> S) :=
  @Ind.Def.rec _ _ _ T S (rec_branches_of_fun body).

Definition lift_type R i : fin (Ind.Def.n T) -> Type :=
  fun j => if leq_fin i j is inl e then R else unit.

Definition lift_typeE R i : lift_type R i i = R :=
  congr1 (fun r => if r is inl e then R else unit) (leq_finii i).

Definition lift_type_of R i j (f : i = j -> R) : lift_type R i j :=
  match leq_fin i j
  as r
  return if r is inl e then R else unit
  with
  | inl e => f e
  | inr _ => tt
  end.

Definition des_branches_of_fun i R (body : F T i -> R) :
  hlist2 (@Ind.des_branch _ D T (lift_type R i)) :=
  hlist_of_fun (fun i' =>
  hlist_of_fun (fun j : Ind.Cidx D i' =>
    hcurry (fun l => @lift_type_of R i i' (fun e => body (cast (F T) e^-1 (Cons j l)))))).

Definition case i R (body : F T i -> R) x :=
  cast id (lift_typeE R i)
    (@Ind.Def.case _ _ _ T _ (des_branches_of_fun body) i x).

Lemma recE S f i (a : F T i) :
  @rec S f i (Roll a) =
  f i (fmap (fun j (x : T j) => (x, rec f j x)) a).
Proof.
case: a=> [j args]; have := Ind.Def.recE T S.
move/all_hlist2P/(_ (rec_branches_of_fun f)).
move/all_finP/(_ i).
move/all_finP/(_ j).
move/all_hlistP/(_ args).
rewrite /rec_branches_of_fun hnth_of_fun.
rewrite /rec /Roll => -> /=.
by rewrite /= hnth_of_fun Ind.rec_branch_of_hfunK hcurryK.
Qed.

Lemma caseE i R f (a : F T i) : case f (Roll a) = f a :> R.
Proof.
case: a => [j args]; have := Ind.Def.caseE T (lift_type R i).
move/all_hlist2P/(_ (des_branches_of_fun f)).
move/all_finP/(_ i).
move/all_finP/(_ j).
move/all_hlistP/(_ args).
rewrite /des_branches_of_fun hnth_of_fun.
rewrite /case /Roll => -> /=.
rewrite /lift_type /lift_typeE /lift_type_of hnth_of_fun hcurryK /=.
case: (leq_fin i i) (leq_finii i)=> // e.
rewrite (eq_axiomK e) => {}e.
by rewrite (eq_axiomK e) /=.
Qed.

Lemma indP P :
  (forall i (a : F (fun j => {x & P j x}) i),
    P i (Roll (fmap (fun _ => tag) a))) ->
  forall i x, P i x.
Proof.
move=> IH.
pose Q := hlist_of_fun P.
pose Q_of_P i a : P i a -> Q i a :=
  cast id (congr1 (fun F => F a) (hnth_of_fun P i))^-1.
pose P_of_Q i a : Q i a -> P i a :=
  cast id (congr1 (fun F => F a) (hnth_of_fun P i)).
pose TP_of_TQ i x := Tagged (P i) (P_of_Q i (tag x) (tagged x)).
have Q_of_PK i a : cancel (Q_of_P i a) (P_of_Q i a) := castKV _.
have P_of_QK i a : cancel (P_of_Q i a) (Q_of_P i a) := castK  _.
have {}IH i (a : F (fun j => {x & Q j x}) i) :
    Q i (Roll (fmap (fun _ => tag) a)).
  rewrite (_ : fmap _ a = fmap (fun _ => tag) (fmap TP_of_TQ a)); last first.
    by rewrite -[RHS]fmap_comp; apply: fmap_eq=> ? [].
  by apply: (Q_of_P); apply: IH.
move=> i x {P_of_QK Q_of_PK Q_of_P TP_of_TQ}; apply: P_of_Q.
move: {P} Q IH i x.
rewrite /Roll; case: (T) => n S D [/= Cs _ _ _ _ indP] P.
have {}indP :
    (forall i j, Ind.ind_branch' P (Cs i j)) ->
    (forall i x, P i x).
  move=> hyps i x.
  pose bs : hlist2 (Ind.ind_branch P Cs) :=
    hlist_of_fun (fun i => hlist_of_fun (fun j => hyps i j)).
  exact: (hdapp indP P bs i x).
move=> hyps; apply: indP=> i j.
have {}hyps:
  forall args : hlist' (type_of_arg (fun k => {x & P k x})) (nth_fin j),
    P i (Cs i j (hmap' (type_of_arg_map (fun _ => tag)) args)).
  by move=> args; move: (hyps i (Cons j args)).
move: (Cs i j) hyps; rewrite /fnth.
elim: (nth_fin j)=> [|[R|k] As IH] /=.
- by move=> C /(_ tt).
- move=> C hyps x; apply: IH=> args; exact: (hyps (x ::: args)).
- move=> constr hyps x H; apply: IH=> args.
  exact: (hyps (existT _ x H ::: args)).
Qed.

Definition unroll i := @case i _ id.

Lemma RollK i : cancel (@Roll i) (@unroll i).
Proof. by move=> x; rewrite /unroll caseE. Qed.

Lemma Roll_inj i : injective (@Roll i).
Proof. exact: can_inj (@RollK i). Qed.

Lemma unrollK i : cancel (@unroll i) (@Roll i).
Proof. by elim/indP: i / => i a; rewrite RollK. Qed.

Lemma unroll_inj i : injective (@unroll i).
Proof. exact: can_inj (@unrollK i). Qed.

End TypeDef.

End IndF.

#[global]
Hint Unfold IndF.constr : deriving.
#[global]
Hint Unfold IndF.args : deriving.
#[global]
Hint Unfold IndF.fmap : deriving.
#[global]
Hint Unfold IndF.Roll : deriving.
#[global]
Hint Unfold IndF.rec_branches_of_fun : deriving.
#[global]
Hint Unfold IndF.rec : deriving.
#[global]
Hint Unfold IndF.lift_type : deriving.
#[global]
Hint Unfold IndF.lift_typeE : deriving.
#[global]
Hint Unfold IndF.lift_type_of : deriving.
#[global]
Hint Unfold IndF.des_branches_of_fun : deriving.
#[global]
Hint Unfold IndF.case : deriving.
#[global]
Hint Unfold IndF.unroll : deriving.

Section InferInstances.

Import PolyType.

Class infer_arity
  n (T : fin n -> Type) (P : forall i, T i -> Type)
  (branchT : Type) (As : arity n) (i : fin n)
  (C : hfun' (type_of_arg T) As (T i)) : Type.
Arguments infer_arity : clear implicits.

Instance infer_arity_end
  n T P i (x : T i) :
  infer_arity n T P (P i x) [::] i x.
Defined.

Instance infer_arity_rec
  n Ts P j
  (branchT : Ts j -> Type)
  i (As : arity n)
  (C : Ts j -> hfun' (type_of_arg Ts) As (Ts i))
  (_ : forall x, infer_arity n Ts P (branchT x) As i (C x)) :
  infer_arity n Ts P (forall x, P j x -> branchT x) (Rec j :: As) i C.
Defined.

Instance infer_arity_nonrec
  n T P S
  (branchT : S -> Type) i As (C : S -> hfun' (type_of_arg T) As (T i))
  (_ : forall x, infer_arity n T P (branchT x) As i (C x)) :
  infer_arity n T P (forall x, branchT x) (NonRec n S :: As) i C.
Defined.

Class infer_decl
  n T (P : forall i, T i -> Type)
  (elimT : Type) (D : declaration n) (Cs : Ind.constructors D T) : Type.
Arguments infer_decl : clear implicits.

Global Instance infer_decl_end n T P :
  infer_decl n T P
             (hlist1 (fun i => forall (x : T i), P i x))
             empty_decl
             (@Ind.empty_cons _ _).
Defined.

Global Instance infer_decl_cons n T P
  (branchT : Type) Ti As C
  (_ : infer_arity n T P branchT As Ti C)
  (elimT : Type) D Cs
  (_ : infer_decl n T P elimT D Cs)
  : infer_decl n T P (branchT -> elimT) (add_arity D Ti As) (Ind.add_cons Cs C).
Defined.

Class read_rect (rectT : Type) (rect : rectT)
  (n : nat) (Ts : fin n -> Type)
  (rectT' : (forall i, Ts i -> Type) -> Type)
  (rect' : forall Ps, rectT' Ps).
Arguments read_rect : clear implicits.

Global Instance read_rect_type
  (T : Type) (rectT : (T -> Type) -> Type) (rect : forall P, rectT P)
  n Ts rectT' rect'
  (_ : forall P, read_rect (rectT P) (rect P) n Ts (rectT' P) (rect' P))
  : read_rect (forall P, rectT P) rect n.+1
              (fcons T Ts)
              (fun Ps => rectT' (Ps None) (fun i => Ps (Some i)))
              (fun Ps => rect' (Ps None) (fun i => Ps (Some i))) | 1.
Defined.

Global Instance read_rect_done rectT rect :
  read_rect rectT rect 0 (fnil Type) (fun _ => rectT) (fun _ => rect) | 2.
Defined.

Class bless_rect
  n Ts (D : declaration n) (Cs : Ind.constructors D Ts)
  (rectT : (forall i, Ts i -> Type) -> Type)
  (rect  : forall P, rectT P)
  (rect' : Ind.recursor D Ts).
Arguments bless_rect : clear implicits.

Class infer_ind rectT (rect : rectT)
  n Ts (D : declaration n) (Cs : Ind.constructors D Ts)
  (rectT' : (forall i, Ts i -> Type) -> Type) (rect' : forall P, rectT' P)
  (rect'' : Ind.recursor D Ts).
Arguments infer_ind : clear implicits.

Global Instance do_infer_ind rectT rect
  n Ts rectT' rect'
  (_ : read_rect rectT rect n Ts rectT' rect')
  D Cs
  (_ : forall P, infer_decl n Ts P (rectT' P) D Cs)
  rect''
  (_ : bless_rect n Ts D Cs rectT' rect' rect'')
  : infer_ind rectT rect n Ts D Cs rectT' rect' rect''.
Defined.

End InferInstances.

Arguments infer_arity : clear implicits.
Arguments infer_decl : clear implicits.
Arguments read_rect : clear implicits.
Arguments bless_rect : clear implicits.
Arguments infer_ind : clear implicits.

#[global]
Hint Unfold infer_arity_end : deriving.
#[global]
Hint Unfold infer_arity_rec : deriving.
#[global]
Hint Unfold infer_arity_nonrec : deriving.
#[global]
Hint Unfold infer_decl_end : deriving.
#[global]
Hint Unfold infer_decl_cons : deriving.
#[global]
Hint Unfold read_rect_type : deriving.
#[global]
Hint Unfold read_rect_done : deriving.
#[global]
Hint Unfold do_infer_ind : deriving.

Ltac infer_arity :=
  cbv beta;
  match goal with
  | |- infer_arity ?n ?Ts ?Ps (?Ps ?i ?x) _ _ _ =>
    exact (@infer_arity_end n Ts Ps i x)
  | |- infer_arity ?n ?Ts ?Ps (forall x, ?Ps ?j x -> @?branchT x) _ _ _ =>
    eapply (@infer_arity_rec n Ts Ps j branchT)
  | |- infer_arity ?n ?Ts ?Ps (forall x : ?S, @?branchT x) _ _ _ =>
    eapply (@infer_arity_nonrec n Ts Ps S branchT)
  end.

#[global]
Hint Extern 0 (infer_arity _ _ _ _ _ _ _) => infer_arity : typeclass_instances.

Ltac infer_decl :=
  cbv beta;
  match goal with
  | |- infer_decl ?n ?Ts ?Ps (?branchT -> ?rectT) _ _ =>
    eapply (@infer_decl_cons n Ts Ps branchT _ _ _ _ rectT)
  | |- infer_decl ?n ?Ts ?Ps _ _ _ =>
    eapply (@infer_decl_end n Ts Ps)
  end.

#[global]
Hint Extern 0 (infer_decl _ _ _ _ _ _) => infer_decl : typeclass_instances.

Ltac bless_rect :=
  cbv beta;
  match goal with
  | |- bless_rect ?n ?Ts ?D ?Cs ?rectT ?rect _ =>
     exact (@Build_bless_rect n Ts D Cs rectT rect
                             (fun P => rect (fun i _ => P i)))
  end.

#[global]
Hint Extern 0 (bless_rect _ _ _ _ _ _ _) => bless_rect : typeclass_instances.

Module IndEqType.

Record type := Pack {
  n         : nat;
  sorts     : fin n -> Type;
  decl      : declaration n;
  eq_class  : forall i, Equality.class_of (sorts i);
  ind_class : Ind.Def.class_of sorts decl;
}.

Definition eqType T i := Equality.Pack (@eq_class T i).
Definition indDef T := Ind.Def.Pack (ind_class T).

Module Import Exports.
Notation indEqType := type.
Notation IndEqType := Pack.
Coercion sorts : type >-> Funclass.
Canonical eqType.
Coercion indDef : type >-> Ind.Def.type.
Canonical indDef.
End Exports.

End IndEqType.

Export IndEqType.Exports.

#[global]
Hint Unfold IndEqType.n : deriving.
#[global]
Hint Unfold IndEqType.sorts : deriving.
#[global]
Hint Unfold IndEqType.decl : deriving.
#[global]
Hint Unfold IndEqType.eq_class : deriving.
#[global]
Hint Unfold IndEqType.ind_class : deriving.
#[global]
Hint Unfold IndEqType.eqType : deriving.
#[global]
Hint Unfold IndEqType.indDef : deriving.

Module IndChoiceType.

Record type := Pack {
  n            : nat;
  sorts        : fin n -> Type;
  decl         : declaration n;
  choice_class : forall i, Choice.class_of (sorts i);
  ind_class    : Ind.Def.class_of sorts decl;
}.

Definition eqType T i := Equality.Pack (@choice_class T i).
Definition choiceType T i := Choice.Pack (@choice_class T i).
Definition indDef T := Ind.Def.Pack (ind_class T).

Module Import Exports.
Notation indChoiceType := type.
Notation IndChoiceType := Pack.
Coercion sorts : type >-> Funclass.
Canonical eqType.
Canonical choiceType.
Coercion indDef : type >-> Ind.Def.type.
Canonical indDef.
End Exports.

End IndChoiceType.

Export IndChoiceType.Exports.

#[global]
Hint Unfold IndChoiceType.n : deriving.
#[global]
Hint Unfold IndChoiceType.sorts : deriving.
#[global]
Hint Unfold IndChoiceType.decl : deriving.
#[global]
Hint Unfold IndChoiceType.choice_class : deriving.
#[global]
Hint Unfold IndChoiceType.ind_class : deriving.
#[global]
Hint Unfold IndChoiceType.eqType : deriving.
#[global]
Hint Unfold IndChoiceType.choiceType : deriving.
#[global]
Hint Unfold IndChoiceType.indDef : deriving.

Module IndCountType.

Record type := Pack {
  n           : nat;
  sorts       : fin n -> Type;
  decl        : declaration n;
  count_class : forall i, Countable.class_of (sorts i);
  ind_class   : Ind.Def.class_of sorts decl;
}.

Definition eqType T i := Equality.Pack (@count_class T i).
Definition choiceType T i := Choice.Pack (@count_class T i).
Definition countType T i := Countable.Pack (@count_class T i).
Definition indDef T := Ind.Def.Pack (ind_class T).

Module Import Exports.
Notation indCountType := type.
Notation IndCountType := Pack.
Coercion sorts : type >-> Funclass.
Canonical eqType.
Canonical choiceType.
Canonical countType.
Coercion indDef : type >-> Ind.Def.type.
Canonical indDef.
End Exports.

End IndCountType.

Export IndCountType.Exports.

#[global]
Hint Unfold IndCountType.n : deriving.
#[global]
Hint Unfold IndCountType.sorts : deriving.
#[global]
Hint Unfold IndCountType.decl : deriving.
#[global]
Hint Unfold IndCountType.count_class : deriving.
#[global]
Hint Unfold IndCountType.ind_class : deriving.
#[global]
Hint Unfold IndCountType.eqType : deriving.
#[global]
Hint Unfold IndCountType.choiceType : deriving.
#[global]
Hint Unfold IndCountType.countType : deriving.
#[global]
Hint Unfold IndCountType.indDef : deriving.


(** printing |-#    %\vdash_{\#}%    #⊢##     *)
(** printing |-##   %\vdash_{\#\#}%  #⊢&#35&#35#  *)
(** printing |-##v  %\vdash_{\#\#v}% #⊢&#35&#35v# *)
(** printing |-!    %\vdash_!%       #⊢!#         *)
(** remove printing ~ *)

Set Implicit Arguments.

Require Import ConstrLangAlt ConstrInterp ConstrEntailment Definitions Subenvironments RecordAndInertTypes.

(** * Typing Rules *)

Reserved Notation "e '⊢c' t ':' T" (at level 39, t at level 59).
Reserved Notation "e '/-c' d : D" (at level 39, d at level 59).
Reserved Notation "e '/-c' ds :: D" (at level 39, ds at level 59).
Reserved Notation "e '⊢c' T '<:' U" (at level 39, T at level 59).

(** ** Term typing [G ⊢c t: T] *)
Inductive cty_trm : (constr * ctx) -> trm -> typ -> Prop :=

(** [G(x) = T]  #
#
    [――――――――]  #
#
    [C, G ⊢c x: T]  *)
| cty_var : forall C G x T,
    binds x T G ->
    (C, G) ⊢c trm_var (avar_f x) : T

(** [C, (G, x: T) ⊢c t^x: U^x]     #
#
    [x fresh]                #
#
    [――――――――――――――――――――――] #
#
    [C, G ⊢c lambda(T)t: forall(T)U]      *)
| cty_all_intro : forall L C G T t U,
    (forall x, x \notin L ->
      (C, G & x ~ T) ⊢c open_trm x t : open_typ x U) ->
    (C, G) ⊢c trm_val (val_lambda T t) : typ_all T U

(** [C, G ⊢c x: forall(S)T] #
#
    [C, G ⊢c z: S]     #
#
    [――――――――――――] #
#
    [C, G ⊢c x z: T^z]     *)
| cty_all_elim : forall C G x z S T,
    (C, G) ⊢c trm_var (avar_f x) : typ_all S T ->
    (C, G) ⊢c trm_var (avar_f z) : S ->
    (C, G) ⊢c trm_app (avar_f x) (avar_f z) : open_typ z T

(** [C, (G, x: T^x) ⊢ ds^x :: T^x]  #
#
    [x fresh]                  #
#
    [―――――――――――――――――――――――]  #
#
    [C, G ⊢ nu(T)ds :: mu(T)]          *)
| cty_new_intro : forall L C G T ds,
    (forall x, x \notin L ->
      (C, G & (x ~ open_typ x T)) /-c open_defs x ds :: open_typ x T) ->
    (C, G) ⊢c trm_val (val_new T ds) : typ_bnd T

(** [C, G ⊢c x: {a: T}] #
#
    [―――――――――――――] #
#
    [C, G ⊢c x.a: T]        *)
| cty_new_elim : forall C G x a T,
    (C, G) ⊢c trm_var (avar_f x) : typ_rcd (dec_trm a T) ->
    (C, G) ⊢c trm_sel (avar_f x) a : T

(** [C, G ⊢c t: T]          #
#
    [C, G, x: T ⊢c u^x: U]  #
#
    [x fresh]           #
#
    [―――――――――――――――――] #
#
    [C, G ⊢c let t in u: U]     *)
| cty_let : forall L C G t u T U,
    (C, G) ⊢c t : T ->
    (forall x, x \notin L ->
      (C, G & x ~ T) ⊢c open_trm x u : U) ->
    (C, G) ⊢c trm_let t u : U

(** [C, G ⊢c x: T^x]   #
#
    [――――――――――――] #
#
    [C, G ⊢c x: mu(T)]     *)
| cty_rec_intro : forall C G x T,
    (C, G) ⊢c trm_var (avar_f x) : open_typ x T ->
    (C, G) ⊢c trm_var (avar_f x) : typ_bnd T

(** [C, G ⊢c x: mu(T)] #
#
    [――――――――――――] #
#
    [C, G ⊢c x: T^x]   *)
| cty_rec_elim : forall C G x T,
    (C, G) ⊢c trm_var (avar_f x) : typ_bnd T ->
    (C, G) ⊢c trm_var (avar_f x) : open_typ x T

(** [C, G ⊢c x: T]     #
#
    [C, G ⊢c x: U]     #
#
    [――――――――――――] #
#
    [C, G ⊢c x: T /\ U]     *)
| cty_and_intro : forall C G x T U,
    (C, G) ⊢c trm_var (avar_f x) : T ->
    (C, G) ⊢c trm_var (avar_f x) : U ->
    (C, G) ⊢c trm_var (avar_f x) : typ_and T U

(** [C, G ⊢c t: T]   #
#
    [C ⊩ S <: T] #
#
    [――――――――――] #
#
    [C, G ⊢c t: U]   *)
| cty_sub : forall C G t T U,
    (C, G) ⊢c t : T ->
    (C, G) ⊢c T <: U ->
    (C, G) ⊢c t : U
where "e '⊢c' t ':' T" := (cty_trm e t T)

(** ** Single-definition typing [G ⊢ d: D] *)
with cty_def : (constr * ctx) -> def -> dec -> Prop :=
(** [C, G ⊢c {A = T}: {A: T..T}]   *)
| cty_def_typ : forall C G A T,
    (C, G) /-c def_typ A T : dec_typ A T T

(** [C, G ⊢c t: T]            #
#
    [―――――――――――――――――――] #
#
    [C, G ⊢c {a = t}: {a: T}] *)
| cty_def_trm : forall C G a t T,
    (C, G) ⊢c t : T ->
    (C, G) /-c def_trm a t : dec_trm a T
where "e '/-c' d ':' D" := (cty_def e d D)

(** ** Multiple-definition typing [G ⊢ ds :: T] *)
with cty_defs : (constr * ctx) -> defs -> typ -> Prop :=
(** [C, G ⊢c d: D]              #
#
    [―――――――――――――――――――――] #
#
    [C, G ⊢c d ++ defs_nil : D] *)
| cty_defs_one : forall C G d D,
    (C, G) /-c d : D ->
    (C, G) /-c defs_cons defs_nil d :: typ_rcd D

(** [C, G ⊢c ds :: T]         #
#
    [C, G ⊢c d: D]            #
#
    [d \notin ds]         #
#
    [―――――――――――――――――――] #
#
    [C, G ⊢c ds ++ d : T /\ D] *)
| cty_defs_cons : forall C G ds d T D,
    (C, G) /-c ds :: T ->
    (C, G) /-c d : D ->
    defs_hasnt ds (label_of_def d) ->
    (C, G) /-c defs_cons ds d :: typ_and T (typ_rcd D)
where "e '/-c' ds '::' T" := (cty_defs e ds T)

with csubtyp : (constr * ctx) -> typ -> typ -> Prop :=
(** [C, G ⊢c x: S]   #
#
    [C ⋏ x: S, G ⊢c T <: U] #
#
    [――――――――――] #
#
    [C, G ⊢c T <: U]   *)
| csubtyp_intro : forall C G x S S' T U,
    S ⩭ S' ->
    binds x S' G ->
    (C ⋏ ctrm_cvar (cvar_x (avar_f x)) ⦂ S, G) ⊢c T <: U ->
    (C, G) ⊢c T <: U
(** [C ⊩ T <: U]   #
#
    [――――――――――]   #
#
    [C, G ⊢c T <: U]   *)
| csubtyp_inst : forall C G S S' T T',
    S ⩭ S' ->
    T ⩭ T' ->
    C ⊩ S <⦂ T ->
    (C, G) ⊢c S' <: T'
where "e '⊢c' T '<:' U" := (csubtyp e T U).

Hint Constructors cty_trm cty_def cty_defs csubtyp.

Scheme cts_ty_trm_mut := Induction for cty_trm Sort Prop
with   cts_subtyp     := Induction for csubtyp Sort Prop.
Combined Scheme cts_mutind from cts_ty_trm_mut, cts_subtyp.

Scheme crules_trm_mut    := Induction for cty_trm Sort Prop
with   crules_def_mut    := Induction for cty_def Sort Prop
with   crules_defs_mut   := Induction for cty_defs Sort Prop
with   crules_subtyp     := Induction for csubtyp Sort Prop.
Combined Scheme crules_mutind from crules_trm_mut, crules_def_mut, crules_defs_mut, crules_subtyp.

(** ** Well-typed programs *)
Definition compatible_constr C G t T :=
  exists tm vm, (tm, vm, G) ⊧ C /\ (C, G) ⊢c t: T.

(* (** ⊤, (x: {A: {X: ⊥..T1}..{X: ⊥..T2}}, y: T1) ⊢c y: T2 *) *)
(* Lemma typing_example1 : forall G x y A X T1 T2, *)
(*     binds x *)
(*           (typ_rcd *)
(*              (dec_typ A *)
(*                       (typ_rcd (dec_typ X typ_bot T1)) *)
(*                       (typ_rcd (dec_typ X typ_bot T2)))) *)
(*           G -> *)
(*     binds y T1 G -> *)
(*     ⊤, G ⊢c trm_var (avar_f y) : T2. *)
(* Proof. *)
(*   introv Hx Hy. *)
(*   eapply ty_constr_intro with (t := trm_var (avar_f x)). *)
(*   - constructor*. *)
(*   - apply ty_sub with (T := T1). *)
(*     -- constructor*. *)
(*     -- eapply ent_trans. *)
(*        + apply ent_and_right. *)
(*        + eapply ent_trans. apply ent_exists_v_intro'. *)
(*          eapply ent_trans. apply ent_cong_exists_v. *)
(*          2: { *)
(*            eapply ent_trans. *)
(*            eapply ent_bound_sub. *)
(*            eapply ent_trans. apply ent_and_right. *)
(*            eapply ent_trans. eapply ent_inv_subtyp_typ. *)
(*            apply ent_and_right. *)
(*          } *)
(*          simpl_open_constr. introv Heqc Heqd. subst C' D'. *)
(*          eapply ent_and_intro. apply ent_refl. *)
(* Qed. *)

(** [G ⊢ ds :: U]                          #
#
    [U] is a record type with labels [ls]  #
#
    [ds] are definitions with label [ls']  #
#
    [l \notin ls']                          #
#
    [―――――――――――――――――――――――――――――――――――]  #
#
    [l \notin ls] *)
Lemma constr_hasnt_notin : forall C G ds ls l U,
    (C, G) /-c ds :: U ->
    record_typ U ls ->
    defs_hasnt ds l ->
    l \notin ls.
Proof.

  Ltac inversion_def_typ :=
    match goal with
    | [ H: _ /-c _ : _ |- _ ] => inversions H
    end.

  introv Hds Hrec Hhasnt.
  inversions Hhasnt. gen ds. induction Hrec; intros; inversions Hds.
  - inversion_def_typ; simpl in *; case_if; apply* notin_singleton.
  - apply notin_union; split; simpl in *.
    + apply* IHHrec. case_if*.
    + inversion_def_typ; case_if; apply* notin_singleton.
Qed.

(** The type of definitions is a record type. *)
Lemma cty_defs_record_type : forall C G ds T,
    (C, G) /-c ds :: T ->
    record_type T.
Proof.
 intros. induction H; destruct D;
    repeat match goal with
        | [ H: record_type _ |- _ ] =>
          destruct H
        | [ Hd: _ /-c _ : dec_typ _ _ _ |- _ ] =>
          inversions Hd
        | [ Hd: _ /-c _ : dec_trm _ _ |- _ ] =>
          inversions Hd
    end;
    match goal with
    | [ ls: fset label,
        t: trm_label |- _ ] =>
      exists (ls \u \{ label_trm t })
    | [ ls: fset label,
        t: typ_label |- _ ] =>
      exists (ls \u \{ label_typ t })
    | [ t: trm_label |- _ ] =>
      exists \{ label_trm t }
    | [ t: typ_label |- _ ] =>
      exists \{ label_typ t }
    end;
    constructor*; try constructor; apply (constr_hasnt_notin H); eauto.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Construction and coloring of the interference graph. *)

Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import RTLtyping.
Require Import Locations.
Require Import Conventions.
Require Import InterfGraph.

(** * Construction of the interference graph *)

(** Two registers interfere if there exists a program point where
    they are both simultaneously live, and it is possible that they
    contain different values at this program point.  Consequently,
    two registers that do not interfere can be merged into one register
    while preserving the program behavior: there is no program point
    where this merged register would have to hold two different values
    (for the two original registers), so to speak.

    The simplified algorithm for constructing the interference graph
    from the results of the liveness analysis is as follows:
<<
     start with empty interference graph
     for each parameter p and register r live at the function entry point:
         add conflict edge p <-> r
     for each instruction I in function:
         let L be the live registers "after" I
         if I is a "move" instruction  dst <- src, and dst is live:
            add conflict edges dst <-> r for each r in L \ {dst, src}
         else if I is an instruction with result dst, and dst is live:
            add conflict edges dst <-> r for each r in L \ {dst};
         if I is a "call" instruction dst <- f(args),
            add conflict edges between all pseudo-registers in L \ {dst}
            and all caller-save machine registers
     done
>>
    Notice that edges are added only when a register becomes live.
    A register becomes live either if it is the result of an operation
    (and is live afterwards), or if we are at the function entrance
    and the register is a function parameter.  For two registers to
    be simultaneously live at some program point, it must be the case
    that one becomes live at a point where the other is already live.
    Hence, it suffices to add interference edges between registers
    that become live at some instruction and registers that are already
    live at this instruction.

    Notice also the special treatment of ``move'' instructions:
    since the destination register of the ``move'' is assigned the same value
    as the source register, it is semantically correct to assign
    the destination and the source registers to the same register,
    even if the source register remains live afterwards.
    (This is even desirable, since the ``move'' instruction can then
    be eliminated.)  Thus, no interference is added between the
    source and the destination of a ``move'' instruction.

    Finally, for ``call'' instructions, we must make sure that
    pseudo-registers live across the instruction are allocated to
    callee-save machine register or to stack slots, but never to
    caller-save machine registers (these lose their values across
    the call).  We therefore add the corresponding conflict edges
    between pseudo-registers live across and caller-save machine
    registers (pairwise).

    The full algorithm is similar to the simplified algorithm above,
    but records preference edges in addition to conflict edges.
    Preference edges guide the graph coloring algorithm by telling it
    that better code will be obtained eventually if it is possible
    to allocate certain pseudo-registers to the same location or to
    a given machine register.  Preference edges are added:
-   between the destination and source pseudo-registers of a ``move''
    instruction;
-   between the arguments of a ``call'' instruction and the locations
    of the arguments as dictated by the calling conventions;
-   between the result of a ``call'' instruction and the location
    of the result as dictated by the calling conventions.
*)

Definition add_interf_live
    (filter: reg -> bool) (res: reg) (live: Regset.t) (g: graph): graph :=
  Regset.fold
    (fun r g => if filter r then add_interf r res g else g) live g.

Definition add_interf_op
    (res: reg) (live: Regset.t) (g: graph): graph :=
  add_interf_live
    (fun r => if Reg.eq r res then false else true)
    res live g.

Definition add_interf_move
    (arg res: reg) (live: Regset.t) (g: graph): graph :=
  add_interf_live
    (fun r =>
       if Reg.eq r res then false else
       if Reg.eq r arg then false else true)
    res live g.

Definition add_interf_destroyed
    (live: Regset.t) (destroyed: list mreg) (g: graph): graph :=
  List.fold_left
    (fun g mr => Regset.fold (fun r g => add_interf_mreg r mr g) live g)
    destroyed g.

Definition add_interfs_indirect_call
    (rfun: reg) (locs: list loc) (g: graph): graph :=
  List.fold_left
    (fun g loc =>
      match loc with R mr => add_interf_mreg rfun mr g | _ => g end)
    locs g.

Definition add_interf_call
    (ros: reg + ident) (locs: list loc) (g: graph): graph :=
  match ros with
  | inl rfun => add_interfs_indirect_call rfun locs g
  | inr idfun => g
  end.

Fixpoint add_prefs_call
    (args: list reg) (locs: list loc) (g: graph) {struct args} : graph :=
  match args, locs with
  | a1 :: al, l1 :: ll =>
      add_prefs_call al ll
        (match l1 with R mr => add_pref_mreg a1 mr g | _ => g end)
  | _, _ => g
  end.

Definition add_prefs_builtin (ef: external_function)
                            (args: list reg) (res: reg) (g: graph) : graph :=
  match ef, args with
  | EF_annot_val txt targ, arg1 :: _ => add_pref arg1 res g
  | _, _ => g
  end.

Definition add_interf_entry
    (params: list reg) (live: Regset.t) (g: graph): graph :=
  List.fold_left (fun g r => add_interf_op r live g) params g.

Fixpoint add_interf_params
    (params: list reg) (g: graph) {struct params}: graph :=
  match params with
  | nil => g
  | p1 :: pl =>
      add_interf_params pl
        (List.fold_left
          (fun g r => if Reg.eq r p1 then g else add_interf r p1 g)
          pl g)
  end.

Definition add_edges_instr
    (sig: signature) (i: instruction) (live: Regset.t) (g: graph) : graph :=
  match i with
  | Iop op args res s =>
      if Regset.mem res live then
        match is_move_operation op args with
        | Some arg =>
            add_pref arg res (add_interf_move arg res live g)
        | None =>
            add_interf_op res live g
        end
      else g
  | Iload chunk addr args dst s =>
      if Regset.mem dst live
      then add_interf_op dst live g
      else g
  | Icall sig ros args res s =>
      let largs := loc_arguments sig in
      let lres := loc_result sig in
      add_prefs_call args largs
        (add_pref_mreg res lres
          (add_interf_op res live
            (add_interf_call ros largs
              (add_interf_destroyed
                (Regset.remove res live) destroyed_at_call_regs g))))
  | Itailcall sig ros args =>
      let largs := loc_arguments sig in
      add_prefs_call args largs
        (add_interf_call ros largs g)
  | Ibuiltin ef args res s =>
      add_prefs_builtin ef args res (add_interf_op res live g)
  | Ireturn (Some r) =>
      add_pref_mreg r (loc_result sig) g
  | _ => g
  end.

Definition add_edges_instrs (f: function) (live: PMap.t Regset.t) : graph :=
  PTree.fold
    (fun g pc i => add_edges_instr f.(fn_sig) i live!!pc g)
    f.(fn_code)
    empty_graph.

Definition interf_graph (f: function) (live: PMap.t Regset.t) (live0: Regset.t) :=
  add_prefs_call f.(fn_params) (loc_parameters f.(fn_sig))
    (add_interf_params f.(fn_params)
      (add_interf_entry f.(fn_params) live0
        (add_edges_instrs f live))).

(** * Graph coloring *)

(** The actual coloring of the graph is performed by a function written
  directly in Caml, and not proved correct in any way.  This function
  takes as argument the [RTL] function, the interference graph for
  this function, an assignment of types to [RTL] pseudo-registers,
  and the set of all [RTL] pseudo-registers mentioned in the
  interference graph.  It returns the coloring as a function from
  pseudo-registers to locations. *)

Parameter graph_coloring:
  function -> graph -> regenv -> Regset.t -> (reg -> loc).

(** To ensure that the result of [graph_coloring] is a correct coloring,
  we check a posteriori its result using the following Coq functions.
  Let [coloring] be the function [reg -> loc] returned by [graph_coloring].
  The three properties checked are:
- [coloring r1 <> coloring r2] if there is a conflict edge between
  [r1] and [r2] in the interference graph.
- [coloring r1 <> R m2] if there is a conflict edge between pseudo-register
  [r1] and machine register [m2] in the interference graph.
- For all [r] mentioned in the interference graph,
  the location [coloring r] is acceptable and has the same type as [r].
*)

Definition check_coloring_1 (g: graph) (coloring: reg -> loc) :=
  SetRegReg.for_all
    (fun r1r2 =>
      if Loc.eq (coloring (fst r1r2)) (coloring (snd r1r2)) then false else true)
    g.(interf_reg_reg).

Definition check_coloring_2 (g: graph) (coloring: reg -> loc) :=
  SetRegMreg.for_all
    (fun r1mr2 =>
      if Loc.eq (coloring (fst r1mr2)) (R (snd r1mr2)) then false else true)
    g.(interf_reg_mreg).

Definition same_typ (t1 t2: typ) :=
  match t1, t2 with
  | Tint, Tint => true
  | Tfloat, Tfloat => true
  | _, _ => false
  end.

Definition loc_is_acceptable (l: loc) :=
  match l with
  | R r =>
     if In_dec Loc.eq l temporaries then false else true
  | S (Local ofs ty) =>
     if zlt ofs 0 then false else true
  | _ =>
     false
  end.

Definition check_coloring_3 (rs: Regset.t) (env: regenv) (coloring: reg -> loc) :=
  Regset.for_all
    (fun r =>
      let l := coloring r in
      andb (loc_is_acceptable l) (same_typ (env r) (Loc.type l)))
    rs.

Definition check_coloring
       (g: graph) (env: regenv) (rs: Regset.t) (coloring: reg -> loc) :=
  andb (check_coloring_1 g coloring)
       (andb (check_coloring_2 g coloring)
             (check_coloring_3 rs env coloring)).

(** To preserve decidability of checking, the checks
  (especially the third one) are performed for the pseudo-registers
  mentioned in the interference graph.  To facilitate the proofs,
  it is convenient to ensure that the properties hold for all
  pseudo-registers.  To this end, we ``clip'' the candidate coloring
  returned by [graph_coloring]: the final coloring behave identically
  over pseudo-registers mentioned in the interference graph,
  but returns a dummy machine register of the correct type otherwise. *)

Definition alloc_of_coloring (coloring: reg -> loc) (env: regenv) (rs: Regset.t) :=
  fun r =>
    if Regset.mem r rs
    then coloring r
    else match env r with Tint => R dummy_int_reg | Tfloat => R dummy_float_reg end.

(** * Coloring of the interference graph *)

(** The following function combines the phases described above:
  construction of the interference graph, coloring by untrusted
  Caml code, checking of the candidate coloring returned,
  and adjustment of this coloring.  If the coloring candidate is
  incorrect, [None] is returned, causing register allocation to fail. *)

Definition regalloc
    (f: function) (live: PMap.t Regset.t) (live0: Regset.t) (env: regenv) :=
  let g := interf_graph f live live0 in
  let rs := all_interf_regs g in
  let coloring := graph_coloring f g env rs in
  if check_coloring g env rs coloring
  then Some (alloc_of_coloring coloring env rs)
  else None.


From Coq Require Import ssreflect.
From stdpp Require Import base gmap.
From iris.proofmode Require Import tactics.
From aneris.prelude Require Import gset_map.
From aneris.aneris_lang.lib Require Import list_proof.
From aneris.aneris_lang.lib.serialization Require Import serialization_proof.
From aneris.aneris_lang Require Import aneris_lifting proofmode.
From aneris.examples.crdt.spec Require Import crdt_base crdt_time crdt_events crdt_denot crdt_resources.
From aneris.examples.crdt.oplib Require Import oplib_code.
From aneris.examples.crdt.oplib.spec Require Import model spec.
From aneris.examples.crdt.oplib.examples.two_p_set Require Import two_p_set_code.

Section tpsCrdt.
  Context `{!Log_Time} `{!EqDecision vl} `{!Countable vl}.

  Definition tpsOp : Type := vl + vl.
  Definition tpsSt : Type := gset vl * gset vl.

  Definition update_state (op : tpsOp) (st : tpsSt) : tpsSt :=
    match op with
    | inl a => ({[a]} ∪ st.1, st.2)
    | inr a => (st.1, {[a]} ∪ st.2)
    end.

  Definition tps_denot (s : gset (Event tpsOp)) (state : tpsSt) : Prop :=
    set_fold (λ ev st, update_state (EV_Op ev) st) (∅, ∅) s = state.

  Global Instance tps_denot_fun : Rel2__Fun tps_denot.
  Proof. constructor; intros ? ? ? <- <-; done. Qed.

  Global Instance tps_denot_instance : CrdtDenot tpsOp tpsSt := {
    crdt_denot := tps_denot;
  }.
End tpsCrdt.

Global Arguments tpsOp _ : clear implicits.
Global Arguments tpsSt _ {_ _}.

Section OpTps.
  Context `{!Log_Time}
          `{!EqDecision vl} `{!Countable vl}.

  Definition op_tps_effect (st : tpsSt vl) (ev : Event (tpsOp vl)) (st' : tpsSt vl) : Prop :=
    st' = update_state (EV_Op ev) st.

  Lemma op_tps_effect_fun st : Rel2__Fun (op_tps_effect st).
  Proof. constructor; intros ??? -> ->; done. Qed.

  Instance op_tps_effect_coh : OpCrdtEffectCoh op_tps_effect.
  Proof.
    intros s ev st st' Hst Hevs Hmax Hext.
    rewrite /op_tps_effect /crdt_denot /= /tps_denot.
    rewrite set_fold_disj_union_strong; [| |set_solver]; last first.
    { intros [[] ] [[] ]; rewrite /update_state /=; intros; f_equal; set_solver. }
    rewrite Hst set_fold_singleton; split; done.
  Qed.

  Definition op_tps_init_st : tpsSt vl := (∅, ∅).

  Lemma op_tps_init_st_coh : ⟦ (∅ : gset (Event (tpsOp vl))) ⟧ ⇝ op_tps_init_st.
  Proof. done. Qed.

  Global Instance op_tps_model_instance : OpCrdtModel (tpsOp vl) (tpsSt vl) := {
    op_crdtM_effect := op_tps_effect;
    op_crdtM_effect_fun := op_tps_effect_fun;
    op_crdtM_effect_coh := op_tps_effect_coh;
    op_crdtM_init_st := op_tps_init_st;
    op_crdtM_init_st_coh := op_tps_init_st_coh
  }.

End OpTps.

From aneris.aneris_lang.lib Require Import set_code set_proof.
From aneris.aneris_lang.lib Require Import inject.
From aneris.examples.crdt.oplib.proof Require Import time.

Section tps_proof.
  Context `{!EqDecision vl} `{!Countable vl}
          `{!Inject vl val} `{!∀ (a : vl), Serializable vl_serialization $a}.

  Context `{!anerisG M Σ}.

  Context `{!CRDT_Params} `{!OpLib_Res (tpsOp vl)}.

  Definition tps_OpLib_Op_Coh := λ (op : tpsOp vl) (v : val), v = $op.

  Lemma tps_OpLib_Op_Coh_Inj (o1 o2 : tpsOp vl) (v : val) :
    tps_OpLib_Op_Coh o1 v → tps_OpLib_Op_Coh o2 v → o1 = o2.
  Proof. intros Ho1 Ho2; apply (inj (@inject _ _ Inject_sum)); rewrite -Ho1 -Ho2; done. Qed.

  Lemma tps_OpLib_Coh_Ser (op : tpsOp vl) (v : val) :
    tps_OpLib_Op_Coh op v → Serializable (sum_serialization vl_serialization vl_serialization) v.
  Proof. intros Heq. rewrite Heq; destruct op; apply _. Qed.

  Definition tps_OpLib_State_Coh :=
    λ (st : tpsSt vl) v, ∃ v1 v2, v = PairV v1 v2 ∧ is_set st.1 v1 ∧ is_set st.2 v2.

  Global Instance tps_OpLib_Params : OpLib_Params (tpsOp vl) (tpsSt vl) :=
  {|
    OpLib_Serialization := (sum_serialization vl_serialization vl_serialization);
    OpLib_State_Coh := tps_OpLib_State_Coh;
    OpLib_Op_Coh := tps_OpLib_Op_Coh;
    OpLib_Op_Coh_Inj := tps_OpLib_Op_Coh_Inj;
    OpLib_Coh_Ser := tps_OpLib_Coh_Ser
  |}.

  Lemma tps_init_st_fn_spec : ⊢ init_st_fn_spec init_st.
  Proof.
    iIntros (addr).
    iIntros "!#" (Φ) "_ HΦ".
    rewrite /init_st.
    wp_pures.
    wp_apply wp_set_empty; first done.
    iIntros (v Hv).
    wp_apply wp_set_empty; first done.
    iIntros (w Hw).
    wp_pures.
    iApply "HΦ".
    iPureIntro; eexists _, _; split_and!; simpl; done.
  Qed.

  Lemma tps_effect_spec : ⊢ effect_spec effect.
  Proof.
    iIntros (addr ev st s log_ev log_st).
    iIntros "!#" (Φ) "(%Hev & %Hst & %Hs & %Hevs) HΦ".
    rewrite /effect.
    destruct log_ev as [log_ev orig vc].
    destruct Hev as (evpl&evvc&evorig& ?&Hopcoh&?&?).
    destruct Hevs as (Hnin & Hmax & Hext).
    destruct log_st as [log_st1 log_st2].
    destruct Hst as (st1&st2&?&?&?).
    simplify_eq/=.
    rewrite Hopcoh /=.
    wp_pures.
    destruct log_ev; wp_pures.
    - wp_apply wp_set_add; first by iPureIntro.
      iIntros (w Hw).
      wp_pures.
      iApply "HΦ".
      iExists _; iSplit; last by eauto.
      simpl; iPureIntro; eexists _, _; split_and!; done.
    - wp_apply wp_set_add; first by iPureIntro.
      iIntros (w Hw).
      wp_pures.
      iApply "HΦ".
      iExists _; iSplit; last by eauto.
      simpl; iPureIntro; eexists _, _; split_and!; done.
  Qed.

  Lemma tps_crdt_fun_spec : ⊢ crdt_fun_spec tps_crdt.
  Proof.
    iIntros (addr).
    iIntros "!#" (Φ) "_ HΦ".
    rewrite /tps_crdt.
    wp_pures.
    iApply "HΦ".
    iExists _, _; iSplit; first done.
    iSplit.
    - iApply tps_init_st_fn_spec; done.
    - iApply tps_effect_spec; done.
  Qed.

  Lemma tps_init_spec :
    init_spec
      (oplib_init
         (s_ser (s_serializer (sum_serialization vl_serialization vl_serialization)))
         (s_deser (s_serializer (sum_serialization vl_serialization vl_serialization)))) -∗
    init_spec_for_specific_crdt
      (tps_init (s_ser (s_serializer vl_serialization)) (s_deser (s_serializer vl_serialization))).
  Proof.
    iIntros "#Hinit" (repId addr addrs_val).
    iIntros (Φ) "!# (%Haddrs & %Hrepid & Hprotos & Hskt & Hfr & Htoken) HΦ".
    rewrite /tps_init.
    wp_pures.
    wp_apply ("Hinit" with "[$Hprotos $Htoken $Hskt $Hfr]").
    { do 2 (iSplit; first done). iApply tps_crdt_fun_spec; done. }
    iIntros (get update) "(HLS & #Hget & #Hupdate)".
    wp_pures.
    iApply "HΦ"; eauto.
  Qed.

End tps_proof.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Leo Ducas, 2007-08-06

Modular termination proof through SCC of an over DPGraph
*)

Set Implicit Arguments.

From Coq Require Import Permutation Multiset Setoid PermutSetoid.
From CoLoR Require Import SCCTopoOrdering AGraph ATrs RelUtil RelSub BoundNat
     AdjMat LogicUtil NatUtil SCC SCC_dec ListExtras SN VecUtil GDomainBij
     OptUtil Union SortUtil ListNodup ListPermutation.

Section S.

  Variable Sig : Signature.

  Notation rule := (rule Sig). Notation rules := (list rule).

  Variables (S : relation (term Sig)) (R : rules) (hyp : rules_preserve_vars R).

  Notation DPG := (hd_rules_graph S R).
  Notation rule_eq_dec := (@ATrs.eq_rule_dec Sig).
  Notation dim := (length R).

  Variables (ODPG : relation rule) (over_DPG : DPG << ODPG)
            (restriction : is_restricted ODPG R) (R_nodup : nodup R)
            (ODPG_dec : forall x y, {ODPG x y} + {~ODPG x y}).

  Definition hyps := mkSCC_dec_hyps rule_eq_dec restriction R_nodup ODPG_dec.

  Variables (M : matrix dim dim) (HM : M = SCC_mat_effective hyps) .

  Notation empty := (fun _ _ => False).

  Definition proj1_sig2 T P Q (e : @sig2 T P Q) :=
    match e with
    | exist2 _ _ a b c => a
    end.

  Definition s_SCC's := proj1_sig2 (sorted_SCC' hyps HM).

  Notation ODPGquo' := (Rquo' hyps HM).

(***********************************************************************)
(** s_SCC's properties *)

  Lemma s_SCC's_spec_cover i : i < dim -> In i s_SCC's.

  Proof.
    intros. unfold s_SCC's. destruct (sorted_SCC' hyps). unfold proj1_sig2.
    unfold permutation, meq in *. ded (p i).
    rewrite multiplicity_nats_decr_lt in H0.
    destruct (lt_ge_dec i (length (hyp_Dom hyps))); try lia.
    cut (exists j, j=i /\ In j x). intros; destruct H1. destruct H1.
    rewrite <- H1; auto.
    apply (multiplicity_in (@eq nat) eq_nat_dec). lia.
    assert (length (hyp_Dom hyps) = dim); intuition.
  Qed.

  Lemma s_SCC's_spec_bound i : In i s_SCC's -> i < dim.

  Proof.
    intros. unfold s_SCC's in H. destruct (sorted_SCC' hyps).
    unfold proj1_sig2 in *. gen p; intros. unfold permutation, meq in p.
    ded (p i). rewrite multiplicity_nats_decr_lt in H0.
    destruct (lt_ge_dec i (length (hyp_Dom hyps))); try lia.
    assert (dim = length (hyp_Dom hyps)). auto. rewrite H1 in *; auto.
    cut (exists j, j=i /\ In j (nats_decr_lt dim)).
    intros; destruct H1. destruct H1.
    rewrite <- In_nats_decr_lt in H2. subst i; auto.
    eapply permutation_in. auto with typeclass_instances.
    apply permutation_sym. eauto. auto.
  Qed.

(***********************************************************************)
(** chain restricted to an SCC *)

  Notation SCC' := (SCC' hyps).
  Notation SCC'_tag := (SCC'_tag hyps).
  Notation SCC'_dec := (SCC'_dec hyps).

  Definition hd_red_SCC' i t1 t2 := exists l, exists r, exists s,
          SCC'_tag HM (mkRule l r) = Some i /\ t1 = sub s l /\ t2 = sub s r.

  Lemma hd_red_SCC'_cover t1 t2 : hd_red R t1 t2 ->
                                  exists i, hd_red_SCC' i t1 t2 /\ i<dim.

  Proof.
    intros. unfold hd_red in *. do 4 destruct H; destruct H0.
    cut (exists n, SCC'_tag HM (mkRule x x0) = Some n).
    intro. destruct H2 as [i]. exists i. split. exists x; exists x0; exists x1.
    split; try tauto.
    apply (find_first_Some_bound
             (SCC' (mkRule x x0)) (SCC'_dec HM (mkRule x x0))). intuition.
    ded (find_first_exist
           (SCC' (mkRule x x0)) (SCC'_dec HM (mkRule x x0)) _ R H).
    assert (SCC'_tag HM (mkRule x x0) <> None). apply H2.
    split; try tauto. left; auto.
    destruct (SCC'_tag HM (mkRule x x0)). exists n; auto. congruence.
  Qed.

  Definition hd_red_Mod_SCC' i :=  S @ hd_red_SCC' i.

(***********************************************************************)
(** union of chain_SCC' *)

  Notation union := Relation_Operators.union.

  Definition sorted_hd_red_Mod_SCC' := map hd_red_Mod_SCC' s_SCC's.

  Definition hd_red_Mod_SCC'_union :=
    fold_right (@union (term Sig)) empty sorted_hd_red_Mod_SCC'.

  Lemma union_list_spec : forall (A : Type) L (x y : A) (r : relation A),
      In r L -> r x y -> fold_right (@union A) empty L x y.

  Proof.
    intros. induction L. simpl in *; tauto.
    simpl in *. destruct H. destruct H. subst; left; auto. right; tauto.
  Qed.

  Lemma union_list_spec2 : forall (A : Type) L (x y : A),
      fold_right (@union A) empty L x y -> exists r, In r L /\ r x y.

  Proof.
    intros. induction L. simpl in *; tauto.
    simpl in *. destruct H. exists a; split; tauto.
    destruct (IHL H). exists x0. split; try tauto.
  Qed.

  Lemma hd_red_Mod_SCC'_cover : hd_red_Mod S R << hd_red_Mod_SCC'_union.

  Proof.
    unfold inclusion. intros. unfold hd_red_Mod_SCC'_union in H.
    unfold hd_red_Mod in H. do 2 destruct H. ded (hd_red_SCC'_cover H0).
    destruct H1 as [i]. assert (hd_red_Mod_SCC' i x y). exists x0; tauto.
    unfold hd_red_Mod_SCC'_union. eapply union_list_spec; eauto.
    unfold sorted_hd_red_Mod_SCC'. apply in_map.
    apply s_SCC's_spec_cover; tauto.
  Qed.

(***********************************************************************)
(** properties of the total order RT relatively to restricted chain *)

  Notation RT_ODPG := (RT hyps HM).

  Lemma compose_empty :
    forall i j, RT_ODPG i j -> hd_red_Mod_SCC' j @ hd_red_Mod_SCC' i << empty.

  Proof.
    intros. unfold inclusion. intros x y H0. destruct H0 as [z]. destruct H0.

    assert (~ODPGquo' j i). unfold RT in  *. destruct topo_sortable_Rquo'.
    simpl in *. intuition. ded (l (nats_decr_lt dim)). clear l.
    set (RTbis := fun x y : nat => x0 (nats_decr_lt dim) x y = true) in *.
    change (RTbis i j) in H.

    assert (RTbis j i). destruct H3. intuition. apply H5.
    ded (@Rquo_restricted hyps M HM j i).
    split; try split; try tauto; destruct H2; try tauto.

    unfold irreflexive in *. intuition. destruct H3; intuition. apply (H7 i).
    eapply H5; ehyp.

    assert (ODPGquo' j i). unfold Rquo'. intuition.
    unfold Rquo in *. unfold hd_red_Mod_SCC' in *.
    destruct H0 as [x']. destruct H0. destruct H1 as [z']. destruct H1.
    destruct H3 as [t1]. destruct H3 as [r1]. destruct H3 as [s1].
    exists (mkRule t1 r1); split; try tauto.
    destruct H4 as [t2]. destruct H4 as [r2]. destruct H4 as [s2].
    exists (mkRule t2 r2); split; try tauto.
    apply over_DPG. eapply hd_red_Mod_rule2_hd_rules_graph; intuition.
    unfold hd_red_Mod_rule. split.

    assert (SCC' (mkRule t1 r1) (mkRule t1 r1)).
    rewrite (SCC'_tag_exact hyps HM). split; try tauto. congruence.

    destruct H7. tauto.
    exists s1. subst x'. split; simpl; auto; eauto.
    intuition. split.

    assert (SCC' (mkRule t2 r2) (mkRule t2 r2)).
    rewrite (SCC'_tag_exact hyps HM). split; try tauto. congruence.

    destruct H7; tauto.
    exists s2. subst z. split; simpl; auto; eauto. congruence.

    subst j. unfold RT in *. destruct topo_sortable_Rquo'. simpl in *.
    ded (l (nats_decr_lt dim)). clear l. destruct H3. intuition.
    unfold irreflexive in H6. ded (H6 i). auto. tauto.
  Qed.

(***********************************************************************)
(** Proof of the modular termination criterion *)

  Lemma WF_SCC'_union_aux : forall L,
      (forall i, In i L -> WF (hd_red_Mod_SCC' i)) -> sort RT_ODPG L ->
      WF (fold_right (@union _) empty (map hd_red_Mod_SCC' L)).

  Proof.
    intros. induction L; simpl in *.
    intro. apply SN_intro. intros; tauto.
    inversion H0. subst a0; subst l. eapply WF_incl. apply union_commut.
    apply WF_union_commut.

    apply IHL. intros. apply H. right; auto.
    destruct H0; auto. apply H. left; auto.

    unfold inclusion. intros. cut False; try tauto.
    destruct H1 as [z]. destruct H1. ded (union_list_spec2 _ _ _ H1).
    destruct H5 as [r]. destruct H5.

    assert (exists b, In b L /\ r = hd_red_Mod_SCC' b).
    apply in_map_elim; auto. destruct H7 as [b]. destruct H7; subst r.
    cut (RT_ODPG a b). intro. eapply (compose_empty H8). exists z; eauto.
    eapply sort_transitive. unfold RT; destruct topo_sortable_Rquo'.
    simpl in *.
    ded (l (nats_decr_lt dim)). destruct H8. intuition. ehyp. auto.
  Qed.

  Lemma WF_SCC'_union :
    (forall i, i < dim -> WF (hd_red_Mod_SCC' i)) -> WF (hd_red_Mod S R).

  Proof.
    intros. eapply WF_incl. apply hd_red_Mod_SCC'_cover.
    unfold hd_red_Mod_SCC'_union, sorted_hd_red_Mod_SCC'.
    eapply WF_SCC'_union_aux. intros. apply H. apply s_SCC's_spec_bound. auto.
    unfold s_SCC's; destruct sorted_SCC'. simpl in *. auto.
  Qed.

  Fixpoint SCC'_list_aux i L :=
    match L with
    | nil => nil
    | x :: q =>
      match eq_opt_dec eq_nat_dec (SCC'_tag HM x) (Some i) with
      | left _ => x :: @SCC'_list_aux i q
      | right _ => @SCC'_list_aux i q
      end
    end.

  Lemma SCC'_list_aux_exact : forall i L r,
      In r (SCC'_list_aux i L) <-> In r L /\ SCC'_tag HM r = Some i.

  Proof.
    intros. induction L. simpl in *. tauto.
    split; intro. simpl in *.
    destruct (eq_opt_dec eq_nat_dec (SCC'_tag HM a) (Some i));
      destruct (rule_eq_dec a r); simpl in *; intuition.
    subst a; tauto.
    destruct H. simpl in *.
    destruct (eq_opt_dec eq_nat_dec (SCC'_tag HM a) (Some i));
      destruct H; simpl in *; try subst a; tauto.
  Qed.

  Lemma nodup_SCC'_list_aux : forall i L, nodup L -> nodup (SCC'_list_aux i L).

  Proof.
    induction L; intros; simpl. tauto.
    simpl in H. destruct H.
    destruct (eq_opt_dec eq_nat_dec (SCC'_tag HM a) (Some i)); try tauto.
    split. rewrite SCC'_list_aux_exact. tauto. tauto.
  Qed.

  Definition SCC'_list i := SCC'_list_aux i R.

  Lemma SCC'_list_exact : forall i r,
      In r (SCC'_list i) <-> SCC'_tag HM r = Some i.

  Proof.
    intros; split; intro.
    unfold SCC'_list in H. rewrite SCC'_list_aux_exact in H. tauto.
    unfold SCC'_list; rewrite SCC'_list_aux_exact; split; try tauto.
    assert (SCC' r r). rewrite (SCC'_tag_exact hyps HM).
    intuition. congruence. unfold SCCTopoOrdering.SCC' in H0. tauto.
  Qed.

  Lemma nodup_SCC'_list : forall i, nodup (SCC'_list i).

  Proof. unfold SCC'_list; intros. apply nodup_SCC'_list_aux. auto. Qed.

  Lemma chain_SCC'_red_Mod : forall i,
      hd_red_Mod_SCC' i << hd_red_Mod S (SCC'_list i).

  Proof.
    unfold inclusion; intros. do 2 destruct H. exists x0. split. auto.
    unfold hd_red_SCC' in H0. unfold hd_red. do 3 destruct H0.
    exists x1; exists x2; exists x3. rewrite SCC'_list_exact. intuition.
  Qed.

(***********************************************************************)
(** A faster way to compute SCC'_list but only half-certified *)

  Definition SCC_list_fast i (Hi : i < dim) :=
    listfilter R (list_of_vec (Vnth M Hi)).

  Lemma incl_SCC_list_fast i (Hi : i < dim) :
    Vnth (Vnth M Hi) Hi = true -> incl (SCC'_list i) (SCC_list_fast Hi).

  Proof.
    intros. assert(M[[i,i]] = true).
    unfold mat_unbound; destruct (le_gt_dec dim i). cut False; try tauto; lia.
    assert (g=Hi).
    unfold Peano.gt in *; apply lt_unique. subst; auto.
    unfold incl. intros. rewrite SCC'_list_exact in H1.
    unfold SCCTopoOrdering.SCC'_tag in H1. simpl in *.
    ded (find_first_exact _ _ _ H1).
    destruct H2 as [r]; destruct H2; destruct H3; destruct H3.
    subst a. unfold SCC_list_fast. eapply listfilter_in. eauto.
    rewrite <- H. apply list_of_vec_exact.
    destruct H4; ded (eq_In_find_first rule_eq_dec H4); do 2 destruct H6.

    assert (x<dim). eapply find_first_Some_bound. eauto.

    unfold SCC_list_fast. eapply listfilter_in. eauto.

    assert ((M[[i,x]]) = true). rewrite HM.
    ded (SCC_sym H3). clear H3. rename H9 into H3.
    rewrite (SCC_effective_exact hyps HM) in H3.
    unfold SCC_effective in H3. simpl in H3.
    unfold rel_on_dom in H3. simpl in *. rewrite H6 in H3.
    ded (eq_In_find_first rule_eq_dec H5).
    do 2 destruct H9. rewrite H9 in H3.

    assert (i=x0). eapply nodup_unique; eauto. subst x0.
    unfold GoM in H3. rewrite HM in H3. auto.

    unfold mat_unbound in H9; destruct (le_gt_dec dim i).
    cut False; try tauto; lia.
    destruct (le_gt_dec dim x). cut False; try tauto; lia.
    rewrite <- H9. unfold Peano.gt in *.
    assert (g=Hi). apply lt_unique. subst g; apply list_of_vec_exact.
  Qed.

  Lemma hd_red_Mod_SCC'_hd_red_Mod_fast : forall i (Hi : i < dim),
      Vnth (Vnth M Hi) Hi = true ->
      hd_red_Mod_SCC' i << hd_red_Mod S (SCC_list_fast Hi).

  Proof.
    intros. eapply incl_trans. apply chain_SCC'_red_Mod.
    ded (incl_SCC_list_fast Hi H). unfold inclusion; intros.
    destruct H1 as [z]; exists z. destruct H1; split; auto.
    do 4 destruct H2. destruct H3.
    exists x0; exists x1; exists x2; split; try split; try tauto.
    apply H0. auto.
  Qed.

(***********************************************************************)
(** Some lemma to prove trivial case of sub-problem termination *)

  Lemma red_Mod_SCC_trivial_empty : WF (hd_red_Mod S nil).

  Proof.
    unfold WF; intro; apply SN_intro; intros.
    do 2 destruct H. do 4 destruct H0. simpl in *; tauto.
  Qed.

  Lemma WF_chain_SCC_trivial : forall i,
      SCC'_list i = nil -> WF (hd_red_Mod_SCC' i).

  Proof.
    intros. eapply WF_incl. apply chain_SCC'_red_Mod.
    rewrite H. apply red_Mod_SCC_trivial_empty.
  Qed.

  Lemma red_Mod_SCC_trivial_singl : forall i r,
      SCC'_list i = r :: nil -> ~ODPG r r ->  WF (hd_red_Mod_SCC' i).

  Proof.
    intros i r H H0 x. apply SN_intro. intros y Hy. apply SN_intro. intros z Hz.
    cut (DPG r r). intro H1. assert False. apply H0. apply over_DPG. auto.
    tauto.
    assert (H1 : In r (SCC'_list i)). rewrite H. simpl. auto.
    unfold SCC'_list in H1. rewrite SCC'_list_aux_exact in H1.
    destruct H1 as [H1 H2]. destruct Hy as [x0 a]. destruct a as [s h].
    eapply hd_red_Mod_rule2_hd_rules_graph; auto; unfold red_mod in *;
    unfold hd_red_Mod_SCC' in *.
    unfold hd_red_Mod_rule. split. auto. destruct h as [x1 e].
    destruct e as [x2 e]. destruct e as [x3 a]. destruct a as [H3 H4].
    destruct H4 as [H4 H5]. exists x3. assert (h : r = mkRule x1 x2).
    rewrite <- SCC'_list_exact, H in H3; simpl in *; tauto.
    rewrite h; simpl. subst x0. split; eauto.
    unfold hd_red_Mod_rule. split. auto. destruct Hz as [x1 H3].
    destruct H3 as [H3 H4]. destruct H4 as [x2 H4]. destruct H4 as [x3 H4].
    destruct H4 as [x4 H4]. destruct H4 as [H4 H5]. destruct H5 as [H5 H6].
    exists x4. assert (r = mkRule x2 x3).
    rewrite <- SCC'_list_exact, H in H4; simpl in *; tauto.
    rewrite H7. simpl. subst x1. split; eauto.
  Qed.

  Lemma WF_hd_red_Mod_SCC_fast_trivial : forall i (Hi : i < dim),
      SCC_list_fast Hi = nil -> WF (hd_red_Mod_SCC' i).

  Proof.
    intros i Hi; intros. set (L := SCC'_list i). assert (L = SCC'_list i); auto.
    destruct L. apply WF_chain_SCC_trivial. auto.
    destruct L. destruct (ODPG_dec h h).
    assert (R [i] =Some h).
    assert (In h (SCC'_list i)). rewrite <- H0; simpl; auto.
    rewrite SCC'_list_exact in H1. gen H1; intro.
    unfold SCCTopoOrdering.SCC'_tag in H1. simpl in *.
    ded (find_first_exact _ _ _ H1). do 2 destruct H3.
    rewrite (SCC'_tag_exact hyps  HM) in H4. intuition.
    cut (x=h). intro; subst x; auto.
    rewrite H5, <- SCC'_list_exact, <- H0 in H2; simpl in *. intuition.

    cut (M[[i,i]] = true). intros. unfold mat_unbound in H2.
    destruct (le_gt_dec dim i); try discr.
    unfold Peano.gt in *; assert (g=Hi). apply lt_unique. subst g.
    ded (incl_SCC_list_fast Hi H2). rewrite H, <- H0 in *.
    unfold incl in H3. ded (H3 h). simpl in *. tauto.
    assert (SCC ODPG h h). split; apply t_step; auto.
    rewrite (SCC_effective_exact hyps HM) in H2.
    unfold SCC_effective in H2. simpl in *. unfold rel_on_dom in H2.
    ded (restriction o); intuition. ded (eq_In_find_first rule_eq_dec H4).
    do 2 destruct H3. ded(@nodup_unique rule R h R_nodup _ _ H1 H6).
    subst x. rewrite H3 in H2. intuition.

    eapply red_Mod_SCC_trivial_singl; eauto.

    ded (nodup_SCC'_list i).
    rewrite <-H0 in H1; simpl in H1; intuition. clear H1 H4 H5.
    assert(In h (SCC'_list i)); assert(In h0 (SCC'_list i)); try rewrite <- H0;
    simpl;auto.
    rewrite SCC'_list_exact in *. rewrite <- H2 in H1.
    assert (SCC' h h0). rewrite (SCC'_tag_exact hyps HM); auto.
    split; congruence.
    destruct H4. destruct H4. assert False; auto. tauto.
    rewrite H2 in H1. unfold SCCTopoOrdering.SCC'_tag in *.
    ded (In_find_first2 H2). ded (In_find_first2 H1).
    do 2 destruct H6. do 2 destruct H7. simpl in *.
    assert (x=x0). congruence. subst x0.

    assert (SCC ODPG x x). destruct(rule_eq_dec x h). subst h.
    eapply SCC_trans. apply H4. apply SCC_sym. apply H4.
    do 2 destruct H9; try subst x; try tauto. simpl in *.
    eapply SCC_trans. apply SCC_sym. apply H9. apply H9.
    cut (M[[i,i]]=true). intros. unfold mat_unbound in H11.
    destruct (le_gt_dec dim i). cut False; try tauto; lia.
    unfold Peano.gt in *. assert (g=Hi). apply lt_unique. subst g.
    ded (incl_SCC_list_fast Hi H11). rewrite H, <- H0 in *.
    unfold incl in H12. ded (H12 h). simpl in *. tauto.

    rewrite (SCC_effective_exact hyps HM) in H10.
    unfold SCC_effective in H10. simpl in *. unfold rel_on_dom in H10.
    assert (In x R). eapply exists_element_at_in. exists i; auto.
    ded (eq_In_find_first rule_eq_dec H11). do 2 destruct H12.
    ded (nodup_unique R_nodup H13 H6). subst x0.
    rewrite H12 in H10. intuition.
  Qed.

End S.

Arguments WF_SCC'_union [Sig] _ [R] _ [ODPG] _ _ _ _ [M] _ _ _.

(***********************************************************************)
(** tactics *)

Ltac use_SCC_tag h M S R t :=
  let x := fresh in
    (set (x := SCC_tag_fast h M t); norm_in x (SCC_tag_fast h M t);
      match eval compute in x with
        | Some ?X1 =>
          let Hi := fresh in
            (assert (Hi : X1 < length R);
              [ norm (length R); lia
              | let L := fresh in
                (set (L := SCC_list_fast R M Hi);
                  norm_in L (SCC_list_fast R M Hi);
                  assert (WF (hd_red_Mod S L)); subst L; clear Hi; clear x)])
      end).

Ltac use_SCC_hyp M l :=
  let b := fresh "b" in
    (set (b := Vnth (Vnth M l) l);
      norm_in b (Vnth (Vnth M l) l);
      match eval compute in b with
        | false => apply WF_hd_red_Mod_SCC_fast_trivial with (Hi:=l); eauto
        | true => eapply WF_incl;
          [eapply hd_red_Mod_SCC'_hd_red_Mod_fast with (Hi:=l); auto | auto]
      end).

Ltac use_SCC_all_hyps M i Hi Hj :=
  let rec aux x :=
    match x with
      | 0 => lia
      | S ?y => destruct i; [use_SCC_hyp M Hi | aux y]
    end in
    match type of Hj with
      | le _ ?Y => aux Y
    end.

Ltac SCC_name n1 n2 :=
  match goal with
    | |- WF (chain ?R) => set (n1 := dp R); set (n2 := int_red R #)
    | |- WF (hd_red_mod ?E ?R) => set (n1 := R); set (n2 := red E #)
    | |- WF (?X @ hd_red ?R) => set (n1 := R); set (n2 := X)
    | |- WF (hd_red_Mod ?E ?R) => set (n1 := R); set (n2 := E)
  end.


From mathcomp Require Import ssreflect.
From mathcomp Require eqtype ssrbool path.
From deriving Require Import deriving.
From stdpp Require Import gmap.
From iris.heap_lang Require Import notation.
From iris.heap_lang Require Import primitive_laws.
From cryptis Require Import mathcomp_compat lib.
From cryptis Require Export pre_term.

Definition int_of_key_type kt : Z :=
  match kt with
  | Enc => 0
  | Dec => 1
  end.

Definition key_type_of_int (n : Z) :=
  match n with
  | 0%Z => Enc
  | _   => Dec
  end.

Canonical key_typeO := leibnizO key_type.

Instance key_type_eq_dec : EqDecision key_type.
Proof.
refine (
  fun kt1 kt2 =>
    match kt1, kt2 with
    | Enc, Enc => left _
    | Dec, Dec => left _
    | _, _ => right _
    end); congruence.
Defined.

Instance int_of_key_typeK : Cancel (=) key_type_of_int int_of_key_type.
Proof. by case. Qed.

Instance int_of_key_type_inj : Inj (=) (=) int_of_key_type.
Proof. by apply (@cancel_inj _ _ _ key_type_of_int); apply _. Qed.

Instance int_of_key_type_countable : Countable key_type.
Proof. apply (inj_countable' _ _ int_of_key_typeK). Qed.

Instance repr_key_type : Repr key_type := λ kt, #(int_of_key_type kt).

Canonical termO := leibnizO term.

Global Instance TExp_proper : Proper ((=) ==> (≡ₚ) ==> (=)) TExp.
Proof.
by move=> t _ <- ts1 ts2 e; apply/TExp_inj; eauto.
Qed.

Lemma TExpC2 g t1 t2 : TExp g [t1; t2] = TExp g [t2; t1].
Proof.
suff -> : [t1; t2] ≡ₚ [t2; t1] by [].
exact/Permutation_swap.
Qed.

Global Instance pre_term_inhabited : Inhabited PreTerm.pre_term.
Proof. exact: (populate (PreTerm.PTInt 0)). Qed.

Definition pre_term_eq_dec : EqDecision PreTerm.pre_term :=
  Eval hnf in def_eq_decision _.
Global Existing Instance pre_term_eq_dec.

Global Instance term_inhabited : Inhabited term.
Proof. exact: (populate (TInt 0)). Qed.

Definition term_eq_dec : EqDecision term :=
  Eval hnf in def_eq_decision _.
Global Existing Instance term_eq_dec.

Section ValOfTerm.

Import PreTerm.

Fixpoint val_of_pre_term_rec pt : val :=
  match pt with
  | PTInt n =>
    (#TInt_tag, #n)
  | PTPair t1 t2 =>
    (#TPair_tag, (val_of_pre_term_rec t1, val_of_pre_term_rec t2))%V
  | PTNonce l =>
    (#TNonce_tag, #l)%V
  | PTKey kt t =>
    (#TKey_tag, (#(int_of_key_type kt), val_of_pre_term_rec t))%V
  | PTEnc t1 t2 =>
    (#TEnc_tag, (val_of_pre_term_rec t1, val_of_pre_term_rec t2))%V
  | PTHash t =>
    (#THash_tag, val_of_pre_term_rec t)
  | PTExp t ts =>
    (#TExp_tag, (val_of_pre_term_rec t,
                 repr_list (map val_of_pre_term_rec ts)))
  end.

Definition val_of_pre_term_aux : seal val_of_pre_term_rec. by eexists. Qed.
Definition val_of_pre_term : Repr pre_term := unseal val_of_pre_term_aux.
Lemma val_of_pre_term_eq : val_of_pre_term = val_of_pre_term_rec.
Proof. exact: seal_eq. Qed.
Global Existing Instance val_of_pre_term.

Fixpoint val_of_term_rec t : val :=
  match t with
  | TInt n =>
    (#TInt_tag, #n)
  | TPair t1 t2 =>
    (#TPair_tag, (val_of_term_rec t1, val_of_term_rec t2))%V
  | TNonce l =>
    (#TNonce_tag, #l)%V
  | TKey kt t =>
    (#TKey_tag, (#(int_of_key_type kt), val_of_term_rec t))%V
  | TEnc t1 t2 =>
    (#TEnc_tag, (val_of_term_rec t1, val_of_term_rec t2))%V
  | THash t =>
    (#THash_tag, val_of_term_rec t)
  | TExp' t ts _ =>
    (#TExp_tag, (val_of_term_rec t, repr ts))
  end.

Definition val_of_term_aux : seal val_of_term_rec. by eexists. Qed.
Definition val_of_term : term -> val := unseal val_of_term_aux.
Lemma val_of_term_eq : val_of_term = val_of_term_rec.
Proof. exact: seal_eq. Qed.
Coercion val_of_term : term >-> val.
Global Instance repr_term : Repr term := val_of_term.

Lemma val_of_pre_term_unfold t :
  val_of_pre_term (unfold_term t) = val_of_term t.
Proof.
rewrite val_of_term_eq val_of_pre_term_eq.
elim/term_ind': t => //=; try by move=> *; congruence.
move=> t -> pts _.
by rewrite [repr_list pts]repr_list_val /repr val_of_pre_term_eq.
Qed.

End ValOfTerm.

Lemma val_of_term_TExp t ts :
  ~ is_exp t ->
  path.sorted order.Order.le ts ->
  val_of_term (TExp t ts) = (#TExp_tag, (val_of_term t, repr ts))%V.
Proof.
move=> nexp sorted_ts.
rewrite -[LHS]val_of_pre_term_unfold unfold_TExp.
rewrite order.Order.POrderTheory.sort_le_id // ?path.sorted_map; last first.
  rewrite (_ : path.sorted _ _ = path.sorted order.Order.le ts) //.
  by case: (path.sorted _ _) sorted_ts.
rewrite -[in RHS](val_of_pre_term_unfold t) val_of_pre_term_eq /=.
rewrite [repr_list ts]repr_list_val map_map.
do !congr PairV; congr repr_list.
elim: ts {sorted_ts} => //= {nexp}t ts -> /=.
by rewrite /repr_term -val_of_pre_term_unfold val_of_pre_term_eq.
Qed.

Global Instance val_of_pre_term_inj : Inj (=) (=) val_of_pre_term.
Proof.
rewrite val_of_pre_term_eq.
elim.
- by move=> n1 [] //= n2 [] ->.
- by move=> t11 IH1 t12 IH2 [] //= t21 t22 [] /IH1 -> /IH2 ->.
- by move=> l1 [] //= l2 [] //= ->.
- by move=> kt1 t1 IH [] //= kt2 t2 [] /int_of_key_type_inj -> /IH ->.
- by move=> t11 IH1 t12 IH2 [] //= ?? [] /IH1 -> /IH2 ->.
- by move=> ? IH [] //= ? [] /IH ->.
- move=> t1 IHt ts1 IHts [] //= t2 ts2 [] /IHt -> e_ts; congr PreTerm.PTExp.
  move: e_ts; rewrite repr_list_eq.
  elim: ts1 IHts ts2 {t1 t2 IHt} => /= [_ [] //|t1 ts1 H [] IHt {}/H IHts].
  by case=> //= t2 ts2 [] /IHt -> /IHts ->.
Qed.

Global Instance val_of_term_inj : Inj (=) (=) val_of_term.
Proof.
move=> t1 t2 e_t1t2; apply: unfold_term_inj.
apply: val_of_pre_term_inj.
by rewrite !val_of_pre_term_unfold.
Qed.

Global Instance countable_term : Countable term.
Proof. exact: def_countable. Qed.

Global Instance infinite_term : Infinite term.
Proof.
pose int_of_term (t : term) :=
  if t is TInt n then Some n else None.
apply (inj_infinite TInt int_of_term).
by move=> n; rewrite /int_of_term.
Qed.

Definition term_height t :=
  PreTerm.height (unfold_term t).

Fixpoint nonces_of_pre_term pt : gset loc :=
  match pt with
  | PreTerm.PTInt _ => ∅
  | PreTerm.PTPair t1 t2 => nonces_of_pre_term t1 ∪ nonces_of_pre_term t2
  | PreTerm.PTNonce l => {[l]}
  | PreTerm.PTKey _ t => nonces_of_pre_term t
  | PreTerm.PTEnc t1 t2 => nonces_of_pre_term t1 ∪ nonces_of_pre_term t2
  | PreTerm.PTHash t => nonces_of_pre_term t
  | PreTerm.PTExp t ts => nonces_of_pre_term t ∪ ⋃ map nonces_of_pre_term ts
  end.

Definition nonces_of_term_def (t : term) :=
  nonces_of_pre_term (unfold_term t).
Arguments nonces_of_term_def /.
Definition nonces_of_term_aux : seal nonces_of_term_def. by eexists. Qed.
Definition nonces_of_term := unseal nonces_of_term_aux.
Lemma nonces_of_term_eq : nonces_of_term = nonces_of_term_def.
Proof. exact: seal_eq. Qed.

Lemma nonces_of_termE t :
  nonces_of_term t =
  match t with
  | TInt _ => ∅
  | TPair t1 t2 => nonces_of_term t1 ∪ nonces_of_term t2
  | TNonce l => {[l]}
  | TKey _ t => nonces_of_term t
  | TEnc t1 t2 => nonces_of_term t1 ∪ nonces_of_term t2
  | THash t => nonces_of_term t
  | TExp' t pts _ => nonces_of_term t ∪ ⋃ map nonces_of_pre_term pts
  end.
Proof.
by rewrite nonces_of_term_eq; case: t => //=.
Qed.

Lemma nonces_of_term_TExp t ts :
  nonces_of_term (TExp t ts)
  = nonces_of_term t ∪ ⋃ map nonces_of_term ts.
Proof.
rewrite nonces_of_term_eq /nonces_of_term_def.
case: unfold_TExpP => pts' e_pts' /=.
by rewrite [in LHS]e_pts' map_map.
Qed.

Module Spec.

Implicit Types N : namespace.

Definition tag_def N (t : term) :=
  TPair (TInt (Zpos (encode N))) t.
Definition tag_aux : seal tag_def. by eexists. Qed.
Definition tag := unseal tag_aux.
Lemma tag_eq : tag = tag_def. Proof. exact: seal_eq. Qed.

Definition untag_def N (t : term) :=
  match t with
  | TPair (TInt (Zpos m)) t =>
    if decide (encode N = m) then Some t else None
  | _ => None
  end.
Definition untag_aux : seal untag_def. by eexists. Qed.
Definition untag := unseal untag_aux.
Lemma untag_eq : untag = untag_def. Proof. exact: seal_eq. Qed.

Lemma tagK N t : untag N (tag N t) = Some t.
Proof.
rewrite untag_eq tag_eq /untag_def /tag_def /=.
by rewrite decide_left.
Qed.

Instance tag_inj : Inj2 (=) (=) (=) tag.
Proof.
rewrite tag_eq /tag_def => c1 t1 c2 t2 [] e ->.
split=> //; by apply: inj e.
Qed.

Lemma untagK N t1 t2 :
  untag N t1 = Some t2 ->
  t1 = tag N t2.
Proof.
rewrite untag_eq tag_eq /=.
case: t1=> [] // [] // [] //= m.
by case: decide => // <- _ [->].
Qed.

Lemma untag_tag_ne N1 N2 t :
  N1 ≠ N2 →
  Spec.untag N1 (Spec.tag N2 t) = None.
Proof.
move=> neq; rewrite Spec.untag_eq Spec.tag_eq /=.
rewrite decide_False //.
move=> eq_enc; apply: neq.
by apply: encode_inj eq_enc.
Qed.

Variant untag_spec N t : option term → Type :=
| UntagSome t' of t = Spec.tag N t' : untag_spec N t (Some t')
| UntagNone of (∀ t', t ≠ Spec.tag N t') : untag_spec N t None.

Lemma untagP N t : untag_spec N t (Spec.untag N t).
Proof.
case e: (Spec.untag N t) => [t'|]; constructor.
- by rewrite (Spec.untagK _ _ _ e).
- move=> t' e'; by rewrite e' Spec.tagK in e.
Qed.

Definition to_int t :=
  if t is TInt n then Some n else None.

Variant to_int_spec t : option Z → Type :=
| AsIntSome n of t = TInt n : to_int_spec t (Some n)
| AsIntNone of (∀ n, t ≠ TInt n) : to_int_spec t None.

Lemma to_intP t : to_int_spec t (Spec.to_int t).
Proof. by case: t => *; constructor; congruence. Qed.

Definition untuple t :=
  match t with
  | TPair t1 t2 => Some (t1, t2)
  | _ => None
  end.

Fixpoint proj t n {struct t} :=
  match t, n with
  | TPair t _, 0 => Some t
  | TPair _ t, S n => proj t n
  | _, _ => None
  end.

Definition enc k t : term :=
  match k with
  | TKey Enc k => TEnc k t
  | _ => t (* Arbitrarily *)
  end.

Definition dec k t : option term :=
  match k, t with
  | TKey Dec k1, TEnc k2 t =>
    if decide (k1 = k2) then Some t else None
  | _, _ => None
  end.

Definition is_key t :=
  match t with
  | TKey kt _ => Some kt
  | _ => None
  end.

Variant is_key_spec t : option key_type → Type :=
| IsKeySome kt k of t = TKey kt k : is_key_spec t (Some kt)
| IsKeyNone of (∀ kt k, t ≠ TKey kt k) : is_key_spec t None.

Lemma is_keyP t : is_key_spec t (is_key t).
Proof.
case: t; try by right.
by move=> kt t; eleft.
Qed.

Definition to_ek t :=
  if t is TKey Enc _ then Some t else None.

Variant to_ek_spec t : option term → Type :=
| ToEKSome k of t = TKey Enc k : to_ek_spec t (Some t)
| ToEKNone of (∀ k, t ≠ TKey Enc k) : to_ek_spec t None.

Lemma to_ekP t : to_ek_spec t (to_ek t).
Proof.
case: t; try by right.
case; try by right.
by move=> t; eleft.
Qed.

Definition to_dk t :=
  if t is TKey Dec _ then Some t else None.

Variant to_dk_spec t : option term → Type :=
| ToDKSome k of t = TKey Dec k : to_dk_spec t (Some t)
| ToDKNone of (∀ k, t ≠ TKey Dec k) : to_dk_spec t None.

Lemma to_dkP t : to_dk_spec t (to_dk t).
Proof.
case: t; try by right.
case; try by right.
by move=> t; eleft.
Qed.

Definition of_list_aux : seal (foldr TPair (TInt 0)). by eexists. Qed.
Definition of_list := unseal of_list_aux.
Lemma of_list_eq : of_list = foldr TPair (TInt 0).
Proof. exact: seal_eq. Qed.

Fixpoint to_list t : option (list term) :=
  match t with
  | TInt 0 => Some []
  | TPair t1 t2 =>
    match to_list t2 with
    | Some l => Some (t1 :: l)
    | None => None
    end
  | _ => None
  end.

Lemma of_listK l : to_list (of_list l) = Some l.
Proof. rewrite of_list_eq; by elim: l => //= t l ->. Qed.

Lemma to_listK t ts :
  to_list t = Some ts →
  t = of_list ts.
Proof.
rewrite of_list_eq /=; elim/term_ind': t ts => //.
  by case=> [] // _ [<-].
move=> t _ ts' IH /= ts.
case e: to_list => [ts''|] // [<-].
by rewrite /= (IH _ e).
Qed.

Inductive to_list_spec : term → option (list term) → Type :=
| ToListSome ts : to_list_spec (of_list ts) (Some ts)
| ToListNone t  : to_list_spec t None.

Lemma to_listP t : to_list_spec t (to_list t).
Proof.
case e: to_list => [ts|]; last constructor.
by rewrite (to_listK _ _ e); constructor.
Qed.

Lemma of_list_inj : Inj eq eq of_list.
Proof.
move=> ts1 ts2 e; apply: Some_inj.
by rewrite -of_listK e of_listK.
Qed.

Definition tenc c k t := enc k (tag c t).

Definition tdec c k t :=
  match dec k t with
  | Some t => untag c t
  | None => None
  end.

Definition texp t1 t2 :=
  if t1 is TExp' base exp _ then
    TExp base (t2 :: map fold_term exp)
  else TInt 0.

Lemma texpA t1 ts1 t2 : texp (TExp t1 ts1) t2 = TExp t1 (t2 :: ts1).
Proof.
rewrite /texp {1}unlock /= fold_wf_termE normalize_unfold1 normalize_unfoldn.
rewrite unfold_termK.
apply: TExp_perm.
rewrite seq.perm_cons -{2}[ts1](seq.mapK unfold_termK).
by rewrite seq.perm_map // path.perm_sort.
Qed.

Lemma unfold_exp t1 t2 :
  unfold_term (texp t1 t2) = PreTerm.exp (unfold_term t1) (unfold_term t2).
Proof.
case: t1 => //= t1 ts1 /(ssrbool.elimT ssrbool.andP) [wf_ts1 ?].
rewrite unfold_TExp /=; congr PreTerm.PTExp.
apply: (ssrbool.elimT (perm_sort_leP _ _ _ _)); rewrite seq.perm_cons.
rewrite -[@List.map]/@seq.map -seq.map_comp seq.map_id_in //= => {}t1 in_ts1.
by rewrite fold_termK // (ssrbool.elimT seq.allP wf_ts1).
Qed.

Definition zero : term := TInt 0.

End Spec.

Arguments repr_term /.
Arguments Spec.tag_def /.
Arguments Spec.untag_def /.

Existing Instance Spec.of_list_inj.