Require Import List.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.Arith_base.

(*** terms and helper defs ***)

Definition level := nat.

Definition IndInfoH (T : Set) :=
  (level * (list ((list T) * (list (list T * list T)))))%type.

Inductive Term : Set :=
| Sort : level -> Term
| Pi : Term -> Term -> Term
| IndType : IndInfo -> TermList -> Term
| Var : nat -> Term
| App : Term -> Term -> Term
| Lam : Term -> Term -> Term
| CtorApp : IndInfo -> nat -> TermList -> TermList -> Term
| Elim : IndInfo -> TermList -> TermList -> Term -> Term
with TermList :=
| TL_nil : TermList
| TL_cons : TermList -> Term -> TermList
with Ctx :=
| Ctx_nil : Ctx
| Ctx_cons : Ctx -> Term -> Ctx
with IndInfo :=
| MkIndInfo : Ctx -> level -> CtorTypeList -> IndInfo
with CtorTypeList :=
| CTL_nil : CtorTypeList
| CTL_cons : CtorTypeList -> CtorType -> CtorTypeList
with CtorType :=
| MkCtorType : Ctx -> RecTpList -> TermList -> CtorType
with RecTpList :=
| RTL_nil : RecTpList
| RTL_cons : RecTpList -> RecTp -> RecTpList
with RecTp :=
| MkRecTp : Ctx -> TermList -> RecTp
.

(* Definition Ctx : Set := list Term. *)
(* Definition Ctx : Set := TermList. *)

(*** operations on my fake lists (stupid Coq) ***)

Fixpoint ctxLen (ctx : Ctx) :=
  match ctx with
    | Ctx_nil => 0
    | Ctx_cons ctx' _ => S (ctxLen ctx')
  end.

Fixpoint Ctx_app (ctx1 ctx2 : Ctx) :=
  match ctx2 with
    | Ctx_nil => ctx1
    | Ctx_cons ctx2' M => Ctx_cons (Ctx_app ctx1 ctx2') M
  end.

Fixpoint TL_Len (l : TermList) :=
  match l with
    | TL_nil => 0
    | TL_cons l' _ => S (TL_Len l')
  end.

Fixpoint TL_app (l1 l2 : TermList) :=
  match l2 with
    | TL_nil => l1
    | TL_cons l2' M => TL_cons (TL_app l1 l2') M
  end.

Fixpoint nth_or_fail_TL (n : nat) (l : TermList) : Term + { TL_Len l <= n } :=
  match n as n', l as l' return Term + { TL_Len l' <= n' } with
    | n, TL_nil => inright _ (le_O_n n)
    | 0, TL_cons _ M => inleft _ M
    | (S n'), (TL_cons l' _) =>
      match nth_or_fail_TL n' l' with
        | inleft M => inleft _ M
        | inright pf => inright _ (le_n_S _ _ pf)
      end
  end.

Fixpoint CTL_Len (l : CtorTypeList) :=
  match l with
    | CTL_nil => 0
    | CTL_cons l' _ => S (CTL_Len l')
  end.

Fixpoint nth_or_fail_CTL (n : nat) (l : CtorTypeList) : CtorType + { CTL_Len l <= n } :=
  match n as n', l as l' return CtorType + { CTL_Len l' <= n' } with
    | n, CTL_nil => inright _ (le_O_n n)
    | 0, CTL_cons _ ctp => inleft _ ctp
    | (S n'), (CTL_cons l' _) =>
      match nth_or_fail_CTL n' l' with
        | inleft ctp => inleft _ ctp
        | inright pf => inright _ (le_n_S _ _ pf)
      end
  end.

Inductive isNth_CTL (T : CtorType) : nat -> CtorTypeList -> Set :=
| isNth_CTL_base (l : CtorTypeList) : isNth_CTL T 0 (CTL_cons l T)
| isNth_CTL_cons (n : nat) (T' : CtorType) (l : CtorTypeList)
  : isNth_CTL T n l -> isNth_CTL T (S n) (CTL_cons l T').

Inductive isNth_TL (T : Term) : nat -> TermList -> Set :=
| isNth_TL_base (l : TermList) : isNth_TL T 0 (TL_cons l T)
| isNth_TL_cons (n : nat) (T' : Term) (l : TermList)
  : isNth_TL T n l -> isNth_TL T (S n) (TL_cons l T').

Inductive isNth_RTL (T : RecTp) : nat -> RecTpList -> Set :=
| isNth_RTL_base (l : RecTpList) : isNth_RTL T 0 (RTL_cons l T)
| isNth_RTL_cons (n : nat) (T' : RecTp) (l : RecTpList)
  : isNth_RTL T n l -> isNth_RTL T (S n) (RTL_cons l T').

Inductive isNth_Ctx (T : Term) : nat -> Ctx -> Set :=
| isNth_Ctx_base (ctx : Ctx) : isNth_Ctx T 0 (Ctx_cons ctx T)
| isNth_Ctx_cons (n : nat) (ctx : Ctx) (T' : Term)
  : isNth_Ctx T n ctx -> isNth_Ctx T (S n) (Ctx_cons ctx T').

(*** simple term maipulation ***)

Fixpoint makeLam (ctx : Ctx) (body : Term) {struct ctx} : Term :=
  match ctx with
    | Ctx_nil => body
    | Ctx_cons ctx' tp => makeLam ctx' (Lam tp body)
  end.
Fixpoint makePi (ctx : Ctx) (body : Term) {struct ctx} : Term :=
  match ctx with
    | Ctx_nil => body
    | Ctx_cons ctx' tp => makePi ctx' (Pi tp body)
  end.
Fixpoint makeApp (f : Term) (args : TermList) : Term :=
  match args with
    | TL_nil => f
    | TL_cons args' arg => App (makeApp f args') arg
  end.
Fixpoint makeVarList (n : nat) (ctx : Ctx) : TermList :=
  match ctx with
    | Ctx_nil => TL_nil
    | Ctx_cons ctx' tp => TL_cons (makeVarList (S n) ctx') (Var n)
  end.
Definition makeAppToVars (f : Term) (n : nat) (ctx : Ctx) : Term :=
  makeApp f (makeVarList n ctx).
(*
Fixpoint makeAppToVars (f : Term) (n : nat) (ctx : Ctx) : Term :=
  match ctx with
    | Ctx_nil => f
    | Ctx_cons ctx' tp => App (makeAppToVars f (S n) ctx') (Var n)
  end.
*)
Fixpoint makeVarListStep2 (n : nat) (ctx : Ctx) : TermList :=
  match ctx with
    | Ctx_cons (Ctx_cons ctx' tp1) tp2 =>
      TL_cons (makeVarListStep2 (S (S n)) ctx') (Var n)
    | _ => TL_nil
  end.

(* Definition dummyCtorType : CtorType := MkCtorType Ctx_nil RTL_nil TL_nil. *)

Definition ctorRecTps (ctp : CtorType) : RecTpList :=
  match ctp with
    MkCtorType ctx recTps indices => recTps
  end.

Definition numCtors (info : IndInfo) :=
  match info with
    MkIndInfo ctx l ctps => CTL_Len ctps
  end.

Definition nthCtorType (n : nat) (info : IndInfo) : option CtorType :=
  match info with
    MkIndInfo ctx l ctps =>
    match nth_or_fail_CTL n ctps with
      | inleft ctp => Some ctp
      | inright _ => None
(* | inright _ => dummyCtorType *)
    end
  end.

(*** proofs of the maximum sort + 1 in a term ***)
(* README: this (not entirely finished) is not closed under conv!
Inductive MaxSort (i : nat) : Term -> Set :=
| MS_Sort j : j < i -> MaxSort i (Sort j)
| MS_Pi A B i : MaxSort i A -> MaxSort i B -> MaxSort i (Pi A B)
| MS_IndType info args i :
  MaxSortIndInfo i info -> MaxSortTermList i args ->
  MaxSort i (IndType info args)
| MS_Var j i : MaxSort i (Var j)
| MS_App M N i : MaxSort i M -> MaxSort i N -> MaxSort i (App M N)
| MS_Lam A M i : MaxSort i A -> MaxSort i M -> MaxSort i (Lam A M)
| MS_CtorApp info j args recArgs i :
  MaxSortIndInfo i info -> MaxSortTermList i args ->
  MaxSortRecTpList i recArgs -> MaxSort i (CtorApp info j args recArgs)
| MS_Elim info fs params scrut i :
  MaxSortIndInfo i info -> MaxSortTermList i fs ->
  MaxSortTermList i params -> MaxSort i scrut ->
  MaxSort i (info fs params scrut)
with MaxSortTermList (i : nat) : TermList -> Set :=
| MS_TL_nil : MaxSortTermList i TL_nil
| MS_TL_cons l M : MaxSortTermList i l -> MaxSort i M ->
  MaxSortTermList i (TL_cons l M)
with MaxSortCtx (i : nat) : MaxSortCtx -> Set :=
| MS_Ctx_nil : MaxSortCtx i Ctx_nil
| MS_Ctx_cons l M : MaxSortCtx i l -> MaxSort i M ->
  MaxSortCtx i (Ctx_cons l M)
with MaxSortIndInfo (i : nat) : MaxSortIndInfo -> Set :=
| MS_MkIndInfo ctx j ctps :
  MaxSortCtx i ctx -> j <= i -> MaxSort
with MaxSortCtorTypeList (i : nat) : MaxSortCtorTypeList -> Set :=
| MS_CTL_nil : MaxSortCtorTypeList i CTL_nil
| MS_CTL_cons l M : MaxSortCtorTypeList i l -> MaxSort i M ->
  MaxSortCtorTypeList i (CTL_cons l M)
with MaxSortCtorType (i : nat) : MaxSortCtorType -> Set :=
| MS_MkCtorType : Ctx -> RecTpList -> TermList -> CtorType
with MaxSortRecTpList (i : nat) : MaxSortRecTpList -> Set :=
| MS_RTL_nil : MaxSortRecTpList i RTL_nil
| MS_RTL_cons l M : MaxSortRecTpList i l -> MaxSort i M ->
  MaxSortRecTpList i (RTL_cons l M)
with MaxSortRecTp (i : nat) : MaxSortRecTp -> Set :=
| MS_MkRecTp : Ctx -> TermList -> RecTp
.
*)

(*** substitution and lifting ***)

(* README: k is the amount we are incrementing the variables, and n is the
 * number of variable bindings under which we have traversed so far *)
Fixpoint lift (n k : nat) (M : Term) {struct M} : Term :=
  match M with
    | Sort i => Sort i
    | Pi A B => Pi (lift n k A) (lift (S n) k B)
    | IndType info indices =>
      IndType (liftIndInfo n k info) (liftTermList n k indices)
    | Var i =>
      match le_lt_dec n i with
        | left _ => Var (i + k) (* case: i >= n *)
        | right _ => Var i (* case: i < n *)
      end
    | App M1 M2 => App (lift n k M1) (lift n k M2)
    | Lam A M1 => Lam (lift n k A) (lift (S n) k M1)
    | CtorApp info i args recArgs =>
      CtorApp (liftIndInfo n k info) i (liftTermList n k args) (liftTermList n k recArgs)
    | Elim info fs params scrut =>
      Elim (liftIndInfo n k info) (liftTermList n k params)
      (liftTermList n k fs) (lift n k scrut)
  end
with liftTermList (n k : nat) (l : TermList) :=
  match l with
    | TL_nil => TL_nil
    | TL_cons l' M => TL_cons (liftTermList n k l') (lift n k M)
  end
with liftCtx (n k : nat) (ctx : Ctx) :=
  match ctx with
    | Ctx_nil => Ctx_nil
    | Ctx_cons ctx' M => Ctx_cons (liftCtx n k ctx') (lift (n + (ctxLen ctx')) k M)
  end
with liftIndInfo (n k : nat) (info : IndInfo) :=
  match info with
    | MkIndInfo ctx i ctorTypes => MkIndInfo (liftCtx n k ctx) i (liftCtorTypeList n k ctorTypes)
  end
with liftCtorTypeList (n k : nat) (l : CtorTypeList) :=
  match l with
    | CTL_nil => CTL_nil
    | CTL_cons l' ctp =>
      CTL_cons (liftCtorTypeList n k l') (liftCtorType n k ctp)
  end
with liftCtorType (n k : nat) (ctp : CtorType) :=
  match ctp with
    | MkCtorType ctx recCtx indices =>
      (MkCtorType (liftCtx n k ctx)
        (liftRecTpList (n + (ctxLen ctx)) k recCtx)
        (liftTermList (n + (ctxLen ctx)) k indices))
  end
with liftRecTpList (n k : nat) (l : RecTpList) :=
  match l with
    | RTL_nil => RTL_nil
    | RTL_cons l' r => RTL_cons (liftRecTpList n k l') (liftRecTp n k r)
  end
with liftRecTp (n k : nat) (r : RecTp) :=
  match r with
    | MkRecTp ctx indices =>
      MkRecTp (liftCtx n k ctx) (liftTermList (n + (ctxLen ctx)) k indices)
  end
  .

Fixpoint substH (n : nat) (s : TermList) (M : Term) {struct M} : Term :=
  match M with
    | Sort i => Sort i
    | Pi A B => Pi (substH n s A) (substH (S n) s B)
    | IndType info indices =>
      IndType (substIndInfo n s info) (substTermList n s indices)
    | Var i =>
      match le_lt_dec n i with
        | right _ => Var i (* case: i < n *)
        | left _ => (* case: i >= n *)
          match nth_or_fail_TL (i - n) s with
            | inleft N => lift 0 n N
            | _ => Var (i + n)
          end
      end
    | App M1 M2 => App (substH n s M1) (substH n s M2)
    | Lam A M1 => Lam (substH n s A) (substH (S n) s M1)
    | CtorApp info i args recArgs =>
      CtorApp (substIndInfo n s info) i (substTermList n s args) (substTermList n s recArgs)
    | Elim info fs params scrut =>
      Elim (substIndInfo n s info) (substTermList n s params)
      (substTermList n s fs) (substH n s scrut)
  end
with substTermList (n : nat) (s : TermList) (l : TermList) :=
  match l with
    | TL_nil => TL_nil
    | TL_cons l' M => TL_cons (substTermList n s l') (substH n s M)
  end
with substCtx (n : nat) (s : TermList) (ctx : Ctx) :=
  match ctx with
    | Ctx_nil => Ctx_nil
    | Ctx_cons ctx' M =>
      Ctx_cons (substCtx n s ctx') (substH (plus n (ctxLen ctx')) s M)
  end
with substIndInfo (n : nat) (s : TermList) (info : IndInfo) :=
  match info with
    | MkIndInfo ctx l ctorTypes =>
      MkIndInfo (substCtx n s ctx) l (substCtorTypeList n s ctorTypes)
  end
with substCtorTypeList (n : nat) (s : TermList) (l : CtorTypeList) :=
  match l with
    | CTL_nil => CTL_nil
    | CTL_cons l' ctp =>
      CTL_cons (substCtorTypeList n s l') (substCtorType n s ctp)
  end
with substCtorType (n : nat) (s : TermList) (ctp : CtorType) :=
  match ctp with
    | MkCtorType ctx recCtx indices =>
      (MkCtorType (substCtx n s ctx)
        (substRecTpList (plus n (ctxLen ctx)) s recCtx)
        (substTermList (plus n (ctxLen ctx)) s indices))
  end
with substRecTpList (n : nat) (s : TermList) (l : RecTpList) :=
  match l with
    | RTL_nil => RTL_nil
    | RTL_cons l' r => RTL_cons (substRecTpList n s l') (substRecTp n s r)
  end
with substRecTp (n : nat) (s : TermList) (r : RecTp) :=
  match r with
    | MkRecTp ctx indices =>
      MkRecTp (substCtx n s ctx) (substTermList (plus n (ctxLen ctx)) s indices)
  end
  .

Definition subst (s : TermList) (M : Term) := substH 0 s M.
Definition substOne (N M : Term) := substH 0 (TL_cons TL_nil N) M.

(*** auxiliary defs dependent on substitution ***)

Fixpoint termList2Ctx (l : TermList) : Ctx :=
  match l with
    | TL_nil => Ctx_nil
    | TL_cons l' A => Ctx_cons (termList2Ctx l') (lift 0 (TL_Len l') A)
  end.

(*** operations on inductive types: most of these require lifting ***)

Definition indLevel (info : IndInfo) :=
  match info with
    | MkIndInfo _ l _ => l
  end.

(* README: we assume info is well-typed in the "ambient" ctx, that
 * argCtx is well-formed in ctx, and that r is well-typed in (ctx,argCtx);
 * the returned term is well-typed in (ctx,argCtx) *)
Definition recTp2Type (info : IndInfo) (argCtx : Ctx) (r : RecTp) : Term :=
  match r with
    | MkRecTp ctx indices =>
      makePi ctx (IndType (liftIndInfo 0 (ctxLen ctx + ctxLen argCtx) info) indices)
  end.
Fixpoint recTps2Types (info : IndInfo) (argCtx : Ctx) (rs : RecTpList) : TermList :=
  match rs with
    | RTL_nil => TL_nil
    | RTL_cons rs' r =>
      TL_cons (recTps2Types info argCtx rs') (recTp2Type info argCtx r)
  end.

(* NOTE: the below requires lifting each result of (recTp2Type info r)
Fixpoint makeRecTpPi (info : IndInfo) (l : RecTpList) (body : Term) : Term :=
  match l with
    | RTL_nil => body
    | RTL_cons l' r => makeRecTpPi info l' (Pi (recTp2Type info r) body)
  end.
Definition ctorPiType (info : IndInfo) (ctp : CtorType) : Term :=
  match ctp with
    | MkCtorType ctx recCtx indices =>
      makePi ctx (makeRecTpPi info recCtx (IndType info indices))
  end.
*)

(*
Fixpoint recTp2Type (info : IndInfo) (r : RecTp) : Term :=
  match r with
    | MkRecTp arg recArgs => IndType info args
    | RT_cons varTp r' => Pi varTp (recTp2Type info r')
  end.
*)

(*
Definition isArgType (ctor i : nat) (info : IndInfo) (T : Term) : Set :=
  match info with
    | MkIndInfo _ ctorTypes =>
      { al : TermList & { rtl : RecTpList & isNth_CTL (MkCtorType al rtl) ctor ctorTypes & isNth_TL T i al } }
  end.

Definition isRecArgType (ctor i : nat) (info : IndInfo) (T : Term) : Set :=

  match info with
    | MkIndInfo _ ctorTypes =>
      { al : TermList & { rtl : RecTpList & isNth_CTL (MkCtorType al rtl) ctor ctorTypes & isNth_TL T i al } }
  end.
*)

(*** convertability ***)

(* README: we assume there is some "ambient" ctx and an argCtx for the
 * non-recursive args in the current constructor; elimF then takes in ctx',
 * some params that are well-typed in (ctx,argCtx,ctx'), and some scrut
 * that is well-typed in (ctx,ctx'), and returns a term well-typed in
 * (ctx,ctx'). *)
Definition elimRecArg (elimF : Ctx -> TermList -> Term -> Term)
  (r : RecTp) (recArg : Term) :=
  match r with
    | MkRecTp ctx indices =>
      makeLam ctx (elimF ctx indices
        (makeAppToVars (lift 0 (ctxLen ctx) recArg) 0 ctx))
  end.

(* README: elimRecArgsH takes each recursive argument recArg supplied
 * to a constructor and returns both recArg and the result of a
 * recursive call (using elimF) on recArg *)
Fixpoint elimRecArgsH (elimF : Ctx -> TermList -> Term -> Term)
  (rs : RecTpList) (recArgs : TermList) : option TermList :=
  match rs, recArgs with
    | RTL_nil, TL_nil => Some TL_nil
    | RTL_cons rs' r, TL_cons recArgs' recArg =>
      match elimRecArgsH elimF rs' recArgs' with
        | None => None
        | Some ret =>
          Some (TL_cons (TL_cons ret recArg) (elimRecArg elimF r recArg))
      end
    | _, _ => None
  end.

Definition elimRecArgs (info : IndInfo) (fs : TermList) (i : nat)
  (args : TermList) (recArgs : TermList) : option TermList :=
  match nthCtorType i info with
    | None => None
    | Some (MkCtorType ctx rs indices) =>
      elimRecArgsH (fun ctx params scrut =>
        Elim (liftIndInfo 0 (ctxLen ctx) info)
        (liftTermList 0 (ctxLen ctx) fs)
        (substTermList (ctxLen ctx) args params)
        scrut)
      rs recArgs
  end.

(*
Definition elimRecArg (info : IndInfo) (fs : TermList) (args : TermList) (r : RecTp) (recArg : Term) :=
  match r with
    | MkRecTp ctx indices =>
      makeLam ctx (
        Elim (liftIndInfo 0 (ctxLen ctx) info)
        (liftTermList 0 (ctxLen ctx) fs)
        (substTermList (ctxLen ctx) args indices)
        (makeAppToVars (lift 0 (ctxLen ctx) recArg) 0 ctx)
      )
  end.

Fixpoint elimRecArgsH (info : IndInfo) (fs : TermList) (args : TermList)
  (rs : RecTpList) (recArgs : TermList) : option TermList :=
  match rs, recArgs with
    | RTL_nil, TL_nil => Some TL_nil
    | RTL_cons rs' r, TL_cons recArgs' recArg =>
      match elimRecArgsH info fs args rs' recArgs' with
        | None => None
        | Some ret => Some (TL_cons ret (elimRecArg info fs args r recArg))
      end
    | _, _ => None
  end.

Definition elimRecArgs (info : IndInfo) (fs : TermList) (i : nat)
  (args : TermList) (recArgs : TermList) : option TermList :=
  match nthCtorType i info with
    | None => None
    | Some (MkCtorType ctx rs indices) =>
      elimRecArgsH info fs args rs recArgs
  end.
*)

Inductive rrto : Term -> Term -> Set :=
| RR_Beta : forall A M N, rrto (App (Lam A M) N) (substOne N M)
| RR_iota : forall info info' fs f params i args recArgs elimArgs,
  nth_or_fail_TL i fs = inleft _ f ->
  elimRecArgs info fs i args recArgs = Some elimArgs ->
  rrto (Elim info fs params (CtorApp info' i args recArgs))
  (makeApp (makeApp f args) elimArgs)
| RR_Pi1 : forall A A' B, rrto A A' -> rrto (Pi A B) (Pi A' B)
| RR_Pi2 : forall A B B', rrto B B' -> rrto (Pi A B) (Pi A B')
| RR_App1 : forall f f' a , rrto f f' -> rrto (App f a) (App f' a)
| RR_App2 : forall f a a', rrto a a' -> rrto (App f a) (App f a')
| RR_Lam1 : forall A A' M, rrto A A' -> rrto (Lam A M) (Lam A' M)
| RR_Lam2 : forall A M M', rrto M M' -> rrto (Lam A M) (Lam A M')
| RR_Elim1 : forall info info' fs params scrut,
  rrtoIndInfo info info' ->
    rrto (Elim info fs params scrut) (Elim info' fs params scrut)
| RR_Elim2 : forall info fs fs' params scrut,
  rrtoTermList fs fs' ->
    rrto (Elim info fs params scrut) (Elim info fs' params scrut)
| RR_Elim3 : forall info fs params params' scrut,
  rrtoTermList params params' ->
    rrto (Elim info fs params scrut) (Elim info fs params' scrut)
| RR_Elim4 : forall info fs params scrut scrut',
  rrto scrut scrut' ->
    rrto (Elim info fs params scrut) (Elim info fs params scrut')
with rrtoTermList : TermList -> TermList -> Set :=
| RR_TL_cons1 : forall M l l',
  rrtoTermList l l' -> rrtoTermList (TL_cons l M) (TL_cons l' M)
| RR_TL_cons2 : forall M M' l,
  rrto M M' -> rrtoTermList (TL_cons l M) (TL_cons l M')
with rrtoCtx : Ctx -> Ctx -> Set :=
| RR_Ctx_cons1 : forall ctx ctx' M,
  rrtoCtx ctx ctx' -> rrtoCtx (Ctx_cons ctx M) (Ctx_cons ctx' M)
| RR_Ctx_cons2 : forall ctx M M',
  rrto M M' -> rrtoCtx (Ctx_cons ctx M) (Ctx_cons ctx M')
with rrtoIndInfo : IndInfo -> IndInfo -> Set :=
| RR_MkIndInfo1 : forall ctx ctx' i ctps,
  rrtoCtx ctx ctx' ->
  rrtoIndInfo (MkIndInfo ctx i ctps) (MkIndInfo ctx' i ctps)
| RR_MkIndInfo2 : forall ctx i ctps ctps',
  rrtoCtorTypeList ctps ctps' ->
  rrtoIndInfo (MkIndInfo ctx i ctps) (MkIndInfo ctx i ctps')
with rrtoCtorTypeList : CtorTypeList -> CtorTypeList -> Set :=
| RR_CTL_cons1 : forall ctp l l',
  rrtoCtorTypeList l l' -> rrtoCtorTypeList (CTL_cons l ctp) (CTL_cons l' ctp)
| RR_CTL_cons2 : forall ctp ctp' l,
  rrtoCtorType ctp ctp' -> rrtoCtorTypeList (CTL_cons l ctp) (CTL_cons l ctp')
with rrtoCtorType : CtorType -> CtorType -> Set :=
| RR_MkCtorType1 : forall ctx ctx' rs indices,
  rrtoCtx ctx ctx' ->
  rrtoCtorType (MkCtorType ctx rs indices) (MkCtorType ctx' rs indices)
| RR_MkCtorType2 : forall ctx rs rs' indices,
  rrtoRecTpList rs rs' ->
  rrtoCtorType (MkCtorType ctx rs indices) (MkCtorType ctx rs' indices)
| RR_MkCtorType3 : forall ctx rs indices indices',
  rrtoTermList indices indices' ->
  rrtoCtorType (MkCtorType ctx rs indices) (MkCtorType ctx rs indices')
with rrtoRecTpList : RecTpList -> RecTpList -> Set :=
| RR_RTL_cons1 : forall r l l',
  rrtoRecTpList l l' -> rrtoRecTpList (RTL_cons l r) (RTL_cons l' r)
| RR_RTL_cons2 : forall r r' l,
  rrtoRecTp r r' -> rrtoRecTpList (RTL_cons l r) (RTL_cons l r')
with rrtoRecTp : RecTp -> RecTp -> Set :=
| RR_MkRecTp1 : forall ctx ctx' indices,
  rrtoCtx ctx ctx' ->
  rrtoRecTp (MkRecTp ctx indices) (MkRecTp ctx' indices)
| RR_MkRecTp2 : forall ctx indices indices',
  rrtoTermList indices indices' ->
  rrtoRecTp (MkRecTp ctx indices) (MkRecTp ctx indices')
.

Inductive conv : Term -> Term -> Set :=
| conv_refl : forall M , conv M M
| conv_stepR : forall M1 M2 M3 , rrto M1 M2 -> conv M2 M3 ->
  conv M1 M3
| conv_stepL : forall M1 M2 M3 , rrto M2 M1 -> conv M2 M3 ->
  conv M1 M3
.

(*** sub-typing ***)

Inductive subtype : Term -> Term -> Set :=
| SubTp_Refl : forall T , subtype T T
| SubTp_Sort : forall i j , i <= j -> subtype (Sort i) (Sort j)
| SubTp_Pi : forall A B B' , subtype B B' -> subtype (Pi A B) (Pi A B')
.

(*** typing ***)

(* translates a RecTp into the type of the eliminator for that RecTp
 *
 * README: we assume an "ambient" ctx, an argCtx that quantifies over
 * the non-recursive args for the current constructor, and an indCtx
 * that quantifies over the index args to the current inductive type,
 * where the latter two must be well-formed relative to ctx; we then
 * assume that r is well-typed w.r.t. (ctx,argCtx) and that B is
 * well-typed w.r.t. (ctx,argCtx,indCtx, --some IndType-- ), and
 * return a term that is well-typed in (ctx,argCtx, 0 : r)
 *)
Definition recTp2ElimType (r : RecTp) B :=
  match r with
    | MkRecTp ctx indices =>
      makePi (liftCtx 0 1 ctx) (substH ((ctxLen ctx) + 1)
        (TL_cons (liftTermList (ctxLen ctx) 1 indices)
          (makeAppToVars (Var (ctxLen ctx)) 0 ctx))
        (lift 0 ((ctxLen ctx) + 1) B))
  end.

(* README: we make the same context assumptions as recTp2ElimType and,
 * in addition, that info is well-typed in the "ambient" ctx. *)
Fixpoint recTps2ElimCtx (info : IndInfo) (argCtx : Ctx) (rs : RecTpList) B :=
  match rs with
    | RTL_nil => Ctx_nil
    | RTL_cons rs' r =>
      Ctx_cons (Ctx_cons (recTps2ElimCtx info argCtx rs' B)
        (lift 0 (ctxLen (recTps2ElimCtx info argCtx rs' B))
          (recTp2Type info argCtx r)))
      (lift 1 (ctxLen (recTps2ElimCtx info argCtx rs' B)) (recTp2ElimType r B))
  end.

(* README: same context assumptions as recTp2sElimCtx, but ctp is
 * well-typed w.r.t. the "ambient" ctx and B is well-typed w.r.t.
 * (ctx,indCtx, --some IndType--); we return a term that is well-typed
 * w.r.t. the ambient ctx *)
Definition ctorElimType (info : IndInfo) (indCtx : Ctx) (i : nat) (ctp : CtorType) B :=
  match ctp with
    | MkCtorType argCtx rs indices =>
      let elimCtx := (recTps2ElimCtx info argCtx rs
        (lift (ctxLen indCtx + 1) (ctxLen argCtx) B)) in
      makePi argCtx (
        makePi elimCtx
        (subst
          (TL_cons (liftTermList 0 (ctxLen elimCtx) indices)
            (CtorApp (liftIndInfo 0 (ctxLen argCtx + ctxLen elimCtx) info)
              i
              (makeVarList (ctxLen elimCtx) argCtx)
              (makeVarListStep2 0 elimCtx)
            ))
          (lift (ctxLen indCtx + 1) (ctxLen argCtx + ctxLen elimCtx) B))
      )
  end.

Fixpoint elimFsTypesH (info : IndInfo) (indCtx : Ctx) (i : nat) (ctps : CtorTypeList) B :=
  match ctps with
    | CTL_nil => TL_nil
    | CTL_cons ctps' ctp =>
      TL_cons (elimFsTypesH info indCtx (S i) ctps' B)
      (ctorElimType info indCtx i ctp B)
  end.

Definition elimFsTypes (info : IndInfo) B :=
  match info with
    | MkIndInfo indCtx _ ctps => elimFsTypesH info indCtx 0 ctps B
  end.

Inductive HasTp (ctx : Ctx) : Term -> Term -> Set :=
| HT_convR : forall M T T' , HasTp ctx M T -> rrto T T' -> HasTp ctx M T'
| HT_convL : forall M T T' , HasTp ctx M T -> rrto T' T -> HasTp ctx M T'
| HT_sub : forall M T T' , HasTp ctx M T -> subtype T T' -> HasTp ctx M T'
(* | HT_Prp : forall i , HasTp ctx Prp (Sort i) *)
| HT_Sort : forall i, HasTp ctx (Sort i) (Sort (S i))
| HT_Pi_P : forall i A B ,
  HasTp ctx A (Sort i) ->
  HasTp (Ctx_cons ctx A) B (Sort i) ->
  HasTp ctx (Pi A B) (Sort i)
| HT_Pi_I : forall i A B ,
  HasTp ctx A (Sort i) ->
  HasTp (Ctx_cons ctx A) B (Sort 0) ->
  HasTp ctx (Pi A B) (Sort 0)
| HT_IndType : forall info indices indCtx i ,
  WfIndInfo ctx info indCtx i ->
  HasTpTermList ctx indices indCtx ->
  HasTp ctx (IndType info indices) (Sort i)
| HT_Var : forall i T, isNth_Ctx T i ctx ->
  HasTp ctx (Var i) T
| HT_App : forall A B M N,
  HasTp ctx M (Pi A B) -> HasTp ctx N A ->
  HasTp ctx (App M N) (substOne N B)
| HT_Lam : forall i A M B,
  HasTp ctx A (Sort i) ->
  HasTp (Ctx_cons ctx A) M B ->
  HasTp ctx (Lam A M) (Pi A B)
| HT_CtorApp : forall info indCtx indI argCtx rs indices i args recArgs,
  WfIndInfo ctx info indCtx indI ->
  nthCtorType i info = Some (MkCtorType argCtx rs indices) ->
  HasTpTermList ctx args argCtx ->
  HasTpTermList_TL ctx recArgs (recTps2Types info argCtx rs) ->
  HasTp ctx (CtorApp info i args recArgs)
  (IndType info (substTermList 0 args indices))
| HT_Elim_P : forall info indCtx indI fs params scrut B Bi,
  WfIndInfo ctx info indCtx (S indI) ->
  (HasTp
    (Ctx_cons (Ctx_app ctx indCtx)
      (IndType (liftIndInfo 0 (ctxLen indCtx) info) (makeVarList 0 indCtx)))
    B (Sort Bi)) ->
  HasTpTermList_TL ctx fs (elimFsTypes info B) ->
  HasTpTermList ctx params indCtx ->
  HasTp ctx scrut (IndType info params) ->
  HasTp ctx (Elim info fs params scrut) (subst (TL_cons params scrut) B)
| HT_Elim_I : forall info indCtx fs params scrut B Bi,
  WfIndInfo ctx info indCtx 0 ->
  (HasTp
    (Ctx_cons (Ctx_app ctx indCtx)
      (IndType (liftIndInfo 0 (ctxLen indCtx) info) (makeVarList 0 indCtx)))
    B (Sort Bi)) ->
  ((Bi = 0) + (numCtors info <= 1)) ->
  HasTpTermList_TL ctx fs (elimFsTypes info B) ->
  HasTpTermList ctx params indCtx ->
  HasTp ctx scrut (IndType info params) ->
  HasTp ctx (Elim info fs params scrut) (subst (TL_cons params scrut) B)
(*
| HT_Elim_I0 : forall indCtx params scrut B,
  WfCtx ctx indCtx 0 ->
  HasTpTermList ctx params indCtx ->
  HasTp ctx scrut (IndType (MkIndInfo indCtx 0 CTL_nil) params) ->
  HasTp ctx (Elim (MkIndInfo indCtx 0 CTL_nil) TL_nil params scrut) (subst (TL_cons params scrut) B)
*)

(* FIXME: impredicative elims *)

with HasTpTermList (ctx : Ctx) : TermList -> Ctx -> Set :=
| HT_TL_nil : HasTpTermList ctx TL_nil Ctx_nil
| HT_TL_cons : forall l lCtx M T,
  HasTpTermList ctx l lCtx -> HasTp ctx M (subst l T) ->
  HasTpTermList ctx (TL_cons l M) (Ctx_cons lCtx T)

(* same as above, but with no substitution, since the types are not a
 * Ctx, and so are not dependent *)
with HasTpTermList_TL (ctx : Ctx) : TermList -> TermList -> Set :=
| HT_TL_nil_TL : HasTpTermList_TL ctx TL_nil TL_nil
| HT_TL_cons_TL : forall l Ts M T,
  HasTpTermList_TL ctx l Ts -> HasTp ctx M T ->
  HasTpTermList_TL ctx (TL_cons l M) (TL_cons Ts T)

(* states that a Ctx is well-formed with max sort i *)
with WfCtx (ctx : Ctx) : Ctx -> nat -> Set :=
| WF_Ctx_nil : forall i, WfCtx ctx Ctx_nil i
| WF_Ctx_cons : forall ctx' A i,
  WfCtx ctx ctx' i -> HasTp ctx A (Sort i) -> WfCtx ctx (Ctx_cons ctx' A) i

with WfIndInfo (ctx : Ctx) : IndInfo -> Ctx -> nat -> Set :=
| WF_MkIndInfo : forall indCtx i ctps,
  WfCtx ctx indCtx i ->
  WfCtorTypeList ctx indCtx ctps i ->
  WfIndInfo ctx (MkIndInfo indCtx i ctps) indCtx i

with WfCtorTypeList (ctx : Ctx) : Ctx -> CtorTypeList -> nat -> Set :=
| WF_CTL_nil : forall indCtx i, WfCtorTypeList ctx indCtx CTL_nil i
| WF_CTL_cons : forall indCtx i ctps ctp,
  WfCtorTypeList ctx indCtx ctps i ->
  WfCtorType ctx indCtx ctp i ->
  WfCtorTypeList ctx indCtx (CTL_cons ctps ctp) i

with WfCtorType (ctx : Ctx) : Ctx -> CtorType -> nat -> Set :=
| WF_MkCtorType : forall indCtx argCtx i r indices,
  WfCtx ctx argCtx i ->
  WfRecTpList ctx indCtx argCtx r i ->
  HasTpTermList (Ctx_app ctx argCtx) indices indCtx ->
  WfCtorType ctx indCtx (MkCtorType argCtx r indices) i

with WfRecTpList (ctx : Ctx) : Ctx -> Ctx -> RecTpList -> nat -> Set :=
| WF_RTL_nil : forall indCtx argCtx i, WfRecTpList ctx indCtx argCtx RTL_nil i
| WF_RTL_cons : forall indCtx argCtx i rs r,
  WfRecTpList ctx indCtx argCtx rs i ->
  WfRecTp ctx indCtx argCtx r i ->
  WfRecTpList ctx indCtx argCtx (RTL_cons rs r) i

with WfRecTp (ctx : Ctx) : Ctx -> Ctx -> RecTp -> nat -> Set :=
| WF_MkRecTp : forall indCtx argCtx i recCtx recIndices,
  WfCtx (Ctx_app ctx argCtx) recCtx i ->
  HasTpTermList (Ctx_app ctx argCtx) recIndices indCtx ->
  WfRecTp ctx indCtx argCtx (MkRecTp recCtx recIndices) i
.


From mathcomp Require Import ssreflect eqtype.
From deriving Require Import deriving.

Require Import type.

Scheme value_rect := Induction for value Sort Type.

(* we cannot derive from word, so we are stuck... *)

Fail Definition value_indDef := [indDef for value_rect].


From Coq.Unicode Require Import Utf8.
From Coq.Lists Require Import List.
From Coq.Program Require Import Wf.
From Coq.Arith Require Import Wf_nat.
From Autosubst Require Import Autosubst.
From Coq.Relations Require Import Relations.
From Coq.micromega Require Import Lia.
From ShortLogrels Require Import prelude language systemF_rec_cbv.

Inductive type_lt : type → type → Prop :=
| TProd_lt1 τ τ' : type_lt τ (TProd τ τ')
| TProd_lt2 τ τ' : type_lt τ' (TProd τ τ')
| TFun_lt1 τ τ' : type_lt τ (TFun τ τ')
| TFun_lt2 τ τ' : type_lt τ' (TFun τ τ').

Definition wf_rel (nτ nτ' : nat * type) : Prop :=
  fst nτ < fst nτ' ∨ (fst nτ ≤ fst nτ' ∧ type_lt (snd nτ) (snd nτ')).

Lemma wf_rel_well_founded : well_founded wf_rel.
Proof.
  intros [n τ].
  revert τ; induction (lt_wf n) as [n Hn IHn]; intros τ.
  assert (∃ k, k = n ∧ k ≤ n) as [k [Heq Hk]] by (exists n; lia).
  rewrite <- Heq; clear Heq.
  revert k Hk; induction τ; intros k Hk.
  - constructor; intros [] Hlt.
    inversion Hlt as [|[? Hlt']]; simpl in *; [apply IHn; lia|subst].
    inversion Hlt'.
  - constructor; intros [] Hlt.
    inversion Hlt as [|[? Hlt']]; simpl in *; [apply IHn; lia|subst].
    inversion Hlt'.
  - constructor; intros [] Hlt.
    inversion Hlt as [|[? Hlt']]; simpl in *; [apply IHn; lia|subst].
    inversion Hlt'; subst.
    + eapply IHτ1; lia.
    + eapply IHτ2; lia.
  - constructor; intros [] Hlt.
    inversion Hlt as [|[? Hlt']]; simpl in *; [apply IHn; lia|subst].
    inversion Hlt'; subst.
    + eapply IHτ1; lia.
    + eapply IHτ2; lia.
  - constructor; intros [] Hlt.
    inversion Hlt as [|[? Hlt']]; simpl in *; [apply IHn; lia|subst].
    inversion Hlt'.
  - constructor; intros [] Hlt.
    inversion Hlt as [|[? Hlt']]; simpl in *; [apply IHn; lia|subst].
    inversion Hlt'.
Qed.

Ltac solve_wf_rel := solve [left; simpl; lia|right; split; [simpl; lia|simpl; constructor]].

Program Definition SISafe' (n : nat) (P : ∀ k, k < n → expr → Prop) (e : expr) :=
    ∀ k e' (Hle : k ≤ n),
      nsteps k e e' → (is_val e' ∧ ∀ (Hpos : 0 < k), P (n - k) _ e') ∨ ∃ e'', step e' e''.
Next Obligation.
Proof. lia. Qed.

Lemma SISafe'_ext (n : nat) (P Q : ∀ k, k < n → expr → Prop) (e : expr) :
  (∀ k Hle v, P k Hle v ↔ Q k Hle v) → SISafe' n P e ↔ SISafe' n Q e.
Proof.
  intros Hext; split; intros Hsf ????.
  - edestruct Hsf as [[]|]; [eassumption|left|right; assumption].
    split; [assumption|intros; apply Hext; auto].
  - edestruct Hsf as [[]|]; [eassumption|left|right; assumption].
    split; [assumption|intros; apply Hext; auto].
Qed.

Lemma SISafe'_SISafe P n e : ¬ is_val e → SISafe' n (λ k _ v, P k v) e ↔ SISafe P n e.
Proof.
  intros Hniv; split.
  - intros Hsf; intros k e' Hk Hstps.
    destruct k as [|k].
    + inversion Hstps; subst.
      destruct (Hsf 0 e' Hk Hstps) as [[]|]; tauto.
    + destruct (Hsf (S k) e' Hk Hstps) as [[? HP]|]; [|tauto].
      left; split; [assumption|].
      apply HP; lia.
  - intros Hsf; intros k e' Hk Hstps.
    destruct (Hsf k e' Hk Hstps) as [[? HP]|]; tauto.
Qed.

Lemma lt_le_le {n m l} : n < m → m ≤ l → n ≤ l.
Proof. lia. Qed.

Lemma prod_lt1 {k τ1 τ2} : wf_rel (k, τ1) (k, TProd τ1 τ2).
Proof. solve_wf_rel. Qed.
Lemma prod_lt2 {k τ1 τ2} : wf_rel (k, τ2) (k, TProd τ1 τ2).
Proof. solve_wf_rel. Qed.
Lemma fun_lt1 {n τ1 τ2 k} : k ≤ n → wf_rel (k, τ1) (n, TFun τ1 τ2).
Proof. solve_wf_rel. Qed.
Lemma fun_lt2 {n τ1 τ2 k} : k ≤ n → wf_rel (k, τ2) (n, TFun τ1 τ2).
Proof. solve_wf_rel. Qed.
Lemma si_lt {n τ τ' z} : z < n → wf_rel (z, τ') (n, τ).
Proof. solve_wf_rel. Qed.

Lemma pos_sub_lt {n m} : 0 < m → m ≤ n → n - m < n.
Proof. lia. Qed.
Lemma lt_eq_S n m : S n = m → n < m.
Proof. lia. Qed.

Definition val_rel_aux_prod {k τ1 τ2}
  (vlrl : ∀ nτ', wf_rel nτ' (k, TProd τ1 τ2) → expr → Prop) v :=
  ∃ v1 v2, v = Pair v1 v2 ∧ vlrl (k, τ1) prod_lt1 v1 ∧ vlrl (k, τ2) prod_lt2 v2.

Lemma val_rel_aux_prod_ext n τ1 τ2 (f g : ∀ nτ', wf_rel nτ' (n, TProd τ1 τ2) → expr → Prop) e :
  (∀ m τ Hrl e, f (m, τ) Hrl e ↔ g (m, τ) Hrl e) →
  val_rel_aux_prod f e ↔ val_rel_aux_prod g e.
Proof.
  intros Hfg; split; intros (?&?&->&?&?); (eexists _, _; split; [reflexivity|]; split);
    (apply Hfg; assumption).
Qed.

Definition val_rel_aux_fun {k τ1 τ2}
  (vlrl : ∀ nτ', wf_rel nτ' (k, TFun τ1 τ2) → expr → Prop) v :=
  is_val v ∧
  ∀ m w (Hle : m ≤ k),
    vlrl (m, τ1) (fun_lt1 Hle) w →
    SISafe' m (λ z Hlt u, vlrl (z, τ2) (fun_lt2 (lt_le_le Hlt Hle)) u) (App v w).

Lemma val_rel_aux_fun_ext n τ1 τ2 (f g : ∀ nτ', wf_rel nτ' (n, TFun τ1 τ2) → expr → Prop) e :
  (∀ m τ Hrl e, f (m, τ) Hrl e ↔ g (m, τ) Hrl e) →
  val_rel_aux_fun f e ↔ val_rel_aux_fun g e.
Proof.
  intros Hfg; split; intros [Hiv Hrl]; (split; [assumption|]).
  - intros m w Hle Hvrl.
    eapply SISafe'_ext; [|apply Hrl; apply Hfg; eassumption].
    intros; symmetry; apply Hfg.
  - intros m w Hle Hvrl.
    eapply SISafe'_ext; [|apply Hrl; apply Hfg; eassumption].
    intros; apply Hfg.
Qed.

Definition val_rel_aux_forall {k τ}
  (vlrl : ∀ nτ', wf_rel nτ' (k, TForAll τ) → expr → Prop) v :=
  is_val v ∧ ∀ τ', SISafe' k (λ z Hlt u, vlrl (z, τ.[τ'/]) (si_lt Hlt) u) (TApp v).

Lemma val_rel_aux_forall_ext n τ (f g : ∀ nτ', wf_rel nτ' (n, TForAll τ) → expr → Prop) e :
  (∀ m τ Hrl e, f (m, τ) Hrl e ↔ g (m, τ) Hrl e) →
  val_rel_aux_forall f e ↔ val_rel_aux_forall g e.
Proof.
  intros Hfg; split; intros [Hiv Hrl]; (split; [assumption|]);
    intros τ'.
  - eapply SISafe'_ext; [|apply Hrl; apply Hfg; eassumption].
    intros; symmetry; apply Hfg.
  - eapply SISafe'_ext; [|apply Hrl; apply Hfg; eassumption].
    intros; apply Hfg.
Qed.

Definition val_rel_aux_rec {k τ}
  (vlrl : ∀ nτ', wf_rel nτ' (k, TRec τ) → expr → Prop) v :=
  is_val v ∧
    ∃ w, v = Fold w ∧
      match k as u return u = k → Prop with
      | 0 => λ _, True
      | S n' => λ Heq, vlrl (n', τ.[TRec τ/]) (si_lt (lt_eq_S _ _ Heq)) w
      end eq_refl.

Lemma val_rel_aux_rec_ext n τ (f g : ∀ nτ', wf_rel nτ' (n, TRec τ) → expr → Prop) e :
  (∀ m τ Hrl e, f (m, τ) Hrl e ↔ g (m, τ) Hrl e) →
  val_rel_aux_rec f e ↔ val_rel_aux_rec g e.
Proof.
  intros Hfg; split; intros [Hiv (w & -> & Hw)]; (split; [assumption|]).
  - eexists _; split; [reflexivity|].
    destruct n; [tauto|].
    apply Hfg; assumption.
  - eexists _; split; [reflexivity|].
    destruct n; [tauto|].
    apply Hfg; assumption.
Qed.

Definition val_rel_aux
  (nτ : nat * type) (vlrl : ∀ nτ', wf_rel nτ' nτ → expr → Prop) (v : expr) : Prop :=
  match snd nτ as u return (∀ nτ', wf_rel nτ' (fst nτ, u) → expr → Prop) → Prop with
  | TUnit => λ _, v = TT
  | TVar X => λ _, False
  | TProd τ1 τ2 => λ vlrl', val_rel_aux_prod vlrl' v
  | TFun τ1 τ2 => λ vlrl', val_rel_aux_fun vlrl' v
  | TForAll τ => λ vlrl', val_rel_aux_forall vlrl' v
  | TRec τ => λ vlrl', val_rel_aux_rec vlrl' v
  end vlrl.

Lemma val_rel_aux_ext n τ (f g : ∀ nτ', wf_rel nτ' (n, τ) → expr → Prop) e :
  (∀ m τ Hrl e, f (m, τ) Hrl e ↔ g (m, τ) Hrl e) →
  val_rel_aux (n, τ) f e ↔ val_rel_aux (n, τ) g e.
Proof.
  intros Hfg.
  induction τ; simpl; [tauto|tauto| | | |].
  - apply val_rel_aux_prod_ext; auto.
  - apply val_rel_aux_fun_ext; auto.
  - apply val_rel_aux_forall_ext; auto.
  - apply val_rel_aux_rec_ext; auto.
Qed.

Fixpoint val_rel_aux' (nτ : nat * type) (Hacc : Acc wf_rel nτ) (v : expr) : Prop :=
  match Hacc return Prop with
  | Acc_intro _ MkAcc => val_rel_aux nτ (λ nτ' Hnτ', val_rel_aux' nτ' (MkAcc _ Hnτ')) v
  end.

Lemma val_rel_aux'_irrel (nτ : nat * type) (Hacc Hacc' : Acc wf_rel nτ) (v : expr) :
  val_rel_aux' nτ Hacc v ↔ val_rel_aux' nτ Hacc' v.
Proof.
  revert Hacc Hacc' v.
  induction (wf_rel_well_founded nτ) as [[n τ] ? IH]; intros Hacc Hacc' v.
  destruct Hacc; destruct Hacc'; simpl.
  apply val_rel_aux_ext.
  intros m τ' Hrl e'; simpl.
  apply IH; assumption.
Qed.

Definition val_rel (τ : type) (n : nat) (v : expr) :=
  val_rel_aux' (n, τ) (wf_rel_well_founded (n, τ)) v.

Lemma val_rel_unfold n τ e :
  val_rel τ n e ↔ val_rel_aux (n, τ) (λ nτ' _ e', val_rel (snd nτ') (fst nτ') e') e.
Proof.
  remember (n, τ) as nτ; symmetry in Heqnτ.
  revert n τ Heqnτ e.
  induction (wf_rel_well_founded nτ) as [[n τ] ? IH]; intros n' τ' Heqnτ e.
  inversion Heqnτ; subst; clear Heqnτ.
  unfold val_rel.
  destruct wf_rel_well_founded; simpl.
  apply val_rel_aux_ext.
  intros m τ' Hrl e'; simpl.
  apply val_rel_aux'_irrel.
Qed.

Opaque val_rel.

Definition expr_rel (τ : type) (n : nat) (e : expr) := SISafe (val_rel τ) n e.

Lemma val_rel_unit n e : val_rel TUnit n e ↔ e = TT.
Proof. rewrite val_rel_unfold; destruct n; simpl; tauto. Qed.

Lemma val_rel_var X n e : val_rel (TVar X) n e ↔ False.
Proof. rewrite val_rel_unfold; destruct n; simpl; tauto. Qed.

Lemma val_rel_prod τ1 τ2 n e :
  val_rel (TProd τ1 τ2) n e ↔ ∃ v1 v2, e = Pair v1 v2 ∧ val_rel τ1 n v1 ∧ val_rel τ2 n v2.
Proof. rewrite val_rel_unfold; simpl; tauto. Qed.

Lemma val_rel_fun τ1 τ2 n e :
  val_rel (TFun τ1 τ2) n e ↔ is_val e ∧ ∀ k w, k ≤ n → val_rel τ1 k w → expr_rel τ2 k (App e w).
Proof.
  rewrite val_rel_unfold; unfold val_rel_aux; simpl; unfold val_rel_aux_fun.
  split; intros [? Her]; (split; [assumption|]);
    intros; (apply SISafe'_SISafe; [inversion 1|apply Her; eauto]).
Qed.

Lemma val_rel_tforall τ n e :
  val_rel (TForAll τ) n e ↔ is_val e ∧ ∀ τ', expr_rel τ.[τ'/] n (TApp e).
Proof.
  rewrite val_rel_unfold; simpl.
  split; intros [? Her]; (split; [assumption|]);
    intros; (apply SISafe'_SISafe; [inversion 1|apply Her]).
Qed.

Lemma val_rel_trec τ n e :
  val_rel (TRec τ) n e ↔
  is_val e ∧ ∃ w, e = Fold w ∧ match n with 0 => True | S n' => val_rel τ.[TRec τ/] n' w end.
Proof.
  rewrite val_rel_unfold.
  unfold val_rel_aux; simpl; unfold val_rel_aux_rec; simpl.
  destruct n; firstorder.
Qed.

Ltac simpl_val_rel := rewrite ?val_rel_unit, ?val_rel_var,
    ?val_rel_prod, ?val_rel_fun, ?val_rel_tforall, ?val_rel_trec.

Lemma val_rel_is_val τ n v : val_rel τ n v → is_val v.
Proof. revert n v; induction τ; intros n v; simpl_val_rel; firstorder; subst; constructor; eauto. Qed.

Lemma val_rel_down_closed τ n n' v : n' ≤ n → val_rel τ n v → val_rel τ n' v.
Proof.
  remember (n, τ) as nτ; symmetry in Heqnτ.
  revert n' v n τ Heqnτ.
  induction (wf_rel_well_founded nτ) as [[n τ] ? IH]; intros n' v ? ?.
  inversion 1; subst.
  intros Hn'.
  destruct τ; simpl_val_rel; [tauto|tauto| | | |].
  - firstorder; subst; eexists _, _; split; [reflexivity|];
      split; eapply IH; eauto; solve_wf_rel.
  - intros [? Hsf]; split; [assumption|].
    intros; eapply SISafe_mono; [|apply Hsf; [lia|assumption]].
    intros; eapply IH; [| | |eassumption]; [|reflexivity|lia]; solve_wf_rel.
  - intros [? Hsf]; split; [assumption|].
    intros; eapply SISafe_down_closed'; [inversion 1| | |eapply Hsf]; [assumption|].
    intros ?????; eapply IH; [|reflexivity|assumption]; solve_wf_rel.
  - intros [? (?&->&Hsf)]; split; [assumption|].
    eexists _; split; [reflexivity|].
    destruct n; destruct n'; [tauto|lia|tauto|].
    eapply IH; [|reflexivity| |eassumption]; [|lia]; solve_wf_rel.
Qed.

Definition expr_rel_down_closed τ n n' e : n' ≤ n → expr_rel τ n e → expr_rel τ n' e.
Proof.
  intros; eapply SISafe_down_closed; [eassumption| |eassumption].
  intros; eapply val_rel_down_closed; eauto.
Qed.

Local Notation env_rel n Γ env := (env_rel (λ τ, val_rel τ n) Γ env).

Lemma env_rel_down_closed n n' Γ env : n' ≤ n → env_rel n Γ env → env_rel n' Γ env.
Proof.
  revert env.
  induction Γ as [|τ Γ IHΓ]; intros env ?.
  - intros ->%env_rel_inv_nil_l; apply env_rel_nil.
  - simpl.
    intros (?&?&->&?&?)%env_rel_inv_cons_l.
    apply env_rel_cons; [|apply IHΓ; eauto; fail].
    eapply val_rel_down_closed; eauto.
Qed.

Theorem Fundamental Γ e τ f :
  typed Γ e τ → ∀ n env, env_rel n (map (subst f) Γ) env → expr_rel τ.[f] n e.[env_subst env].
Proof.
  intros Htp; revert f.
  induction Htp; intros f n env Henv; simpl.
  - assert (val_rel τ.[f] n (env_subst env v)).
    { eapply env_rel_lookup1 in Henv as [? [? ?]]; [|apply lookup_map; eassumption].
      erewrite env_subst_lookup; eauto. }
    apply SISafe_val; [eapply val_rel_is_val; eauto|assumption].
  - apply SISafe_val; [constructor|].
    simpl_val_rel; destruct n; [constructor|reflexivity].
  - eapply (SISafe_bind _ _ _ (λ e, Pair e _));
      [repeat econstructor; fail|apply IHHtp1; eassumption; fail|].
    intros ? v1 ? Hv11 Hv12.
    eapply (SISafe_bind _ _ _ (λ e, Pair _ e));
      [|eapply IHHtp2; eapply env_rel_down_closed; eauto; fail|].
    { repeat econstructor; trivial. }
    intros z v2 ? Hv21 Hv22.
    apply SISafe_val; [constructor; trivial|].
    simpl_val_rel.
    eexists _, _; split; [reflexivity|];
    split; (eapply val_rel_down_closed; [|eauto]); lia.
  - eapply (SISafe_bind _ _ _ (λ e, Fst e));
      [repeat econstructor; fail|apply IHHtp; eassumption; fail|].
    intros k v ? Hv1; simpl.
    simpl_val_rel.
    intros (v1 & v2 & -> & Hv1r & Hv2r).
    inversion Hv1; subst.
    eapply SISafe_head_step_back; [solve_det_head_step|]; intros ?.
    destruct k; [lia|]; simpl in *.
    apply SISafe_val; [assumption|].
    eapply val_rel_down_closed; [|eassumption]; lia.
  - eapply (SISafe_bind _ _ _ (λ e, Snd e));
      [repeat econstructor; fail|apply IHHtp; eassumption; fail|].
    intros k v ? Hv1; simpl.
    simpl_val_rel.
    intros (v1 & v2 & -> & Hv1r & Hv2r).
    inversion Hv1; subst.
    eapply SISafe_head_step_back; [solve_det_head_step|]; intros.
    apply SISafe_val; [assumption|].
    eapply val_rel_down_closed; [|eassumption]; lia.
  - apply SISafe_val; [constructor; fail|].
    simpl_val_rel.
    split; [constructor; fail|].
    intros k w ? Hw.
    assert (is_val w) by (eapply val_rel_is_val; eauto).
    eapply SISafe_head_step_back; [solve_det_head_step|]; intros ?.
    asimpl.
    apply (IHHtp _ _ (_ :: _)).
    apply env_rel_cons;
      [eapply val_rel_down_closed; [|eassumption]|eapply env_rel_down_closed; [|eassumption]];
      lia.
  - eapply (SISafe_bind _ _ _ (λ e, App e _));
      [repeat econstructor; fail|apply IHHtp1; eassumption; fail|].
    intros ? v1 ? Hv11.
    simpl; simpl_val_rel; intros Hv12.
    eapply (SISafe_bind _ _ _ (λ e, App _ e));
      [|apply IHHtp2; eapply env_rel_down_closed; eauto; fail|].
    { repeat econstructor; trivial. }
    intros ? v2 ? Hv21 Hv22.
    eapply Hv12 ; trivial.
  - apply SISafe_val; [constructor; fail|].
    simpl_val_rel.
    split; [constructor; fail|].
    intros τ'.
    eapply SISafe_head_step_back; [solve_det_head_step|]; intros.
    eapply (expr_rel_down_closed _ n); [lia|].
    asimpl; apply IHHtp.
    erewrite map_map, map_ext; [eassumption|].
    intros ?; asimpl; reflexivity.
  - eapply (SISafe_bind _ _ _ (λ e, TApp e));
      [repeat econstructor; fail|apply IHHtp; eassumption; fail|].
    intros ? v ? ?.
    simpl; simpl_val_rel; intros [? Hv].
    eapply SISafe_mono; [|apply Hv].
    intros ???. asimpl; eauto.
  - eapply (SISafe_bind _ _ _ (λ e, Fold e));
      [repeat econstructor; fail|apply IHHtp; eassumption; fail|].
    intros ? v ? ? Hv.
    apply SISafe_val; [constructor; assumption|].
    simpl_val_rel.
    split; [constructor; assumption|].
    eexists _; split; [reflexivity|].
    destruct k as [|k]; [tauto|].
    asimpl in *.
    eapply val_rel_down_closed; [|eassumption]; lia.
  - eapply (SISafe_bind _ _ _ (λ e, Unfold e));
      [repeat econstructor; fail|apply IHHtp; eassumption; fail|].
    intros ? v ? ?.
    simpl; simpl_val_rel; intros [Hiv (?&->&Hv)].
    inversion Hiv; subst.
    eapply SISafe_head_step_back; [solve_det_head_step|]; intros.
    destruct k as [|k]; [lia|]; asimpl in *.
    apply SISafe_val; [assumption|].
    eapply val_rel_down_closed; [|eassumption]; lia.
Qed.

Corollary type_safety e τ : typed nil e τ → Safe (λ _, True) e.
Proof.
  intros Htp.
  apply SISafe_adequacy; intros n.
  replace e with e.[env_subst nil] by (asimpl; reflexivity).
  eapply SISafe_mono; [tauto|].
  pose proof (Fundamental nil _ _ ids Htp n nil) as Hfm.
  replace τ.[ids] with τ in Hfm by (asimpl; reflexivity).
  eapply Hfm.
  apply env_rel_nil.
Qed.


(** * Auto: More Automation *)

Set Warnings "-notation-overridden,-parsing".
Require Import Coq.omega.Omega.
Require Import Maps.
Require Import Imp.

(** Up to now, we've used the more manual part of Coq's tactic
    facilities.  In this chapter, we'll learn more about some of Coq's
    powerful automation features: proof search via the [auto] tactic,
    automated forward reasoning via the [Ltac] hypothesis matching
    machinery, and deferred instantiation of existential variables
    using [eapply] and [eauto].  Using these features together with
    Ltac's scripting facilities will enable us to make our proofs
    startlingly short!  Used properly, they can also make proofs more
    maintainable and robust to changes in underlying definitions.  A
    deeper treatment of [auto] and [eauto] can be found in the
    [UseAuto] chapter in _Programming Language Foundations_.

    There's another major category of automation we haven't discussed
    much yet, namely built-in decision procedures for specific kinds
    of problems: [omega] is one example, but there are others.  This
    topic will be deferred for a while longer.

    Our motivating example will be this proof, repeated with just a
    few small changes from the [Imp] chapter.  We will simplify
    this proof in several stages. *)

(** First, define a little Ltac macro to compress a common
    pattern into a single command. *)
Ltac inv H := inversion H; subst; clear H.

Theorem ceval_deterministic: forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2.
  - (* E_Skip *) reflexivity.
  - (* E_Ass *) reflexivity.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; apply H1. }
    subst st'0.
    apply IHE1_2. assumption.
  (* E_IfTrue *)
  - (* b evaluates to true *)
    apply IHE1. assumption.
  - (* b evaluates to false (contradiction) *)
    rewrite H in H5. inversion H5.
  (* E_IfFalse *)
  - (* b evaluates to true (contradiction) *)
    rewrite H in H5. inversion H5.
  - (* b evaluates to false *)
    apply IHE1. assumption.
  (* E_WhileFalse *)
  - (* b evaluates to false *)
    reflexivity.
  - (* b evaluates to true (contradiction) *)
    rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption.  Qed.

(* ################################################################# *)
(** * The [auto] Tactic *)

(** Thus far, our proof scripts mostly apply relevant hypotheses or
    lemmas by name, and one at a time. *)

Example auto_example_1 : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P Q R H1 H2 H3.
  apply H2. apply H1. assumption.
Qed.

(** The [auto] tactic frees us from this drudgery by _searching_ for a
    sequence of applications that will prove the goal: *)

Example auto_example_1' : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  auto.
Qed.

(** The [auto] tactic solves goals that are solvable by any combination of
     - [intros] and
     - [apply] (of hypotheses from the local context, by default). *)

(** Using [auto] is always "safe" in the sense that it will never fail
    and will never change the proof state: either it completely solves
    the current goal, or it does nothing. *)

(** Here is a more interesting example showing [auto]'s power: *)

Example auto_example_2 : forall P Q R S T U : Prop,
  (P -> Q) ->
  (P -> R) ->
  (T -> R) ->
  (S -> T -> U) ->
  ((P->Q) -> (P->S)) ->
  T ->
  P ->
  U.
Proof. auto. Qed.

(** Proof search could, in principle, take an arbitrarily long time,
    so there are limits to how far [auto] will search by default. *)

Example auto_example_3 : forall (P Q R S T U: Prop),
  (P -> Q) ->
  (Q -> R) ->
  (R -> S) ->
  (S -> T) ->
  (T -> U) ->
  P ->
  U.
Proof.
  (* When it cannot solve the goal, [auto] does nothing *)
  auto.
  (* Optional argument says how deep to search (default is 5) *)
  auto 6.
Qed.

(** When searching for potential proofs of the current goal,
    [auto] considers the hypotheses in the current context together
    with a _hint database_ of other lemmas and constructors.  Some
    common lemmas about equality and logical operators are installed
    in this hint database by default. *)

Example auto_example_4 : forall P Q R : Prop,
  Q ->
  (Q -> R) ->
  P \/ (Q /\ R).
Proof. auto. Qed.

(** We can extend the hint database just for the purposes of one
    application of [auto] by writing "[auto using ...]". *)

Lemma le_antisym : forall n m: nat, (n <= m /\ m <= n) -> n = m.
Proof. intros. omega. Qed.

Example auto_example_6 : forall n m p : nat,
  (n <= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto using le_antisym.
Qed.

(** Of course, in any given development there will probably be
    some specific constructors and lemmas that are used very often in
    proofs.  We can add these to the global hint database by writing

      Hint Resolve T.

    at the top level, where [T] is a top-level theorem or a
    constructor of an inductively defined proposition (i.e., anything
    whose type is an implication).  As a shorthand, we can write

      Hint Constructors c.

    to tell Coq to do a [Hint Resolve] for _all_ of the constructors
    from the inductive definition of [c].

    It is also sometimes necessary to add

      Hint Unfold d.

    where [d] is a defined symbol, so that [auto] knows to expand uses
    of [d], thus enabling further possibilities for applying lemmas that
    it knows about. *)

(** It is also possible to define specialized hint databases that can
    be activated only when needed.  See the Coq reference manual for
    more. *)

Hint Resolve le_antisym.

Example auto_example_6' : forall n m p : nat,
  (n<= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto. (* picks up hint from database *)
Qed.

Definition is_fortytwo x := (x = 42).

Example auto_example_7: forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof.
  auto.  (* does nothing *)
Abort.

Hint Unfold is_fortytwo.

Example auto_example_7' : forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof. auto. Qed.

(** Let's take a first pass over [ceval_deterministic] to simplify the
    proof script. *)

Theorem ceval_deterministic': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
       induction E1; intros st2 E2; inv E2; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
Qed.

(** When we are using a particular tactic many times in a proof, we
    can use a variant of the [Proof] command to make that tactic into
    a default within the proof.  Saying [Proof with t] (where [t] is
    an arbitrary tactic) allows us to use [t1...] as a shorthand for
    [t1;t] within the proof.  As an illustration, here is an alternate
    version of the previous proof, using [Proof with auto]. *)

Theorem ceval_deterministic'_alt: forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof with auto.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1;
           intros st2 E2; inv E2...
  - (* E_Seq *)
    assert (st' = st'0) as EQ1...
    subst st'0...
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1...
    subst st'0...
Qed.

(* ################################################################# *)
(** * Searching For Hypotheses *)

(** The proof has become simpler, but there is still an annoying
    amount of repetition. Let's start by tackling the contradiction
    cases. Each of them occurs in a situation where we have both

      H1: beval st b = false

    and

      H2: beval st b = true

    as hypotheses.  The contradiction is evident, but demonstrating it
    is a little complicated: we have to locate the two hypotheses [H1]
    and [H2] and do a [rewrite] following by an [inversion].  We'd
    like to automate this process.

    (In fact, Coq has a built-in tactic [congruence] that will do the
    job in this case.  But we'll ignore the existence of this tactic
    for now, in order to demonstrate how to build forward search
    tactics by hand.)

    As a first step, we can abstract out the piece of script in
    question by writing a little function in Ltac. *)

Ltac rwinv H1 H2 := rewrite H1 in H2; inv H2.

Theorem ceval_deterministic'': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rwinv H H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rwinv H H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rwinv H H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rwinv H H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto. Qed.

(** That was is a bit better, but we really want Coq to discover the
    relevant hypotheses for us.  We can do this by using the [match
    goal] facility of Ltac. *)

Ltac find_rwinv :=
  match goal with
    H1: ?E = true,
    H2: ?E = false
    |- _ => rwinv H1 H2
  end.

(** This [match goal] looks for two distinct hypotheses that
    have the form of equalities, with the same arbitrary expression
    [E] on the left and with conflicting boolean values on the right.
    If such hypotheses are found, it binds [H1] and [H2] to their
    names and applies the [rwinv] tactic to [H1] and [H2].

    Adding this tactic to the ones that we invoke in each case of the
    induction handles all of the contradictory cases. *)

Theorem ceval_deterministic''': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      assert (st' = st'0) as EQ1 by auto.
      subst st'0.
      auto. Qed.

(** Let's see about the remaining cases. Each of them involves
    applying a conditional hypothesis to extract an equality.
    Currently we have phrased these as assertions, so that we have to
    predict what the resulting equality will be (although we can then
    use [auto] to prove it).  An alternative is to pick the relevant
    hypotheses to use and then [rewrite] with them, as follows: *)

Theorem ceval_deterministic'''': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  - (* E_Seq *)
    rewrite (IHE1_1 st'0 H1) in *. auto.
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      rewrite (IHE1_1 st'0 H3) in *. auto. Qed.

(** Now we can automate the task of finding the relevant hypotheses to
    rewrite with. *)

Ltac find_eqn :=
  match goal with
    H1: forall x, ?P x -> ?L = ?R,
    H2: ?P ?X
    |- _ => rewrite (H1 X H2) in *
  end.

(** The pattern [forall x, ?P x -> ?L = ?R] matches any hypothesis of
    the form "for all [x], _some property of [x]_ implies _some
    equality_."  The property of [x] is bound to the pattern variable
    [P], and the left- and right-hand sides of the equality are bound
    to [L] and [R].  The name of this hypothesis is bound to [H1].
    Then the pattern [?P ?X] matches any hypothesis that provides
    evidence that [P] holds for some concrete [X].  If both patterns
    succeed, we apply the [rewrite] tactic (instantiating the
    quantified [x] with [X] and providing [H2] as the required
    evidence for [P X]) in all hypotheses and the goal.

    One problem remains: in general, there may be several pairs of
    hypotheses that have the right general form, and it seems tricky
    to pick out the ones we actually need.  A key trick is to realize
    that we can _try them all_!  Here's how this works:

    - each execution of [match goal] will keep trying to find a valid
      pair of hypotheses until the tactic on the RHS of the match
      succeeds; if there are no such pairs, it fails;
    - [rewrite] will fail given a trivial equation of the form [X = X];
    - we can wrap the whole thing in a [repeat], which will keep doing
      useful rewrites until only trivial ones are left. *)

Theorem ceval_deterministic''''': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv;
    repeat find_eqn; auto.
Qed.

(** The big payoff in this approach is that our proof script should be
    more robust in the face of modest changes to our language.  To
    test whether it really is, let's try adding a [REPEAT] command to
    the language. *)

Module Repeat.

Inductive com : Type :=
  | CSkip : com
  | CAsgn : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CRepeat : com -> bexp -> com.

(** [REPEAT] behaves like [WHILE], except that the loop guard is
    checked _after_ each execution of the body, with the loop
    repeating as long as the guard stays _false_.  Because of this,
    the body will always execute at least once. *)

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
  (CRepeat e1 b2) (at level 80, right associativity).

Inductive ceval : state -> com -> state -> Prop :=
  | E_Skip : forall st,
      ceval st SKIP st
  | E_Ass  : forall st a1 n X,
      aeval st a1 = n ->
      ceval st (X ::= a1) (t_update st X n)
  | E_Seq : forall c1 c2 st st' st'',
      ceval st c1 st' ->
      ceval st' c2 st'' ->
      ceval st (c1 ; c2) st''
  | E_IfTrue : forall st st' b1 c1 c2,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_IfFalse : forall st st' b1 c1 c2,
      beval st b1 = false ->
      ceval st c2 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_WhileFalse : forall b1 st c1,
      beval st b1 = false ->
      ceval st (WHILE b1 DO c1 END) st
  | E_WhileTrue : forall st st' st'' b1 c1,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st' (WHILE b1 DO c1 END) st'' ->
      ceval st (WHILE b1 DO c1 END) st''
  | E_RepeatEnd : forall st st' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = true ->
      ceval st (CRepeat c1 b1) st'
  | E_RepeatLoop : forall st st' st'' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = false ->
      ceval st' (CRepeat c1 b1) st'' ->
      ceval st (CRepeat c1 b1) st''.

Notation "c1 '/' st '\\' st'" := (ceval st c1 st')
                                 (at level 40, st at level 39).

(** Our first attempt at the determinacy proof does not quite succeed:
    the [E_RepeatEnd] and [E_RepeatLoop] cases are not handled by our
    previous automation. *)

Theorem ceval_deterministic: forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; try find_rwinv; repeat find_eqn; auto.
  - (* E_RepeatEnd *)
    + (* b evaluates to false (contradiction) *)
       find_rwinv.
       (* oops: why didn't [find_rwinv] solve this for us already?
          answer: we did things in the wrong order. *)
  - (* E_RepeatLoop *)
     + (* b evaluates to true (contradiction) *)
        find_rwinv.
Qed.

(** Fortunately, to fix this, we just have to swap the invocations of
    [find_eqn] and [find_rwinv]. *)

Theorem ceval_deterministic': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; repeat find_eqn; try find_rwinv; auto.
Qed.

End Repeat.

(** These examples just give a flavor of what "hyper-automation"
    can achieve in Coq.  The details of [match goal] are a bit
    tricky (and debugging scripts using it is, frankly, not very
    pleasant).  But it is well worth adding at least simple uses to
    your proofs, both to avoid tedium and to "future proof" them. *)

(* ================================================================= *)
(** ** The [eapply] and [eauto] variants *)

(** To close the chapter, we'll introduce one more convenient feature
    of Coq: its ability to delay instantiation of quantifiers.  To
    motivate this feature, recall this example from the [Imp]
    chapter: *)

Example ceval_example1:
    (X ::= 2;;
     IFB X <= 1
       THEN Y ::= 3
       ELSE Z ::= 4
     FI)
   / { --> 0 }
   \\ { X --> 2 ; Z --> 4 }.
Proof.
  (* We supply the intermediate state [st']... *)
  apply E_Seq with { X --> 2 }.
  - apply E_Ass. reflexivity.
  - apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

(** In the first step of the proof, we had to explicitly provide a
    longish expression to help Coq instantiate a "hidden" argument to
    the [E_Seq] constructor.  This was needed because the definition
    of [E_Seq]...

          E_Seq : forall c1 c2 st st' st'',
            c1 / st  \\ st' ->
            c2 / st' \\ st'' ->
            (c1 ;; c2) / st \\ st''

   is quantified over a variable, [st'], that does not appear in its
   conclusion, so unifying its conclusion with the goal state doesn't
   help Coq find a suitable value for this variable.  If we leave
   out the [with], this step fails ("Error: Unable to find an
   instance for the variable [st']").

   What's silly about this error is that the appropriate value for [st']
   will actually become obvious in the very next step, where we apply
   [E_Ass].  If Coq could just wait until we get to this step, there
   would be no need to give the value explicitly.  This is exactly what
   the [eapply] tactic gives us: *)

Example ceval'_example1:
    (X ::= 2;;
     IFB X <= 1
       THEN Y ::= 3
       ELSE Z ::= 4
     FI)
   / { --> 0 }
   \\ { X --> 2 ; Z --> 4 }.
Proof.
  eapply E_Seq. (* 1 *)
  - apply E_Ass. (* 2 *)
    reflexivity. (* 3 *)
  - (* 4 *) apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

(** The [eapply H] tactic behaves just like [apply H] except
    that, after it finishes unifying the goal state with the
    conclusion of [H], it does not bother to check whether all the
    variables that were introduced in the process have been given
    concrete values during unification.

    If you step through the proof above, you'll see that the goal
    state at position [1] mentions the _existential variable_ [?st']
    in both of the generated subgoals.  The next step (which gets us
    to position [2]) replaces [?st'] with a concrete value.  This new
    value contains a new existential variable [?n], which is
    instantiated in its turn by the following [reflexivity] step,
    position [3].  When we start working on the second
    subgoal (position [4]), we observe that the occurrence of [?st']
    in this subgoal has been replaced by the value that it was given
    during the first subgoal. *)

(** Several of the tactics that we've seen so far, including [exists],
    [constructor], and [auto], have [e...] variants.  For example,
    here's a proof using [eauto]: *)

Hint Constructors ceval.
Hint Transparent state.
Hint Transparent total_map.

Definition st12 := { X --> 1 ; Y --> 2 }.
Definition st21 := { X --> 2 ; Y --> 1 }.

Example eauto_example : exists s',
  (IFB X <= Y
    THEN Z ::= Y - X
    ELSE Y ::= X + Z
  FI) / st21 \\ s'.
Proof. eauto. Qed.

(** The [eauto] tactic works just like [auto], except that it uses
    [eapply] instead of [apply].

    Pro tip: One might think that, since [eapply] and [eauto] are more
    powerful than [apply] and [auto], it would be a good idea to use
    them all the time.  Unfortunately, they are also significantly
    slower -- especially [eauto].  Coq experts tend to use [apply] and
    [auto] most of the time, only switching to the [e] variants when
    the ordinary variants don't do the job. *)


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

(** Author: Bruno Barras *)

Require Import Relation_Operators.
Require Import Relation_Definitions.
Require Import Transitive_Closure.

Section WfUnion.
  Variable A : Type.
  Variables R1 R2 : relation A.

  Notation Union := (union A R1 R2).

  Remark strip_commut :
    commut A R1 R2 ->
    forall x y:A,
      clos_trans A R1 y x ->
      forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & clos_trans A R1 z y'.
  Proof.
    induction 2 as [x y| x y z H0 IH1 H1 IH2]; intros.
    elim H with y x z; auto with sets; intros x0 H2 H3.
    exists x0; auto with sets.

    elim IH1 with z0; auto with sets; intros.
    elim IH2 with x0; auto with sets; intros.
    exists x1; auto with sets.
    apply t_trans with x0; auto with sets.
  Qed.

  Lemma Acc_union :
    commut A R1 R2 ->
    (forall x:A, Acc R2 x -> Acc R1 x) -> forall a:A, Acc R2 a -> Acc Union a.
  Proof.
    induction 3 as [x H1 H2].
    apply Acc_intro; intros.
    elim H3; intros; auto with sets.
    cut (clos_trans A R1 y x); auto with sets.
    elimtype (Acc (clos_trans A R1) y); intros.
    apply Acc_intro; intros.
    elim H8; intros.
    apply H6; auto with sets.
    apply t_trans with x0; auto with sets.

    elim strip_commut with x x0 y0; auto with sets; intros.
    apply Acc_inv_trans with x1; auto with sets.
    unfold union in |- *.
    elim H11; auto with sets; intros.
    apply t_trans with y1; auto with sets.

    apply (Acc_clos_trans A).
    apply Acc_inv with x; auto with sets.
    apply H0.
    apply Acc_intro; auto with sets.
  Qed.

  Theorem wf_union :
    commut A R1 R2 -> well_founded R1 -> well_founded R2 -> well_founded Union.
  Proof.
    unfold well_founded in |- *.
    intros.
    apply Acc_union; auto with sets.
  Qed.

End WfUnion.