From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Aprime : Universe, ((wd_ B Aprime /\ (wd_ B C /\ (wd_ A Aprime /\ (wd_ A C /\ (wd_ B A /\ (col_ Aprime B C /\ col_ A B C)))))) -> col_ A Aprime B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Add LoadPath "???\syntax".
Add LoadPath "???\type_system".
Add LoadPath "???\substitution".
Require Export syntax subtyping_and_admissibility substitution.

(* ==================== Template Handling ==================== *)

(* We increase context length so that we don't have to shift h. *)
Fixpoint handle_t D Γ_len Z_len h T :=
  match T with
  | TApp n v => App (Var (Γ_len+n)) v
  | TAbsurd v => Absurd D v
  | TProdMatch v T =>
      ProdMatch v (handle_t D (2+Γ_len) Z_len h T)
  | TSumMatch v T1 T2 =>
      SumMatch v
        (handle_t D (1+Γ_len) Z_len h T1)
        (handle_t D (1+Γ_len) Z_len h T2)
  | TListMatch v T1 T2 =>
      ListMatch v
        (handle_t D Γ_len Z_len h T1)
        (handle_t D (2+Γ_len) Z_len h T2)
  | TDo c T =>
      Do c (handle_t D (1+Γ_len) Z_len h T)
  | TOp op A B v T =>
      match get_case h op with
      | Some c_op =>
          c_subs2_out (c_shift c_op (Γ_len + Z_len) 2)
            v (Fun B (handle_t D (1+Γ_len) Z_len h T))
      | None =>
          (* You shouldn't be here *)
          Op op A B v (handle_t D (1+Γ_len) Z_len h T)
      end
  end.

Fixpoint tmpl_to_comp C Γ_len T :=
  match T with
  | TApp n v => App (Var (Γ_len+n)) v
  | TAbsurd v => Absurd C v
  | TProdMatch v T =>
      ProdMatch v (tmpl_to_comp C (2+Γ_len) T)
  | TSumMatch v T1 T2 =>
      SumMatch v
        (tmpl_to_comp C (1+Γ_len) T1)
        (tmpl_to_comp C (1+Γ_len) T2)
  | TListMatch v T1 T2 =>
      ListMatch v
        (tmpl_to_comp C Γ_len T1)
        (tmpl_to_comp C (2+Γ_len) T2)
  | TDo c T =>
      Do c (tmpl_to_comp C (1+Γ_len) T)
  | TOp op A B v T =>
      Op op A B v (tmpl_to_comp C (1+Γ_len) T)
  end.

(* ==================== Well formedness Judgements ==================== *)

Inductive wf_vtype : vtype -> Prop :=
| WfTyUnit : wf_vtype TyUnit
| WfTyInt : wf_vtype TyInt
| WfTyEmpty : wf_vtype TyEmpty
| WfTySum A B: wf_vtype A -> wf_vtype B -> wf_vtype (TySum A B)
| WfTyProd A B : wf_vtype A -> wf_vtype B -> wf_vtype (TyProd A B)
| WfTyList A : wf_vtype A -> wf_vtype (TyList A)
| WfTyFun A C : wf_vtype A -> wf_ctype C -> wf_vtype (TyFun A C)
| WfTyHandler C D : wf_ctype C -> wf_ctype D -> wf_vtype (TyHandler C D)

with wf_ctype : ctype -> Prop :=
| WfCTy A Σ E : wf_vtype A -> wf_sig Σ -> wf_eqs E Σ -> wf_ctype (CTy A Σ E)

with wf_sig : sig -> Prop :=
| WfSigØ : wf_sig SigØ
| WfSigU Σ op Aop Bop:
    wf_sig Σ -> get_op_type Σ op = None ->
    wf_vtype Aop -> wf_vtype Bop ->
    wf_sig (SigU Σ op Aop Bop)

with wf_ctx : ctx -> Prop :=
| WfCtxØ : wf_ctx CtxØ
| WfCtxU Γ A : wf_ctx Γ -> wf_vtype A -> wf_ctx (CtxU Γ A)

with wf_tctx : tctx -> Prop :=
| WfTCtxØ : wf_tctx TCtxØ
| WfTCtxU Γ A : wf_tctx Γ -> wf_vtype A -> wf_tctx (TCtxU Γ A)

with wf_t : ctx -> tctx -> tmpl -> sig -> Prop :=
| WfTApp Γ Z n v A Σ :
    has_vtype Γ v A -> get_ttype Z n = Some A ->
    wf_t Γ Z (TApp n v) Σ
| WfTAbsurd Γ Z v Σ :
    has_vtype Γ v TyEmpty ->
    wf_t Γ Z (TAbsurd v) Σ
| WfTProdMatch Γ Z v T A B Σ :
    has_vtype Γ v (TyProd A B) -> wf_t (CtxU (CtxU Γ A) B) Z T Σ ->
    wf_t Γ Z (TProdMatch v T) Σ
| WfTSumMatch Γ Z v T1 T2 A B Σ :
    has_vtype Γ v (TySum A B) ->
    wf_t (CtxU Γ A) Z T1 Σ -> wf_t (CtxU Γ B) Z T2 Σ ->
    wf_t Γ Z (TSumMatch v T1 T2) Σ
| WfTListMatch Γ Z v T1 T2 A Σ :
    has_vtype Γ v (TyList A) ->
    wf_t Γ Z T1 Σ -> wf_t (CtxU (CtxU Γ A) (TyList A)) Z T2 Σ ->
    wf_t Γ Z (TListMatch v T1 T2) Σ
| WfTDo Γ Z c T A Σ :
    has_ctype Γ c (CTy A SigØ EqsØ) ->
    wf_t (CtxU Γ A) Z T Σ ->
    wf_t  Γ Z (TDo c T) Σ
| WfTOp Γ Z op Aop Bop v T A B Σ :
    get_op_type Σ op = Some (A, B) ->
    vsubtype Aop A -> vsubtype B Bop ->
    wf_vtype Aop -> wf_vtype Bop ->
    has_vtype Γ v Aop ->
    wf_t (CtxU Γ Bop) Z T Σ ->
    wf_t Γ Z (TOp op Aop Bop v T) Σ

with wf_eqs : eqs -> sig -> Prop :=
| WfEqsØ Σ : wf_eqs EqsØ Σ
| WfEqsU E Γ Z T1 T2 Σ:
    wf_eqs E Σ -> wf_ctx Γ -> wf_tctx Z -> wf_sig Σ ->
    wf_t Γ Z T1 Σ -> wf_t Γ Z T2 Σ ->
    wf_eqs (EqsU E Γ Z T1 T2) Σ

with wf_form : ctx -> formula -> Prop :=
| WfVeq Γ A v1 v2 :
    has_vtype Γ v1 A -> has_vtype Γ v2 A ->
    wf_form Γ (Veq A v1 v2)
| WfCeq Γ C c1 c2 :
    has_ctype Γ c1 C -> has_ctype Γ c2 C ->
    wf_form Γ (Ceq C c1 c2)
| WfHeq Γ Σ Σ1 Σ2 D h1 h2 :
    wf_sig Σ -> sig_subtype Σ Σ1 -> sig_subtype Σ Σ2 ->
    has_htype Γ h1 Σ1 D -> has_htype Γ h2 Σ2 D ->
    wf_form Γ (Heq Σ D h1 h2)
| WfTruth Γ :
    wf_ctx Γ ->
    wf_form Γ Truth
| WfFalsity Γ :
    wf_ctx Γ ->
    wf_form Γ Falsity
| WfAnd φ1 φ2 Γ :
    wf_form Γ φ1 -> wf_form Γ φ2 ->
    wf_form Γ (And φ1 φ2)
| WfOr φ1 φ2 Γ :
    wf_form Γ φ1 -> wf_form Γ φ2 ->
    wf_form Γ (Or φ1 φ2)
| WfImplies φ1 φ2 Γ :
    wf_form Γ φ1 -> wf_form Γ φ2 ->
    wf_form Γ (Implies φ1 φ2)
| WfForall A φ Γ :
    wf_vtype A -> wf_form (CtxU Γ A) φ ->
    wf_form Γ (Forall A φ)
| WfExists A φ Γ :
    wf_vtype A -> wf_form (CtxU Γ A) φ ->
    wf_form Γ (Exists A φ)

with wf_hyp : ctx -> hypotheses -> Prop :=
| WfHypØ Γ:
    wf_hyp Γ HypØ
| WfHypU Γ Ψ j:
    wf_hyp Γ Ψ ->
    wf_form Γ j ->
    wf_hyp Γ (HypU Ψ j)

(* ==================== Type Judgements ==================== *)

with has_vtype : ctx -> val -> vtype -> Prop :=
| TypeV Γ v A :
    wf_ctx Γ ->  wf_vtype A ->
    has_vtype' Γ v A ->
    has_vtype Γ v A

with has_vtype' : ctx -> val -> vtype -> Prop :=
| TypeUnit Γ :
    has_vtype' Γ Unit TyUnit
| TypeInt Γ n :
    has_vtype' Γ (Int n) TyInt
| TypeVar Γ n A :
    get_vtype Γ n = Some A ->
    has_vtype' Γ (Var n) A
| TypePair Γ v1 v2 A B :
    has_vtype Γ v1 A ->
    has_vtype Γ v2 B ->
    has_vtype' Γ (Pair v1 v2) (TyProd A B)
| TypeLeft Γ v A B :
    has_vtype Γ v A ->
    has_vtype' Γ (Left A B v) (TySum A B)
| TypeRight Γ v A B :
    has_vtype Γ v B ->
    has_vtype' Γ (Right A B v) (TySum A B)
| TypeNil Γ A :
    has_vtype' Γ (Nil A) (TyList A)
| TypeCons Γ v vs A :
    has_vtype Γ v A ->
    has_vtype Γ vs (TyList A) ->
    has_vtype' Γ (Cons v vs) (TyList A)
| TypeFun Γ c A C :
    has_ctype (CtxU Γ A) c C ->
    has_vtype' Γ (Fun A c) (TyFun A C)
| TypeHandler Γ cr h A Σ E D :
    has_ctype (CtxU Γ A) cr D ->
    has_htype Γ h Σ D ->
    respects Γ h Σ D E ->
    has_vtype' Γ (Handler A cr h) (TyHandler (CTy A Σ E) D)
| TypeVSubsume Γ v A A' :
    has_vtype Γ v A ->
    vsubtype A A' ->
    has_vtype' Γ v A'

with has_ctype : ctx -> comp -> ctype -> Prop :=
| TypeC Γ c C :
    wf_ctx Γ -> wf_ctype C ->
    has_ctype' Γ c C ->
    has_ctype Γ c C

with has_ctype' : ctx -> comp -> ctype -> Prop :=
| TypeRet Γ v A :
    has_vtype Γ v A ->
    has_ctype' Γ (Ret v) (CTy A SigØ EqsØ)
| TypeAbsurd Γ v C :
    has_vtype Γ v TyEmpty ->
    has_ctype' Γ (Absurd C v) C
| TypeProdMatch Γ v A B c C :
    has_vtype Γ v (TyProd A B) ->
    has_ctype (CtxU (CtxU Γ A) B) c C ->
    has_ctype' Γ (ProdMatch v c) C
| TypeSumMatch Γ v A B c1 c2 C :
    has_vtype Γ v (TySum A B) ->
    has_ctype (CtxU Γ A) c1 C ->
    has_ctype (CtxU Γ B) c2 C ->
    has_ctype' Γ (SumMatch v c1 c2) C
| TypeListMatch Γ v A c1 c2 C :
    has_vtype Γ v (TyList A) ->
    has_ctype Γ c1 C ->
    has_ctype (CtxU (CtxU Γ A) (TyList A)) c2 C ->
    has_ctype' Γ (ListMatch v c1 c2) C
| TypeDo Γ c1 c2 A B Σ E :
    has_ctype Γ c1 (CTy A Σ E) ->
    has_ctype (CtxU Γ A) c2 (CTy B Σ E) ->
    has_ctype' Γ (Do c1 c2) (CTy B Σ E)
| TypeApp Γ v1 v2 A C :
    has_vtype Γ v1 (TyFun A C) ->
    has_vtype Γ v2 A ->
    has_ctype' Γ (App v1 v2) C
| TypeHandle Γ v c C D :
    has_vtype Γ v (TyHandler C D) ->
    has_ctype Γ c C ->
    has_ctype' Γ (Handle v c) D
| TypeLetRec Γ A C c1 c2 D:
    has_ctype (CtxU (CtxU Γ A) (TyFun A C)) c1 C ->
    has_ctype (CtxU Γ (TyFun A C)) c2 D ->
    has_ctype' Γ (LetRec A C c1 c2) D
| TypeOp Γ op v c Aop Bop Aop' Bop' A Σ E :
    get_op_type Σ op = Some (Aop', Bop') ->
    (* This is needed for the safety theorem. *)
    vsubtype Aop Aop' -> vsubtype Bop' Bop ->
    has_vtype Γ v Aop ->
    has_ctype (CtxU Γ Bop) c (CTy A Σ E) ->
    has_ctype' Γ (Op op Aop Bop v c) (CTy A Σ E)
| TypeCSubsume Γ c C C' :
    has_ctype Γ c C ->
    csubtype C C' ->
    has_ctype' Γ c C'

with has_htype : ctx -> hcases -> sig -> ctype -> Prop :=
| TypeH Γ h Σ D :
    wf_ctx Γ -> wf_sig Σ -> wf_ctype D ->
    has_htype' Γ h Σ D ->
    has_htype Γ h Σ D

with has_htype' : ctx -> hcases -> sig -> ctype -> Prop :=
| TypeCasesØ Γ D : has_htype' Γ (CasesØ D) SigØ D
| TypeCasesU Γ h op c A B Σ D :
    has_htype Γ h Σ D ->
    has_ctype (CtxU (CtxU Γ A) (TyFun B D)) c D ->
    has_htype' Γ (CasesU h op A B c) (SigU Σ op A B) D

(* ==================== Logic Judgements ==================== *)

with respects : ctx -> hcases -> sig -> ctype -> eqs -> Prop :=
| Respects Γ h Σ D E :
    wf_ctx Γ -> wf_sig Σ -> wf_ctype D -> wf_eqs E Σ ->
    has_htype Γ h Σ D -> respects' Γ h Σ D E ->
    respects Γ h Σ D E

with respects' : ctx -> hcases -> sig -> ctype -> eqs -> Prop :=
| RespectEqsØ Γ h Σ D : respects' Γ h Σ D EqsØ
| RespectEqsU Γ h Σ D E Γ' Z T1 T2 :
    respects Γ' h Σ D E ->
    judg (join_ctxs (join_ctxs Γ' (tctx_to_ctx Z D)) Γ) HypØ
      (Ceq D
        (handle_t D (ctx_len Γ) (tctx_len Z) h T1)
        (handle_t D (ctx_len Γ) (tctx_len Z) h T2) ) ->
    respects' Γ' h Σ D (EqsU E Γ Z T1 T2)

with judg : ctx -> hypotheses -> formula -> Prop :=
| WfJudg Γ Ψ φ :
    wf_ctx Γ ->
    wf_form Γ φ ->
    wf_hyp Γ Ψ ->
    judg' Γ Ψ φ ->
    judg Γ Ψ φ

with judg' : ctx -> hypotheses -> formula -> Prop :=
(* - - - - - - - - - - - - - - -  Values - - - - - - - - - - - - - - -  *)
| VeqSym Γ Ψ A v1 v2 :
    judg Γ Ψ (Veq A v1 v2) ->
    judg' Γ Ψ (Veq A v2 v1)
| VeqTrans Γ Ψ A v1 v2 v3 :
    judg Γ Ψ (Veq A v1 v2) ->
    judg Γ Ψ (Veq A v2 v3) ->
    judg' Γ Ψ (Veq A v1 v3)
| VeqVar i A Γ Ψ :
    get_vtype Γ i = Some A ->
    judg' Γ Ψ (Veq A (Var i) (Var i))
| VeqUnit Γ Ψ:
    judg' Γ Ψ (Veq TyUnit Unit Unit)
| VeqInt Γ Ψ n:
    judg' Γ Ψ (Veq TyInt (Int n) (Int n))
| VeqPair A B Γ Ψ v1 v1' v2 v2' :
    judg Γ Ψ (Veq A v1 v1') ->
    judg Γ Ψ (Veq B v2 v2') ->
    judg' Γ Ψ (Veq (TyProd A B) (Pair v1 v2) (Pair v1' v2'))
| VeqLeft A A1 A2 B B1 B2 Γ Ψ v v' :
    judg Γ Ψ (Veq A v v') ->
    judg' Γ Ψ (Veq (TySum A B) (Left A1 B1 v) (Left A2 B2 v'))
| VeqRight A A1 A2 B B1 B2 Γ Ψ v v' :
    judg Γ Ψ (Veq B v v') ->
    judg' Γ Ψ (Veq (TySum A B) (Right A1 B1 v) (Right A2 B2 v'))
| VeqNil A A1 A2 Γ Ψ :
    judg' Γ Ψ (Veq (TyList A) (Nil A1) (Nil A2))
| VeqCons A Γ Ψ v v' vs vs':
    judg Γ Ψ (Veq A v v') ->
    judg Γ Ψ (Veq (TyList A) vs vs') ->
    judg' Γ Ψ (Veq (TyList A) (Cons v vs) (Cons v' vs'))
| VeqFun A A1 A2 C Γ Ψ c c':
    judg (CtxU Γ A) (hyp_shift Ψ 1 0) (Ceq C c c') ->
    judg' Γ Ψ (Veq (TyFun A C) (Fun A1 c) (Fun A2 c'))
| VeqHandler A A1 A2 Σ E D Γ Ψ c c' h h':
    judg (CtxU Γ A) (hyp_shift Ψ 1 0) (Ceq D c c') ->
    judg Γ Ψ (Heq Σ D h h') ->
    respects Γ h Σ D E ->
    judg' Γ Ψ (Veq (TyHandler (CTy A Σ E) D) (Handler A1 c h) (Handler A2 c' h'))
| VeqSubsume Γ Ψ A A' v1 v2 :
    judg Γ Ψ (Veq A v1 v2) ->
    vsubtype A A' ->
    judg' Γ Ψ (Veq A' v1 v2)
| ηUnit Γ Ψ v:
    judg' Γ Ψ (Veq TyUnit v Unit)
| ηFun A C Γ Ψ f:
    judg' Γ Ψ (Veq (TyFun A C) (Fun A (App (v_shift f 1 0) (Var 0))) f)
(* - - - - - - - - - - - - - - -  Computations - - - - - - - - - - - - - - -  *)
| CeqSym Γ Ψ C c1 c2 :
    judg Γ Ψ (Ceq C c1 c2) ->
    judg' Γ Ψ (Ceq C c2 c1)
| CeqTrans Γ Ψ C c1 c2 c3 :
    judg Γ Ψ (Ceq C c1 c2) ->
    judg Γ Ψ (Ceq C c2 c3) ->
    judg' Γ Ψ (Ceq C c1 c3)
| CeqRet A Σ E Γ Ψ v v' :
    judg Γ Ψ (Veq A v v') ->
    judg' Γ Ψ (Ceq (CTy A Σ E) (Ret v) (Ret v'))
| CeqAbsurd Γ Ψ C C1 C2 v v' :
    judg' Γ Ψ (Ceq C (Absurd C1 v) (Absurd C2 v'))
| CeqProdMatch Γ Ψ C v v' A B c c':
    judg Γ Ψ (Veq (TyProd A B) v v') ->
    judg (CtxU (CtxU Γ A) B) (hyp_shift Ψ 2 0) (Ceq C c c') ->
    judg' Γ Ψ (Ceq C (ProdMatch v c) (ProdMatch v' c'))
| CeqSumMatch Γ Ψ C v v' A B c1 c1' c2 c2':
    judg Γ Ψ (Veq (TySum A B) v v') ->
    judg (CtxU Γ A) (hyp_shift Ψ 1 0) (Ceq C c1 c1') ->
    judg (CtxU Γ B) (hyp_shift Ψ 1 0) (Ceq C c2 c2') ->
    judg' Γ Ψ (Ceq C (SumMatch v c1 c2) (SumMatch v' c1' c2'))
| CeqListMatch Γ Ψ C v v' A c1 c1' c2 c2':
    judg Γ Ψ (Veq (TyList A) v v') ->
    judg Γ Ψ (Ceq C c1 c1') ->
    judg (CtxU (CtxU Γ A) (TyList A)) (hyp_shift Ψ 2 0) (Ceq C c2 c2') ->
    judg' Γ Ψ (Ceq C (ListMatch v c1 c2) (ListMatch v' c1' c2'))
| CeqDo A B Σ E Γ Ψ c1 c1' c2 c2':
    judg Γ Ψ (Ceq (CTy A Σ E) c1 c1') ->
    judg (CtxU Γ A) (hyp_shift Ψ 1 0) (Ceq (CTy B Σ E) c2 c2') ->
    judg' Γ Ψ (Ceq (CTy B Σ E) (Do c1 c2) (Do c1' c2'))
| CeqApp Γ Ψ v1 v1' v2 v2' A C:
    judg Γ Ψ (Veq (TyFun A C) v1 v1') ->
    judg Γ Ψ (Veq A v2 v2') ->
    judg' Γ Ψ (Ceq C (App v1 v2) (App v1' v2'))
| CeqHandle Γ Ψ v v' c c' C D:
    judg Γ Ψ (Veq (TyHandler C D) v v') ->
    judg Γ Ψ (Ceq C c c') ->
    judg' Γ Ψ (Ceq D (Handle v c) (Handle v' c'))
| CeqLetRec Γ Ψ c1 c1' c2 c2' A C D:
    judg (CtxU (CtxU Γ A) (TyFun A C)) (hyp_shift Ψ 2 0) (Ceq C c1 c1') ->
    judg (CtxU Γ (TyFun A C)) (hyp_shift Ψ 1 0) (Ceq D c2 c2') ->
    judg' Γ Ψ (Ceq D (LetRec A C c1 c2) (LetRec A C c1' c2'))
| CeqOp Γ Ψ op v v' c c' A A' B B' Aop Bop Ac Σ E:
    get_op_type Σ op = Some (Aop, Bop) ->
    judg Γ Ψ (Veq Aop v v') ->
    judg (CtxU Γ Bop) (hyp_shift Ψ 1 0) (Ceq (CTy Ac Σ E) c c') ->
    judg' Γ Ψ (Ceq (CTy Ac Σ E) (Op op A B v c) (Op op A' B' v' c'))
| CeqSubsume Γ Ψ C C' c1 c2 :
    judg Γ Ψ (Ceq C c1 c2) ->
    csubtype C C' ->
    judg' Γ Ψ (Ceq C' c1 c2)
| OOTB A Σ E Γ' Ψ I Γ Z T1 T2 c1 c2:
    has_eq E Γ Z T1 T2 ->
    wf_inst Γ' I (join_ctxs (tctx_to_ctx Z (CTy A Σ E)) Γ) ->
    c_inst (tmpl_to_comp (CTy A Σ E) (ctx_len Γ) T1) I = c1 ->
    c_inst (tmpl_to_comp (CTy A Σ E) (ctx_len Γ) T2) I = c2 ->
    judg' Γ' Ψ (Ceq (CTy A Σ E) c1 c2)
| βMatchPair v1 v2 c C Γ Ψ:
    judg' Γ Ψ
    (Ceq  C
      (ProdMatch (Pair v1 v2) c)
      (c_subs2_out c v1 v2) )
| βMatchLeft v c1 c2 C A B Γ Ψ:
    judg' Γ Ψ
    (Ceq C
      (SumMatch (Left A B v) c1 c2)
      (c_subs_out c1 v) )
| βMatchRight v c1 c2 C A B Γ Ψ:
    judg' Γ Ψ
    (Ceq C
      (SumMatch (Right A B v) c1 c2)
      (c_subs_out c2 v) )
| βMatchNil c1 c2 C A Γ Ψ:
    judg' Γ Ψ
    (Ceq C
      (ListMatch (Nil A) c1 c2)
      c1 )
| βMatchCons v vs c1 c2 C Γ Ψ:
    judg' Γ Ψ
    (Ceq C
      (ListMatch (Cons v vs) c1 c2)
      (c_subs2_out c2 v vs) )
| βApp c v A C Γ Ψ:
    judg' Γ Ψ (Ceq C (App (Fun A c) v) (c_subs_out c v))
| βLetRec c1 c2 A C D Γ Ψ:
    judg' Γ Ψ
    (Ceq D
      (LetRec A C c1 c2)
      (c_subs_out c2 (Fun A (LetRec A C (c_shift c1 1 2) c1))) )
| βDoRet v c C Γ Ψ:
    judg' Γ Ψ (Ceq C (Do (Ret v) c) (c_subs_out c v))
| βDoOp op A B v c1 c2 C Γ Ψ:
    judg' Γ Ψ
    (Ceq C
      (Do (Op op A B v c1) c2)
      (Op op A B v (Do c1 (c_shift c2 1 1))) )
| βHandleRet c_r h v A C Γ Ψ:
    judg' Γ Ψ
    (Ceq C
      (Handle (Handler A c_r h) (Ret v))
      (c_subs_out c_r v) )
| βHandleOp A c_r h op Aop Bop  v c_k c_op C Γ Ψ:
    get_case h op = Some c_op ->
    judg' Γ Ψ
    (Ceq C
      (Handle (Handler A c_r h) (Op op Aop Bop v c_k))
      (c_subs2_out c_op
        v (Fun Bop (Handle (v_shift (Handler A c_r h) 1 0) c_k)) ) )
| ηEmpty Γ Ψ v n c C C':
    n <= ctx_len Γ ->
    has_ctype (ctx_insert Γ n (TyEmpty)) c C' ->
    judg' Γ Ψ (Ceq C' (c_subs c n v) (Absurd C v) )
| ηPair Γ Ψ v n c C A B:
    n <= ctx_len Γ ->
    has_ctype (ctx_insert Γ n (TyProd A B)) c C ->
    judg' Γ Ψ (Ceq C (c_subs c n v)
      (ProdMatch v (c_subs (c_shift c 2 0) (2+n) (Pair (Var 1) (Var 0)))) )
| ηSum Γ Ψ v n c C A B:
    n <= ctx_len Γ ->
    has_ctype (ctx_insert Γ n (TySum A B)) c C ->
    judg' Γ Ψ (Ceq C (c_subs c n v)
      (SumMatch v
        (c_subs (c_shift c 1 0) (1+n) (Left A B (Var 0)))
        (c_subs (c_shift c 1 0) (1+n) (Right A B (Var 0)))) )
| ηList Γ Ψ v n c C A:
    n <= ctx_len Γ ->
    has_ctype (ctx_insert Γ n (TyList A)) c C ->
    judg' Γ Ψ (Ceq C (c_subs c n v)
      (ListMatch v
        (c_subs c n (Nil A))
        (c_subs (c_shift c 2 0) (2+n) (Cons (Var 1) (Var 0)))) )
| ηDo Γ Ψ c C:
    judg' Γ Ψ (Ceq C (Do c (Ret (Var 0))) c)
| DoLoop Γ Ψ c A C D:
    judg' Γ Ψ (Ceq D
      (Do (LetRec A C (App (Var 0) Unit) (App (Var 0) Unit) ) c)
      (LetRec A C (App (Var 0) Unit) (App (Var 0) Unit) ) )
| HandleLoop Γ Ψ v A C D:
    judg' Γ Ψ (Ceq D
      (Handle v (LetRec A C (App (Var 0) Unit) (App (Var 0) Unit)))
      (LetRec A C (App (Var 0) Unit) (App (Var 0) Unit)) )
(* - - - - - - - - - - - - - - -  Cases - - - - - - - - - - - - - - -  *)
| HeqSym Γ Ψ Σ D h1 h2 :
    judg Γ Ψ (Heq Σ D h1 h2) ->
    judg' Γ Ψ (Heq Σ D h2 h1)
| HeqTrans Γ Ψ Σ D h1 h2 h3 :
    judg Γ Ψ (Heq Σ D h1 h2) ->
    judg Γ Ψ (Heq Σ D h2 h3) ->
    judg' Γ Ψ (Heq Σ D h1 h3)
| HeqSigØ D Γ Ψ h1 h2:
    judg' Γ Ψ (Heq SigØ D h1 h2)
| HeqSigU Σ op A B D Γ Ψ h1 c1 h2 c2:
    get_case h1 op = Some c1 ->
    get_case h2 op = Some c2 ->
    judg (CtxU (CtxU Γ A) (TyFun B D)) (hyp_shift Ψ 2 0) (Ceq D c1 c2) ->
    judg Γ Ψ (Heq Σ D h1 h2) ->
    judg' Γ Ψ (Heq (SigU Σ op A B) D h1 h2)
| HeqExtend Γ Ψ op h1 h2 c1 c2 A B Σ D:
    judg Γ Ψ (Heq Σ D h1 h2) ->
    get_case h1 op = None -> get_case h2 op = None ->
    judg (CtxU (CtxU Γ A) (TyFun B D)) (hyp_shift Ψ 2 0) (Ceq D c1 c2) ->
    judg' Γ Ψ (Heq (SigU Σ op A B) D
      (CasesU h1 op A B c1) (CasesU h2 op A B c2))
(* - - - - - - - - - - - - - - -  General - - - - - - - - - - - - - - -  *)
| IsHyp Γ Ψ φ:
    has_hypothesis Ψ φ ->
    judg' Γ Ψ φ
| TruthIn Γ Ψ :
    judg' Γ Ψ Truth
| FalsityEl Γ Ψ φ:
    judg Γ Ψ Falsity ->
    judg' Γ Ψ φ
| AndIn Γ Ψ φ1 φ2:
    judg Γ Ψ φ1 ->
    judg Γ Ψ φ2 ->
    judg' Γ Ψ (And φ1 φ2)
| AndElLeft Γ Ψ φ1 φ2:
    judg Γ Ψ (And φ1 φ2) ->
    judg' Γ Ψ φ1
| AndElRight Γ Ψ φ1 φ2:
    judg Γ Ψ (And φ1 φ2) ->
    judg' Γ Ψ φ2
| OrLefteft Γ Ψ φ1 φ2:
    judg Γ Ψ φ1 ->
    judg' Γ Ψ (Or φ1 φ2)
| OrRightight Γ Ψ φ1 φ2:
    judg Γ Ψ φ1 ->
    judg' Γ Ψ (Or φ1 φ2)
| OrEl Γ Ψ φ1 φ2 Φ:
    judg Γ Ψ (Or φ1 φ2) ->
    judg Γ Ψ (Implies φ1 Φ) ->
    judg Γ Ψ (Implies φ2 Φ) ->
    judg' Γ Ψ (Implies (Or φ1 φ2) Φ)
| ImpliesIn Γ Ψ φ1 φ2:
    judg Γ (HypU Ψ φ1) φ2 ->
    judg' Γ Ψ (Implies φ1 φ2)
| ImpliesEl Γ Ψ φ1 φ2:
    judg Γ Ψ φ1 ->
    judg Γ Ψ (Implies φ1 φ2) ->
    judg' Γ Ψ φ2
| ForallIn Γ Ψ φ A:
    judg (CtxU Γ A) (hyp_shift Ψ 1 0) φ ->
    judg' Γ Ψ (Forall A φ)
| ForallEl Γ Ψ φ v A:
    judg Γ Ψ (Forall A φ) ->
    has_vtype Γ v A ->
    judg' Γ Ψ (form_subs φ 0 v)
| ExistsIn Γ Ψ φ v A:
    has_vtype Γ v A ->
    judg Γ Ψ (form_subs φ 0 v) ->
    judg' Γ Ψ (Exists A φ)
| ExistsEl Γ Ψ φ Φ A:
    judg Γ Ψ (Exists A φ) ->
    judg (CtxU Γ A) (HypU (hyp_shift Ψ 1 0) φ) (form_shift Φ 1 0) ->
    judg' Γ Ψ Φ
| CompInduction Γ Ψ A Σ E φ :
    (* Ensure admissibility *)
    var_admissible 0 φ ->
    (* Base case *)
    judg (CtxU Γ A) (hyp_shift Ψ 1 0)
      (form_subs (form_shift φ 1 0) 1 (Fun TyUnit (Ret (Var 1)))) ->
    (* Operation case *)
    (forall op Aop Bop,
      get_op_type Σ op = Some (Aop, Bop) ->
      judg
        (CtxU (CtxU Γ Aop) (TyFun Bop (CTy A Σ E)))
        (HypU (hyp_shift Ψ 2 0)
          (Forall Bop
            (form_subs (form_shift φ 3 0) 3
              (Fun TyUnit (App (Var 2) (Var 1))))))
        (form_subs (form_shift φ 2 0) 2
          (Fun TyUnit (Op op Aop Bop (Var 2) (App (Var 2) (Var 0)))))
    ) ->
    (* Nontermination case *)
    judg Γ Ψ
      (form_subs φ 0
        (Fun TyUnit (LetRec TyUnit (CTy A Σ E)
          (App (Var 0) Unit)
          (App (Var 0) Unit) ))
      ) ->
    (* Conclusion *)
    judg' Γ Ψ (Forall (TyFun TyUnit (CTy A Σ E)) φ)

(* ==================== Wellformed instantiations ==================== *)

with wf_inst : ctx -> instantiation -> ctx -> Prop :=
| WfInstØ Γcheck : wf_ctx Γcheck -> wf_inst Γcheck InstØ CtxØ
| WfInstU Γcheck I v Γ A :
  has_vtype Γcheck v A ->
  wf_inst Γcheck I Γ ->
  wf_inst Γcheck (InstU I v) (CtxU Γ A)
.


Set Implicit Arguments.

Require Import List Lia ZArith.
Import ListNotations.

Require Import Util.Class.
Require Import Util.Misc.
Require Export Util.Color.

Inductive Piece := King | Rook.

Instance PieceEnum : Enum Piece := {|
  enum := [King;Rook]
  |}.
Proof.
  destruct x; simpl; auto.
Defined.

Instance PieceEq : Eq Piece.
  derive_eq.
Defined.

Instance PieceSearch : Search Piece.
  constructor.
  intros P Pd.
  destruct (Pd King).
  left; exists King; auto.
  destruct (Pd Rook).
  left; exists Rook; auto.
  right; intros [[] HP]; auto.
Defined.

Inductive Rank := R1 | R2 | R3 | R4.

Instance RankEq : Eq Rank.
  derive_eq.
Defined.

Instance RankEnum : Enum Rank := {|
  enum := [R1;R2;R3;R4]
  |}.
Proof.
  destruct x; simpl; auto.
Defined.

Instance RankSearch : Search Rank.
  constructor.
  intros P Pd.
  destruct (Pd R1).
  left; exists R1; auto.
  destruct (Pd R2).
  left; exists R2; auto.
  destruct (Pd R3).
  left; exists R3; auto.
  destruct (Pd R4).
  left; exists R4; auto.
  right; intros [[] HP]; auto.
Defined.

Inductive File := A | B | C | D.

Instance FileEq : Eq File.
  derive_eq.
Defined.

Instance FileEnum : Enum File := {|
  enum := [A;B;C;D]
  |}.
Proof.
  destruct x; simpl; auto.
Defined.

Instance FileSearch : Search File.
  constructor.
  intros P Pd.
  destruct (Pd A).
  left; exists A; auto.
  destruct (Pd B).
  left; exists B; auto.
  destruct (Pd C).
  left; exists C; auto.
  destruct (Pd D).
  left; exists D; auto.
  right; intros [[] HP]; auto.
Defined.

Instance RanktoNat : toNat Rank := {
  num := fun r => match r with
                  | R1 => 0
                  | R2 => 1
                  | R3 => 2
                  | R4 => 3
                  end
  }.

Instance FiletoNat : toNat File := {
  num := fun f => match f with
                  | A => 0
                  | B => 1
                  | C => 2
                  | D => 3
                  end
  }.

Definition Board := File * Rank -> option (Color * Piece).

Definition occupied : Board -> File * Rank -> Prop :=
  fun b p => match b p with
             | None => False
             | Some _ => True
             end.

Definition friendly : Board -> Color -> File * Rank -> Prop :=
  fun b c p => match b p with
               | None => False
               | Some (c',_) => c = c'
               end.

Definition enemy : Board -> Color -> File * Rank -> Prop :=
  fun b c p => match b p with
               | None => False
               | Some (c',_) => c <> c'
               end.

Definition king_adj : File * Rank -> File * Rank -> Prop :=
  fun p q => p <> q /\
    dist (num (fst p)) (num (fst q)) <= 1 /\ dist (num (snd p)) (num (snd q)) <= 1.

Lemma king_adj_sym : forall p q, king_adj p q -> king_adj q p.
Proof.
  intros [x y] [x' y'] [H1 H2].
  unfold king_adj; split.
  auto.
  rewrite (dist_sym (num x')), (dist_sym (num y')); exact H2.
Qed.

Definition threatens(b : Board)(p : File * Rank)(q : File * Rank) : Prop :=
  match b p with
  | None => False
  | Some (c,x) => ~ friendly b c q
      /\ match x with
         | King => king_adj p q
         | Rook => (fst p = fst q /\ snd p <> snd q /\ ~ exists r, between (snd p) r (snd q) /\ occupied b (fst p,r))
                \/ (snd p = snd q /\ fst p <> fst q /\ ~ exists f, between (fst p) f (fst q) /\ occupied b (f,snd p))
         end
  end.

Definition in_check : Board -> Color -> Prop :=
  fun b c => exists p q, b q = Some (c,King) /\ threatens b p q.

Record GameState := {
  board : Board;
  to_play : Color;
  no_check : ~ in_check board (flip to_play);
  white_king : exists! p, board p = Some (White,King);
  black_king : exists! p, board p = Some (Black,King);
  }.

Definition make_move : File * Rank -> File * Rank -> Board -> Board :=
  fun p q b => update p None (update q (b p) b).

Definition legal_move(g : GameState)(p q : File * Rank) : Prop :=
     friendly (board g) (to_play g) p
  /\ threatens (board g) p q
  /\ ~ in_check (make_move p q (board g)) (to_play g).

Definition checkmate(g : GameState) :=
     in_check (board g) (to_play g)
  /\ ~ exists p q, legal_move g p q.

Lemma legal_move_diff_squares : forall g p q, legal_move g p q -> p <> q.
Proof.
  intros.
  destruct H as [_ [H _]].
  unfold threatens in H.
  destruct (board g p) eqn:G.
  destruct p0; destruct H.
  unfold friendly in H.
  intro.
  rewrite <- H1 in H.
  rewrite G in H.
  apply H; reflexivity.
  destruct H.
Qed.

Lemma no_king_capture : forall g p q c, legal_move g p q ->
  board g q <> Some (c,King).
Proof.
  intros.
  destruct (c =dec (to_play g)).
  destruct H as [H1 [H2 _]].
  unfold threatens in H2.
  unfold friendly in H1.
  destruct (board g p).
  destruct p0; destruct H2 as [H2 _].
  unfold friendly in H2.
  destruct (board g q).
  destruct p1.
  intro; congruence.
  discriminate.
  destruct H1.
  intro.
  apply (no_check g).
  exists p,q.
  split.
  rewrite (neq_flip c); auto.
  unfold legal_move in H; tauto.
Qed.

Definition make_legal_move(g : GameState)(p q : File * Rank) : legal_move g p q -> GameState.
  intro l.
  refine {|
            board := make_move p q (board g);
            to_play := flip (to_play g)
         |}.
Proof.
  unfold legal_move in l.
  rewrite flip_flip; tauto.
  destruct (white_king g) as [p' [H1 H2]].
  destruct (p' =dec p).
  exists q; split.
  unfold make_move, update.
  destruct (p =dec q).
  elim (legal_move_diff_squares l e0).
  destruct (q =dec q).
  congruence.
  elim n0; reflexivity.
  unfold make_move, update; intros.
  destruct (p =dec x').
  discriminate.
  destruct (q =dec x').
  auto.
  elim n.
  rewrite <- e; auto.
  exists p'; split.
  unfold make_move, update.
  destruct (p =dec p').
  elim n; auto.
  destruct (q =dec p').
  elim (no_king_capture l (c := White)).
  congruence.
  auto.
  intros.
  apply H2.
  unfold make_move, update in H.
  destruct (p =dec x').
  congruence.
  destruct (q =dec x').
  elim n; auto.
  auto.
  destruct (black_king g) as [p' [H1 H2]].
  destruct (p' =dec p).
  exists q; split.
  unfold make_move, update.
  destruct (p =dec q).
  elim (legal_move_diff_squares l e0).
  destruct (q =dec q).
  congruence.
  elim n0; reflexivity.
  unfold make_move, update; intros.
  destruct (p =dec x').
  discriminate.
  destruct (q =dec x').
  auto.
  elim n.
  rewrite <- e; auto.
  exists p'; split.
  unfold make_move, update.
  destruct (p =dec p').
  elim n; auto.
  destruct (q =dec p').
  elim (no_king_capture l (c := Black)).
  congruence.
  auto.
  intros.
  apply H2.
  unfold make_move, update in H.
  destruct (p =dec x').
  congruence.
  destruct (q =dec x').
  elim n; auto.
  auto.
Defined.

Definition blank_board : Board := fun _ => None.

(*

 (*TODO:improve*)
Ltac decision :=
  match goal with
  | |- dec (_ /\ _) => apply and_dec; decision
  | |- dec (_ \/ _) => apply or_dec; decision
  | |- dec (~ _) => apply not_dec; decision
  | |- dec (_ -> _) => apply impl_dec; decision
  | |- dec (forall _,_) => apply search_all; decision
  | |- dec True => left; tauto
  | |- dec False => right; tauto
  | |- dec (exists _: _, _) => apply search; decision
  | |- forall _,_ => intro; decision
  | |- dec (_ = _) => apply eq
  | |- dec (_ <= _) => apply Compare_dec.le_dec
  | |- dec (_ < _) => apply Compare_dec.lt_dec
  | |- dec (match ?t with _ => _ end) => destruct ?t; decision
  | |- _ => idtac
  end.

(* TODO: ltac-ize *)
Lemma legal_dec : forall g p q, dec (legal_move g p q).
Proof.
  intros.
  unfold legal_move.
  decision.
  unfold friendly.
  destruct board; decision.
  destruct p0.
  decision.
  unfold threatens.
  destruct board.
  destruct p0.
  decision.
  unfold friendly.
  destruct board.
  destruct p1; decision.
  decision.
  destruct p0.
  unfold king_adj.
  destruct p,q.
  decision.
  decision.
  unfold between.
  unfold betw; decision.
  unfold occupied.
  destruct board; decision.
  unfold between.
  unfold betw; decision.
  unfold occupied.
  destruct board; decision.
  decision.
  unfold in_check.
  decision.
  unfold threatens.
  destruct make_move.
  destruct p0.
  decision.
  unfold friendly; destruct make_move.
  destruct p1; decision.
  decision.
  destruct p0; decision.
  unfold king_adj; decision.
  destruct x,x0; decision.
  unfold between; unfold betw; decision.
  unfold occupied.
  destruct make_move; decision.
  unfold between; unfold betw; decision.
  unfold occupied; destruct make_move; decision.
  decision.
Defined.

Definition game_moves : GameState -> list ((File * Rank) * (File * Rank)) :=
  fun g => dec_enum (fun '(p,q) => legal_move g p q)
    (fun '(p,q) => legal_dec g p q).

Definition test_board : Board :=
  (update (A,R1) (Some (White,King))
  (update (D,R4) (Some (Black,King))
  (update (C,R2) (Some (White,Rook)) blank_board))).

Definition test_gs : GameState.
  refine {|
    board := test_board;
    to_play := White
  |}.
Proof.
  simpl.
  intros [p [q [H1 H2]]].
  unfold test_board,update,blank_board in H1.
  destruct ((A,R1) == q).
  discriminate.
  destruct ((D,R4) == q).
  rewrite <- e in H2.
  unfold threatens in H2.
  destruct (test_board p) eqn:G.
  destruct p0.
  destruct H2.
  destruct p0.
  unfold friendly in H; simpl in H.
  destruct c.
  unfold test_board,update,blank_board in G.
  destruct ((A,R1) == p).
  rewrite <- e0 in H0.
  simpl in H0; lia.
  destruct ((D,R4) == p).
  discriminate G.
  destruct ((C,R2) == p).
  discriminate G.
  discriminate G.
  apply H; reflexivity.
  unfold test_board,update,blank_board in G.
  destruct ((A,R1) == p).
  discriminate G.
  destruct ((D,R4) == p).
  discriminate G.
  destruct ((C,R2) == p).
  rewrite <- e0 in H0.
  simpl in H0.
  destruct H0;
  destruct H0;
  discriminate.
  discriminate.
  exact H2.
  destruct ((C,R2) == q); discriminate.
  exists (A,R1); split.
  auto.
  intros [f r] H.
  destruct f; destruct r; try discriminate; try auto.
  exists (D,R4); split.
  auto.
  intros [f r] H.
  destruct f; destruct r; try discriminate; try auto.
Defined.

Definition test_gs2 : GameState.
  refine {|
    board := test_board;
    to_play := Black
  |}.
Proof.
  simpl.
  intros [p [q [H1 H2]]].
  unfold test_board,update,blank_board in H1.
  destruct ((A,R1) == q).
  rewrite <- e in H2.
  unfold threatens in H2.
  destruct (test_board p) eqn:G.
  destruct p0.
  destruct H2.
  destruct p0.
  unfold friendly in H; simpl in H.
  unfold test_board,update,blank_board in G.
  destruct ((A,R1) == p).
  apply H.
  inversion G; auto.
  destruct ((D,R4) == p).
  rewrite <- e0 in H0.
  simpl in H0; lia.
  destruct ((C,R2) == p).
  discriminate.
  discriminate.
  simpl in H0.
  unfold test_board,update,blank_board in G.
  destruct ((A,R1) == p).
  discriminate.
  destruct ((D,R4) == p).
  discriminate.
  destruct ((C,R2) == p).
  unfold friendly in H.
  simpl in H.
  apply H; inversion G; auto.
  discriminate.
  exact H2.
  destruct ((D,R4) == q).
  discriminate.
  destruct ((C,R2) == q).
  discriminate.
  discriminate.
  exists (A,R1); split.
  auto.
  intros [f r] H.
  destruct f; destruct r; try discriminate; try auto.
  exists (D,R4); split.
  auto.
  intros [f r] H.
  destruct f; destruct r; try discriminate; try auto.
Defined.

Record KRvK(g : GameState) : Prop := {
  black_only_king : forall p x, board g p = Some (Black,x) -> x = King;
  white_at_most_one_rook : forall p q, board g p = Some (White,Rook) -> board g q = Some (White,Rook) -> p = q
  }.

Lemma WK_forget_unique : forall g, exists p, board g p = Some (White,King).
Proof.
  intro g.
  destruct (white_king g) as [p [H _]].
  exists p; exact H.
Qed.

Lemma BK_forget_unique : forall g, exists p, board g p = Some (Black,King).
Proof.
  intro g.
  destruct (black_king g) as [p [H _]].
  exists p; exact H.
Qed.

Definition WK_pos : GameState -> File * Rank :=
  fun g => projT1 (choice (fun p => board g p = Some (White,King))
   (fun q => eq (board g q) (Some (White,King))) (WK_forget_unique g)).

Definition BK_pos : GameState -> File * Rank :=
  fun g => projT1 (choice (fun p => board g p = Some (Black,King))
   (fun q => eq (board g q) (Some (Black,King))) (BK_forget_unique g)).

Definition FR_nat : File * Rank -> nat :=
  fun '(f,r) => (2 ^ 2) * (num f) + num r.

Definition KRvKtup := (Color * (File * Rank) * (File * Rank) * (File * Rank))%type.

Definition KRvKc : KRvKtup -> Color :=
  fun '(c,_,_,_) => c.

Definition WK : KRvKtup -> File * Rank :=
  fun '(_,x,_,_) => x.

Definition BK : KRvKtup -> File * Rank :=
  fun '(_,_,x,_) => x.

Definition WR : KRvKtup -> File * Rank :=
  fun '(_,_,_,x) => x.

Record legal_tup t : Prop := {
  WK_BK : WK t <> BK t;
  WK_WR : WK t <> WR t;
  BK_WR : BK t <> WR t;
  king_sep : ~ king_adj (WK t) (BK t);
  WK_file_block : KRvKc t = White -> fst (BK t) = fst (WR t) ->
    fst (WK t) = fst (BK t) /\ between (snd (BK t)) (snd (WK t)) (snd (WR t));
  WK_rank_block : KRvKc t = White -> snd (BK t) = snd (WR t) ->
    snd (WK t) = snd (BK t) /\ between (fst (BK t)) (fst (WK t)) (fst (WR t))
  }.

Lemma between_dec{X}`{toNat X} : forall x y z : X, dec (between x y z).
Proof.
  intros.
  unfold between, betw.
  decision.
Defined.

Lemma king_adj_dec : forall p q, dec (king_adj p q).
Proof.
  intros [x y] [x' y'].
  unfold king_adj.
  decision.
Defined.

Lemma legal_tup_dec : forall t, dec (legal_tup t).
Proof.
  intros [[[c wk] bk] wr].
  destruct (wk == bk).
  right; intro l; destruct l; contradiction.
  destruct (wk == wr).
  right; intro l; destruct l; contradiction.
  destruct (bk == wr).
  right; intro l; destruct l; contradiction.
  destruct (king_adj_dec wk bk).
  right; intros [_ _ _ nk _ _]; auto.
  destruct c eqn:C.
  destruct ((fst bk) == (fst wr)).
  destruct ((fst bk) == (fst wk)).
  destruct (between_dec (snd bk) (snd wk) (snd wr)).
  left.
  constructor; auto.
  simpl.
  intro k.
  intros.
  elim n1; destruct wr,bk.
  simpl in e,H; congruence.
  right; intros [_ _ _ _ ch _].
  tauto.
  right; intros [_ _ _ _ ch _].
  simpl in ch.
  elim n3.
  symmetry; tauto.
  destruct ((snd bk) == (snd wr)).
  destruct ((snd wk) == (snd bk)).
  destruct (between_dec (fst bk) (fst wk) (fst wr)).
  left.
  constructor; (auto || tauto).
  right; intros [_ _ _ _ _ b].
  tauto.
  right; intros [_ _ _ _ _ b].
  tauto.
  left; constructor; (auto || tauto || (intros; discriminate)).
  left; constructor; (auto || tauto || (intros; discriminate)).
Defined.

Definition tup_board : KRvKtup -> Board :=
  fun '(c,p,q,r) => (update p (Some (White,King))
                    (update q (Some (Black,King))
                    (update r (Some (White,Rook)) blank_board))).

Definition tup_gs : forall t, legal_tup t -> GameState.
Proof.
  intros [[[c p] q] r] [H1 [H2 [H3 H4]]].
  refine {|
    board := tup_board (c,p,q,r);
    to_play := c
    |}.
  exact H1.
  unfold tup_board; unfold update.
  exists p; split.
  destruct (p == p).
  reflexivity.
  elim n; reflexivity.
  intros.
  destruct (p == x').
  exact e.
  repeat (destruct eq; try discriminate).
  unfold tup_board; unfold update.
  exists q; split.
  destruct (p == q).
  contradiction.
  destruct (q == q).
  reflexivity.
  elim n0; reflexivity.
  intros.
  repeat (destruct eq; (discriminate || auto)).
Defined.

Definition black_checkmate : forall t, legal_tup t -> Prop :=
  fun t l => in_check (tup_board t) Black /\
    game_moves (tup_gs t l) = [].

Lemma black_checkmate_black : forall c p q r l,
  black_checkmate (c,p,q,r) l -> c = Black.
Proof.
  intros.
  destruct c.
  destruct H.
  simpl in H.
  destruct l.
  simpl in n.
  elim n; exact H.
  reflexivity.
Qed.

Lemma black_checkmate_dec : forall t (l : legal_tup t),
  dec (black_checkmate t l).
Proof.
  intros.
  destruct t as [[[[] p] q] r].
  right.
  intro.
  discriminate (black_checkmate_black H).
  apply and_dec.
  unfold in_check.
  decision.
  unfold threatens.
  destruct tup_board.
  destruct p0.
  decision.
  unfold friendly.
  destruct tup_board; decision.
  destruct p1; decision.
  destruct p0; decision.
  unfold king_adj; destruct x,x0; decision.
  unfold between; unfold betw; decision.
  unfold occupied.
  destruct tup_board; decision.
  unfold between; unfold betw; decision.
  unfold occupied.
  destruct tup_board; decision.
  decision.
  destruct game_moves.
  left; auto.
  right; discriminate.
Defined.

Definition is_black_cm t :=
  match legal_tup_dec t with
  | left l => black_checkmate t l
  | right _ => False
  end.

Lemma is_black_cm_dec : forall t, dec (is_black_cm t).
Proof.
  intro; unfold is_black_cm.
  destruct legal_tup_dec.
  apply black_checkmate_dec.
  decision.
Defined.

*)


Require Import List.
Export ListNotations.

Require Import PeanoNat.

Require Import Ensembles.
Require Import K_Syntax.
Require Import K_GHC.
Require Import K_logics.

Lemma extens_diff_sKH : forall (p : V),
    sKH_prv (Singleton _ (# p), Box (# p)).
Proof.
intro p. apply sNec with (ps:=[(Singleton _ (# p), #p)]).
intros. inversion H. subst. apply Ids. apply IdRule_I. apply In_singleton.
inversion H0. apply sNecRule_I.
Qed.

Theorem sKH_extens_wKH : forall s,
    (wKH_prv s) -> (sKH_prv s).
Proof.
intros s D. induction D.
(* Id *)
- inversion H. subst. apply Ids. apply IdRule_I. auto.
(* Ax *)
- inversion H. subst. apply Axs. apply AxRule_I. auto.
(* MP *)
- inversion H1. subst. assert (J1: List.In (Γ, A --> B) [(Γ, A --> B); (Γ, A)]). apply in_eq.
  pose (H0 (Γ, A --> B) J1). assert (J2: List.In (Γ, A) [(Γ, A --> B); (Γ, A)]). apply in_cons. apply in_eq.
  pose (H0 (Γ, A) J2). apply MPs with (ps:=[(Γ, A --> B); (Γ, A)]).
  intros. inversion H2. subst. auto. inversion H3. subst. auto. inversion H4. apply MPRule_I.
(* wNec *)
- inversion H1. subst. assert (J1: List.In (Empty_set MPropF, A) [(Empty_set MPropF, A)]). apply in_eq.
  pose (H0 (Empty_set MPropF, A) J1). assert (Included _ (Empty_set _) Γ).
  intro. intro. inversion H2. pose (@sKH_monot (Empty_set _, A) s Γ H2).
  apply sNec with (ps:=[(Γ, A)]). intros. inversion H3. subst.
  assumption. inversion H4. apply sNecRule_I.
Qed.

Theorem sKH_same_thms_wKH : forall s,
    (sKH_prv s) ->
    (forall A, ((Empty_set _, A) = s) -> (wKH_prv s)).
Proof.
intros s D. induction D.
(* Ids *)
- intros A id. inversion H. subst. inversion H2. subst.
  apply Id. apply IdRule_I. auto.
(* Axs *)
- intros A id. inversion H. subst. inversion H2. subst.
  apply Ax. apply AxRule_I. auto.
(* MPs *)
- intros A id. inversion H1. subst. inversion H3. subst.
  assert (J1: List.In (Empty_set MPropF, A0 --> A) [(Empty_set MPropF, A0 --> A); (Empty_set MPropF, A0)]). apply in_eq.
  pose (H0 (Empty_set MPropF, A0 --> A) J1).
  assert (J2: List.In (Empty_set MPropF, A0) [(Empty_set MPropF, A0 --> A); (Empty_set MPropF, A0)]). apply in_cons. apply in_eq.
  pose (H0 (Empty_set MPropF, A0) J2).
  apply MP with (ps:=[(Empty_set _, A0 --> A); (Empty_set _, A0)]).
  intros. inversion H2. subst. apply w with (A1:=A0 --> A). auto.
  inversion H4. subst. apply w0 with (A:=A0). auto. inversion H5. apply MPRule_I.
(* sNec *)
- intros A id. inversion H1. subst. inversion H3. subst.
  assert (J1: List.In (Empty_set MPropF, A0) [(Empty_set MPropF, A0)]). apply in_eq.
  pose (H0 (Empty_set MPropF, A0) J1).
  apply wNec with (ps:=[(Empty_set _, A0)]). intros. inversion H2. subst.
  apply w with (A:=A0). auto. inversion H4. apply wNecRule_I.
Qed.

Theorem wKH_same_thms_sKH : forall s,
    (wKH_prv s) ->
    (forall A, ((Empty_set _, A) = s) -> (sKH_prv s)).
Proof.
intros. apply sKH_extens_wKH. assumption.
Qed.

Theorem wKH_sKH_same_thms : forall A,
    wKH_prv (Empty_set _, A) <-> sKH_prv (Empty_set _, A).
Proof.
intros. split ; intro. apply wKH_same_thms_sKH with (A:=A) ; auto.
apply sKH_same_thms_wKH with (A:=A) ; auto.
Qed.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This defines the static semantics of statements and expressions, pg. 63.

*)
Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax Cyclone_Static_Semantics_Typing_Heap_Objects.
Require Export Cyclone_LN_Env.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

(* TODO Not in the thesis. I need it and in K when the context is formed. *)

(* This is equivalent to OK from LibEnv. *)
Inductive WFD : Delta -> Prop :=
  | WFD_ddot   : WFD ddot
  | WFD_xtau   : forall (d : Delta) (alpha : var) (k : Kappa),
                 get alpha d = None ->
                 WFD  d ->
                 WFD (d & alpha ~ k).
Hint Constructors WFD.
Hint Extern 1 (WFD ddot) => unfold ddot.

Inductive K : Delta -> Tau -> Kappa -> Prop :=
 | K_cint   : forall (d : Delta),
                  K d cint B

 | K_B     : forall (d : Delta) (alpha : var),
              (* binds alpha B d -> *)
               get alpha d = Some B ->
               K d (ftvar alpha) B

 | K_star_A  : forall (d : Delta) (alpha : var),
                 (* binds  alpha A d -> *)
                  get alpha d = Some A ->
                 K  d (ptype (ftvar alpha)) B

 | K_cross   : forall (d : Delta) (t0 t1 : Tau),
                    K d t0 A ->
                    K d t1 A ->
                    K d (cross t0 t1) A

 | K_arrow   : forall (d : Delta) (t0 t1 : Tau),
                    K d t0 A ->
                    K d t1 A ->
                    K d (arrow t0 t1) A

 | K_ptype    :  forall (d : Delta) (tau : Tau),
                    K d tau A ->
                    K d (ptype tau) B

 | K_utype  : forall (L : vars) (d : Delta) (k : Kappa) (tau : Tau),
                (forall (alpha : var),
                   alpha \notin L ->
                   ok (d & alpha ~ k) ->
                   K  (d & alpha ~ k) (T.open_rec 0 (ftvar alpha) tau) A) ->
                K d (utype k tau) A

 | K_etype  : forall (L : vars) (d : Delta) (k : Kappa) (tau : Tau) (p : Phi),
              (forall (alpha : var),
                 alpha \notin L ->
                 ok (d & alpha ~ k) ->
                 K (d & alpha ~ k) (T.open_rec 0 (ftvar alpha) tau) A) ->
              K d (etype p k tau) A

 | K_B_A     : forall (d : Delta) (tau : Tau),
     K d tau B ->
     K d tau A.

Ltac K_constructors :=
  match goal with
   | H: K _ ?t B |- K _ ?t A => try apply K_B_A
   | |-  (K _ _ _)  =>
    try apply K_cint; try apply K_B; try apply K_star_A; try apply K_cross;
    try apply K_arrow; try apply K_ptype
  end.
Hint Extern 3 (K _ _ _) => try K_constructors.

Inductive AK : Delta -> Tau -> Kappa -> Prop :=

 | AK_AK_K  : forall (d : Delta) (tau : Tau) (k : Kappa),
                   K  d tau k ->
                   AK d tau k

 | AK_A     : forall (d : Delta) (alpha : var),
                (* binds alpha A d -> *)
                get alpha d = Some A ->
                AK d (ftvar alpha) A.

Hint Constructors AK.
Hint Extern 1 (AK ddot) => unfold ddot.

Inductive ASGN : Delta -> Tau -> Prop :=

  | ASGN_cint  : forall (d : Delta),
                      ASGN d cint

  | ASGN_B     : forall (d : Delta) (alpha : var),
                   (* binds alpha B d -> *)
                   get alpha d = Some B ->
                   ASGN d (ftvar alpha)

  | ASGN_ptype : forall (d : Delta) (tau : Tau),
                   ASGN d (ptype tau)

  | ASGN_cross : forall (d : Delta) (t0 t1 : Tau),
                   ASGN d t0 ->
                   ASGN d t1 ->
                   ASGN d (cross t0 t1)

  | ASGN_arrow : forall (d : Delta) (t0 t1 : Tau),
                   ASGN d t0 ->
                   ASGN d t1 ->
                   ASGN d (arrow t0 t1)

  | ASGN_utype : forall (L : vars) (d : Delta)  (k : Kappa) (tau : Tau),
                 (forall (alpha : var),
                     alpha \notin L ->
                   ASGN (d & alpha ~ k) (T.open_rec 0 (ftvar alpha) tau)) ->
                   ASGN d (utype k tau)

  | ASGN_etype : forall (L : vars) (d : Delta) (k : Kappa) (tau : Tau),
                 (forall (alpha : var),
                     alpha \notin L ->
                     ASGN (d & alpha ~ k) (T.open_rec 0 (ftvar alpha) tau)) ->
                   ASGN d (etype witnesschanges k tau).
Hint Constructors ASGN.
Hint Extern 1 (ASGN ddot) => unfold ddot.

Inductive WFU : Upsilon -> Prop :=
  | WFU_udot : WFU udot
  | WFU_A   : forall (u : Upsilon) (tau : Tau) (p : Path) (x : var),
                 LVPE.V.get (x,p) u = None ->
                 WFU  u ->
                 K ddot tau A ->
                 WFU (u &p ((x,p) ~p tau)).
Hint Constructors WFU.
Hint Extern 1 (WFU udot) => unfold udot.

Inductive WFDG : Delta -> Gamma -> Prop :=
  | WFDG_d_gdot : forall (d: Delta),
                     WFDG d gdot
  | WFDG_xt      : forall (d: Delta) (g: Gamma) (x : var) (tau : Tau),
                     get x g = None ->
                     K d tau A ->
                     WFDG d g ->
                     WFDG d (g & (x ~ tau))
(* Proposed Thesis bug, I have to be able to extend WFDG with a new type variable. *)
  | WFDG_alphak   : forall (d: Delta) (g: Gamma) (alpha : var) (k : Kappa),
                     get alpha d = None ->
                     WFDG d g ->
                     WFDG (d & (alpha ~ k)) g.

Hint Constructors WFDG.
Hint Extern 6 (WFDG _ _) => try apply WFDG_xt; auto.
Hint Extern 1 (WFDG ddot _) => unfold ddot.
Hint Extern 1 (WFDG _ gdot) => unfold gdot.

(* Thesis change, we really need to know that kinding contexts are unique,
   so we're adding it here. Another option is to add it inside WFDG. *)
Inductive WFC : Delta -> Upsilon -> Gamma -> Prop :=
  | WFC_DUG : forall (d : Delta) (g: Gamma) (u : Upsilon),
                ok d ->
                WFDG d g ->
                LVPE.okp u ->
                WFC d u g.
Hint Constructors WFC.
Hint Extern 10 (WFC _ _ _) => try solve[constructor; auto].
Hint Extern 1  (WFC ddot _ _) => unfold ddot.
Hint Extern 1  (WFC _ udot _) => unfold udot.
Hint Extern 1  (WFC _ _ gdot) => unfold udot.

(* Automation for judgements with LN constructors. *)

Ltac fv_of_kinding_goal :=
  match goal with
    | |- K ?d (utype _ ?tau) _   => constr:((fv_delta d) \u  (T.fv tau))
    | |- K ?d (etype _ _ ?tau) _ => constr:((fv_delta d) \u  (T.fv tau))
    | |- ASGN ?d (utype _ ?tau)  => constr:((fv_delta d) \u  (T.fv tau))
    | |- ASGN ?d (etype _ _ ?tau)  => constr:((fv_delta d) \u  (T.fv tau))
    | |- ASGN ?d (etype _ _ ?tau)  => constr:((fv_delta d) \u  (T.fv tau))
  end.


Require Import ZArith.
Require Import String.
Require Export maps.

Set Implicit Arguments.
Inductive float : Set :=.

Inductive AExp : Set :=
   k_wrap_Bool_AExp : Bool -> AExp
 | Var : Id -> AExp
 | ACon : Int -> AExp
 | Add : AExp -> AExp -> AExp
 | Div : AExp -> AExp -> AExp
 | k_HOLE_AExp : AExp
with Array : Set :=
   (* 'const-array(_,_) *) k_label_zqconstzmarrayZLzuzxzuZR : Int ->
                                                              k ->
                                                              Array
 | (* 'store(_,_,_) *) k_label_zqstoreZLzuzxzuzxzuZR : Array ->
                                                       Int ->
                                                       k ->
                                                       Array
with BExp : Set :=
   BCon : Bool -> BExp
 | k_wrap_Int_BExp : Int -> BExp
 | Not : BExp -> BExp
 | And : BExp -> BExp -> BExp
 | Le : AExp -> AExp -> BExp
 | k_HOLE_BExp : BExp
with Bag : Set :=
with Block : Set :=
   BStmt : Stmt -> Block
 | BEmpty : Block
with Bool : Set :=
   k_wrap_zhBool_Bool : bool -> Bool
 | (* 'exists_._ *) k_label_zqexistszuzizu : k_sort_Set ->
                                             Bool ->
                                             Bool
 | (* 'forall_._ *) k_label_zqforallzuzizu : k_sort_Set ->
                                             Bool ->
                                             Bool
with Char : Set :=
with Float : Set :=
   k_wrap_zhFloat_Float : float -> Float
with Id : Set :=
   k_token_Id : string -> Id
with Int : Set :=
   k_wrap_zhInt_Int : Z -> Int
with kitem : Set :=
   k_wrap_zhBool_KItem : bool -> kitem
 | k_wrap_zhFloat_KItem : float -> kitem
 | k_wrap_zhInt_KItem : Z -> kitem
 | k_wrap_zhString_KItem : string -> kitem
 | k_wrap_AExp_KItem : AExp -> kitem
 | k_wrap_Array_KItem : Array -> kitem
 | k_wrap_BExp_KItem : BExp -> kitem
 | k_wrap_Bag_KItem : Bag -> kitem
 | k_wrap_Block_KItem : Block -> kitem
 | k_wrap_Bool_KItem : Bool -> kitem
 | k_wrap_Char_KItem : Char -> kitem
 | k_wrap_Float_KItem : Float -> kitem
 | k_wrap_Id_KItem : Id -> kitem
 | k_wrap_Ids_KItem : list Id -> kitem
 | k_wrap_Int_KItem : Int -> kitem
 | k_wrap_KLabel_KItem : KLabel -> kitem
 | k_wrap_KList_KItem : KList -> kitem
 | k_wrap_List_KItem : List -> kitem
 | k_wrap_MInt_KItem : MInt -> kitem
 | k_wrap_Map_KItem : Map k k -> kitem
 | k_wrap_Nat_KItem : Nat -> kitem
 | k_wrap_Pgm_KItem : Pgm -> kitem
 | k_wrap_Set_KItem : k_sort_Set -> kitem
 | k_wrap_Stmt_KItem : Stmt -> kitem
 | k_wrap_Stream_KItem : Stream -> kitem
 | k_wrap_String_KItem : String -> kitem
 | k_wrap_TCPAnswer_KItem : TCPAnswer -> kitem
 | k_wrap_TCPError_KItem : TCPError -> kitem
 | k_wrap_Variable_KItem : k_sort_Variable -> kitem
 | (* '#ioError(_) *) k_label_zqzhioErrorZLzuZR : String -> kitem
 | (* '#splitedBinder *) k_label_zqzhsplitedBinder : KList ->
                                                     KList ->
                                                     k_sort_Set ->
                                                     kitem
 | (* 'dummy *) k_label_zqdummy : KList -> kitem
 | (* 'freshVariables *) k_label_zqfreshVariables : k_sort_Set ->
                                                    k ->
                                                    kitem
 | (* 'isSymbolicK *) k_label_zqisSymbolicK : List -> kitem
 | (* 'select(_,_) *) k_label_zqselectZLzuzxzuZR : Array ->
                                                   Int ->
                                                   kitem
 | k_freeze : kitem -> kitem
with KLabel : Set :=
   (* '#freezer_ *) k_label_zqzhfreezzerzu : k -> KLabel
 | (* '#symEqualitySort *) k_label_zqzhsymEqualitySort : KLabel
 | (* '#token *) k_label_zqzhtoken : KLabel
 | (* 'cool *) k_label_zqcool : KLabel
 | (* 'heat *) k_label_zqheat : KLabel
 | (* 'heated *) k_label_zqheated : KLabel
 | (* 'isBinder *) k_label_zqisBinder : KLabel
 | (* 'redex *) k_label_zqredex : KLabel
with KList : Set :=
with KResult : Set :=
   k_wrap_Bool_KResult : Bool -> KResult
 | k_wrap_Int_KResult : Int -> KResult
with List : Set :=
with MInt : Set :=
   (* '$mi(_,_) *) k_label_zqzdmiZLzuzxzuZR : Int -> Int -> MInt
with Nat : Set :=
with Pgm : Set :=
   (* 'int_;_ *) k_label_zqintzuZSzu : list Id -> Stmt -> Pgm
with k_sort_Set : Set :=
with Stmt : Set :=
   k_wrap_Block_Stmt : Block -> Stmt
 | Assign : Id -> AExp -> Stmt
 | Seq : Stmt -> Stmt -> Stmt
 | If : BExp -> Block -> Block -> Stmt
 | While : BExp -> Block -> Stmt
with Stream : Set :=
   (* '#buffer *) k_label_zqzhbuffer : k -> Stream
 | (* '#istream *) k_label_zqzhistream : Int -> Stream
 | (* '#noIO *) k_label_zqzhnoIO : Stream
 | (* '#ostream *) k_label_zqzhostream : Int -> Stream
 | (* '#parseInput *) k_label_zqzhparseInput : String ->
                                               String ->
                                               Stream
with String : Set :=
   k_wrap_zhString_String : string -> String
with TCPAnswer : Set :=
   k_wrap_String_TCPAnswer : String -> TCPAnswer
 | k_wrap_TCPError_TCPAnswer : TCPError -> TCPAnswer
with TCPError : Set :=
   (* '#EACCES *) k_label_zqzhEACCES : TCPError
 | (* '#EBADF *) k_label_zqzhEBADF : TCPError
 | (* '#EINVAL *) k_label_zqzhEINVAL : TCPError
 | (* '#EISDIR *) k_label_zqzhEISDIR : TCPError
 | (* '#ELOOP *) k_label_zqzhELOOP : TCPError
 | (* '#ENAMETOOLONG *) k_label_zqzhENAMETOOLONG : TCPError
 | (* '#ENOENT *) k_label_zqzhENOENT : TCPError
 | (* '#ENOTDIR *) k_label_zqzhENOTDIR : TCPError
 | (* '#EOF *) k_label_zqzhEOF : TCPError
 | (* '#ESPIPE *) k_label_zqzhESPIPE : TCPError
 | (* '#noparse *) k_label_zqzhnoparse : TCPError
 | (* '#tcpError(_) *) k_label_zqzhtcpErrorZLzuZR : String ->
                                                    TCPError
with k_sort_Variable : Set :=
   k_wrap_Id_Variable : Id -> k_sort_Variable
with k : Set :=
   kdot : k
 | kra : kitem -> k -> k.

Definition k_inj_Variable_KItem (x : k_sort_Variable) : kitem :=
  match x with
  | k_wrap_Id_Variable i => k_wrap_Id_KItem i
  end.
Definition k_proj_Variable_KItem (x : kitem) : option k_sort_Variable :=
  match x with
  | k_wrap_Id_KItem i => Some (k_wrap_Id_Variable i)
  | k_wrap_Variable_KItem i => Some i
  | _ => None
  end.
Definition k_inj_Stmt_KItem (x : Stmt) : kitem :=
  match x with
  | k_wrap_Block_Stmt i => k_wrap_Block_KItem i
  | _ => k_wrap_Stmt_KItem x
  end.
Definition k_proj_Stmt_KItem (x : kitem) : option Stmt :=
  match x with
  | k_wrap_Stmt_KItem i => Some i
  | k_wrap_Block_KItem i => Some (k_wrap_Block_Stmt i)
  | _ => None
  end.
Definition k_inj_String_KItem (x : String) : kitem :=
  match x with
  | k_wrap_zhString_String i => k_wrap_zhString_KItem i
  end.
Definition k_proj_String_KItem (x : kitem) : option String :=
  match x with
  | k_wrap_zhString_KItem i => Some (k_wrap_zhString_String i)
  | k_wrap_String_KItem i => Some i
  | _ => None
  end.
Definition k_inj_TCPAnswer_KItem (x : TCPAnswer) : kitem :=
  match x with
  | k_wrap_String_TCPAnswer i => k_inj_String_KItem i
  | k_wrap_TCPError_TCPAnswer i => k_wrap_TCPError_KItem i
  end.
Definition k_proj_TCPAnswer_KItem (x : kitem) : option TCPAnswer :=
  match x with
  | k_wrap_String_KItem i => Some (k_wrap_String_TCPAnswer i)
  | k_wrap_TCPError_KItem i => Some (k_wrap_TCPError_TCPAnswer i)
  | k_wrap_zhString_KItem i => Some (k_wrap_String_TCPAnswer (k_wrap_zhString_String i))
  | k_wrap_TCPAnswer_KItem i => Some i
  | _ => None
  end.
Definition k_inj_Int_KItem (x : Int) : kitem :=
  match x with
  | k_wrap_zhInt_Int i => k_wrap_zhInt_KItem i
  end.
Definition k_proj_Int_KItem (x : kitem) : option Int :=
  match x with
  | k_wrap_zhInt_KItem i => Some (k_wrap_zhInt_Int i)
  | k_wrap_Int_KItem i => Some i
  | _ => None
  end.
Definition k_inj_Float_KItem (x : Float) : kitem :=
  match x with
  | k_wrap_zhFloat_Float i => k_wrap_zhFloat_KItem i
  end.
Definition k_proj_Float_KItem (x : kitem) : option Float :=
  match x with
  | k_wrap_zhFloat_KItem i => Some (k_wrap_zhFloat_Float i)
  | k_wrap_Float_KItem i => Some i
  | _ => None
  end.
Definition k_inj_Bool_KItem (x : Bool) : kitem :=
  match x with
  | k_wrap_zhBool_Bool i => k_wrap_zhBool_KItem i
  | _ => k_wrap_Bool_KItem x
  end.
Definition k_proj_Bool_KItem (x : kitem) : option Bool :=
  match x with
  | k_wrap_Bool_KItem i => Some i
  | k_wrap_zhBool_KItem i => Some (k_wrap_zhBool_Bool i)
  | _ => None
  end.
Definition k_inj_KResult_KItem (x : KResult) : kitem :=
  match x with
  | k_wrap_Bool_KResult i => k_inj_Bool_KItem i
  | k_wrap_Int_KResult i => k_inj_Int_KItem i
  end.
Definition k_proj_KResult_KItem (x : kitem) : option KResult :=
  match x with
  | k_wrap_Bool_KItem i => Some (k_wrap_Bool_KResult i)
  | k_wrap_Int_KItem i => Some (k_wrap_Int_KResult i)
  | k_wrap_zhBool_KItem i => Some (k_wrap_Bool_KResult (k_wrap_zhBool_Bool i))
  | k_wrap_zhInt_KItem i => Some (k_wrap_Int_KResult (k_wrap_zhInt_Int i))
  | _ => None
  end.
Definition k_inj_KResult_AExp (x : KResult) : AExp :=
  match x with
  | k_wrap_Bool_KResult i => k_wrap_Bool_AExp i
  | k_wrap_Int_KResult i => ACon i
  end.
Definition k_proj_KResult_AExp (x : AExp) : option KResult :=
  match x with
  | k_wrap_Bool_AExp i => Some (k_wrap_Bool_KResult i)
  | ACon i => Some (k_wrap_Int_KResult i)
  | _ => None
  end.
Definition k_inj_KResult_BExp (x : KResult) : BExp :=
  match x with
  | k_wrap_Bool_KResult i => BCon i
  | k_wrap_Int_KResult i => k_wrap_Int_BExp i
  end.
Definition k_proj_KResult_BExp (x : BExp) : option KResult :=
  match x with
  | BCon i => Some (k_wrap_Bool_KResult i)
  | k_wrap_Int_BExp i => Some (k_wrap_Int_KResult i)
  | _ => None
  end.
Definition k_inj_BExp_KItem (x : BExp) : kitem :=
  match x with
  | BCon i => k_inj_Bool_KItem i
  | k_wrap_Int_BExp i => k_inj_Int_KItem i
  | _ => k_wrap_BExp_KItem x
  end.
Definition k_proj_BExp_KItem (x : kitem) : option BExp :=
  match x with
  | k_wrap_BExp_KItem i => Some i
  | k_wrap_zhBool_KItem i => Some (BCon (k_wrap_zhBool_Bool i))
  | k_wrap_zhInt_KItem i => Some (k_wrap_Int_BExp (k_wrap_zhInt_Int i))
  | k_wrap_Bool_KItem i => Some (BCon i)
  | k_wrap_Int_KItem i => Some (k_wrap_Int_BExp i)
  | _ => None
  end.
Definition k_inj_AExp_KItem (x : AExp) : kitem :=
  match x with
  | k_wrap_Bool_AExp i => k_inj_Bool_KItem i
  | Var i => k_wrap_Id_KItem i
  | ACon i => k_inj_Int_KItem i
  | _ => k_wrap_AExp_KItem x
  end.
Definition k_proj_AExp_KItem (x : kitem) : option AExp :=
  match x with
  | k_wrap_AExp_KItem i => Some i
  | k_wrap_zhBool_KItem i => Some (k_wrap_Bool_AExp (k_wrap_zhBool_Bool i))
  | k_wrap_zhInt_KItem i => Some (ACon (k_wrap_zhInt_Int i))
  | k_wrap_Bool_KItem i => Some (k_wrap_Bool_AExp i)
  | k_wrap_Id_KItem i => Some (Var i)
  | k_wrap_Int_KItem i => Some (ACon i)
  | _ => None
  end.


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

(* $Id: FMapList.v 12458 2009-11-02 18:50:33Z letouzey $ *)

(** * Finite map library *)

(** This file proposes an implementation of the non-dependant interface
 [FMapInterface.S] using lists of pairs ordered (increasing) with respect to
 left projection. *)

Require Import FMapInterface.

Set Implicit Arguments.
Unset Strict Implicit.

Module Raw (X:OrderedType).

Module Import MX := OrderedTypeFacts X.
Module Import PX := KeyOrderedType X.

Definition key := X.t.
Definition t (elt:Type) := list (X.t * elt).

Section Elt.
Variable elt : Type.

Notation eqk := (eqk (elt:=elt)).
Notation eqke := (eqke (elt:=elt)).
Notation ltk := (ltk (elt:=elt)).
Notation MapsTo := (MapsTo (elt:=elt)).
Notation In := (In (elt:=elt)).
Notation Sort := (sort ltk).
Notation Inf := (lelistA (ltk)).

(** * [empty] *)

Definition empty : t elt := nil.

Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.

Lemma empty_1 : Empty empty.
Proof.
 unfold Empty,empty.
 intros a e.
 intro abs.
 inversion abs.
Qed.
Hint Resolve empty_1.

Lemma empty_sorted : Sort empty.
Proof.
 unfold empty; auto.
Qed.

(** * [is_empty] *)

Definition is_empty (l : t elt) : bool := if l then true else false.

Lemma is_empty_1 :forall m, Empty m -> is_empty m = true.
Proof.
 unfold Empty, PX.MapsTo.
 intros m.
 case m;auto.
 intros (k,e) l inlist.
 absurd (InA eqke (k, e) ((k, e) :: l));auto.
Qed.

Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
Proof.
 intros m.
 case m;auto.
 intros p l abs.
 inversion abs.
Qed.

(** * [mem] *)

Function mem (k : key) (s : t elt) {struct s} : bool :=
 match s with
  | nil => false
  | (k',_) :: l =>
     match X.compare k k' with
      | LT _ => false
      | EQ _ => true
      | GT _ => mem k l
     end
 end.

Lemma mem_1 : forall m (Hm:Sort m) x, In x m -> mem x m = true.
Proof.
 intros m Hm x; generalize Hm; clear Hm.
 functional induction (mem x m);intros sorted belong1;trivial.

 inversion belong1. inversion H.

 absurd (In x ((k', _x) :: l));try assumption.
 apply Sort_Inf_NotIn with _x;auto.

 apply IHb.
 elim (sort_inv sorted);auto.
 elim (In_inv belong1);auto.
 intro abs.
 absurd (X.eq x k');auto.
Qed.

Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m.
Proof.
 intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo.
 functional induction (mem x m); intros sorted hyp;try ((inversion hyp);fail).
 exists _x; auto.
 induction IHb; auto.
 exists x0; auto.
 inversion_clear sorted; auto.
Qed.

(** * [find] *)

Function find (k:key) (s: t elt) {struct s} : option elt :=
 match s with
  | nil => None
  | (k',x)::s' =>
     match X.compare k k' with
      | LT _ => None
      | EQ _ => Some x
      | GT _ => find k s'
     end
 end.

Lemma find_2 :  forall m x e, find x m = Some e -> MapsTo x e m.
Proof.
 intros m x. unfold PX.MapsTo.
 functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto.
Qed.

Lemma find_1 :  forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e.
Proof.
 intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo.
 functional induction (find x m);simpl; subst; try clear H_eq_1.

 inversion 2.

 inversion_clear 2.
 clear e1;compute in H0; destruct H0;order.
 clear e1;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.

 clear e1;inversion_clear 2.
 compute in H0; destruct H0; intuition congruence.
 generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.

 clear e1; do 2 inversion_clear 1; auto.
 compute in H2; destruct H2; order.
Qed.

(** * [add] *)

Function add (k : key) (x : elt) (s : t elt) {struct s} : t elt :=
 match s with
  | nil => (k,x) :: nil
  | (k',y) :: l =>
     match X.compare k k' with
      | LT _ => (k,x)::s
      | EQ _ => (k,x)::l
      | GT _ => (k',y) :: add k x l
     end
 end.

Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m).
Proof.
 intros m x y e; generalize y; clear y.
 unfold PX.MapsTo.
 functional induction (add x e m);simpl;auto.
Qed.

Lemma add_2 : forall m x y e e',
  ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
Proof.
 intros m x  y e e'.
 generalize y e; clear y e; unfold PX.MapsTo.
 functional induction (add x e' m) ;simpl;auto;  clear e0.
 subst;auto.

 intros y' e'' eqky';  inversion_clear 1;  destruct H0; simpl in *.
 order.
 auto.
 auto.
 intros y' e'' eqky'; inversion_clear 1; intuition.
Qed.

Lemma add_3 : forall m x y e e',
  ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
Proof.
 intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo.
 functional induction (add x e' m);simpl; intros.
 apply (In_inv_3 H0); compute; auto.
 apply (In_inv_3 H0); compute; auto.
 constructor 2; apply (In_inv_3 H0); compute; auto.
 inversion_clear H0; auto.
Qed.

Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt),
  Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m).
Proof.
 induction m.
 simpl; intuition.
 intros.
 destruct a as (x'',e'').
 inversion_clear H.
 compute in H0,H1.
 simpl; case (X.compare x x''); intuition.
Qed.
Hint Resolve add_Inf.

Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m).
Proof.
 induction m.
 simpl; intuition.
 intros.
 destruct a as (x',e').
 simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto.
 constructor; auto.
 apply Inf_eq with (x',e'); auto.
Qed.

(** * [remove] *)

Function remove (k : key) (s : t elt) {struct s} : t elt :=
 match s with
  | nil => nil
  | (k',x) :: l =>
     match X.compare k k' with
      | LT _ => s
      | EQ _ => l
      | GT _ => (k',x) :: remove k l
     end
 end.

Lemma remove_1 : forall m (Hm:Sort m) x y, X.eq x y -> ~ In y (remove x m).
Proof.
 intros m Hm x y; generalize Hm; clear Hm.
 functional induction (remove x m);simpl;intros;subst.

 red; inversion 1; inversion H1.

 apply Sort_Inf_NotIn with x0; auto.
 clear e0;constructor; compute; order.

 clear e0;inversion_clear Hm.
 apply Sort_Inf_NotIn with x0; auto.
 apply Inf_eq with (k',x0);auto; compute; apply X.eq_trans with x; auto.

 clear e0;inversion_clear Hm.
 assert (notin:~ In y (remove x l)) by auto.
 intros (x1,abs).
 inversion_clear abs.
 compute in H2; destruct H2; order.
 apply notin; exists x1; auto.
Qed.

Lemma remove_2 : forall m (Hm:Sort m) x y e,
  ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
Proof.
 intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
 functional induction (remove x m);subst;auto;
   match goal with
     | [H: X.compare _ _ = _ |- _ ] => clear H
     | _ => idtac
   end.

 inversion_clear 3; auto.
 compute in H1; destruct H1; order.

 inversion_clear 1; inversion_clear 2; auto.
Qed.

Lemma remove_3 : forall m (Hm:Sort m) x y e,
  MapsTo y e (remove x m) -> MapsTo y e m.
Proof.
 intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
 functional induction (remove x m);subst;auto.
 inversion_clear 1; inversion_clear 1; auto.
Qed.

Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt),
  Inf (x',e') m -> Inf (x',e') (remove x m).
Proof.
 induction m.
 simpl; intuition.
 intros.
 destruct a as (x'',e'').
 inversion_clear H.
 compute in H0.
 simpl; case (X.compare x x''); intuition.
 inversion_clear Hm.
 apply Inf_lt with (x'',e''); auto.
Qed.
Hint Resolve remove_Inf.

Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m).
Proof.
 induction m.
 simpl; intuition.
 intros.
 destruct a as (x',e').
 simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto.
Qed.

(** * [elements] *)

Definition elements (m: t elt) := m.

Lemma elements_1 : forall m x e,
  MapsTo x e m -> InA eqke (x,e) (elements m).
Proof.
 auto.
Qed.

Lemma elements_2 : forall m x e,
  InA eqke (x,e) (elements m) -> MapsTo x e m.
Proof.
 auto.
Qed.

Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m).
Proof.
 auto.
Qed.

Lemma elements_3w : forall m (Hm:Sort m), NoDupA eqk (elements m).
Proof.
 intros.
 apply Sort_NoDupA.
 apply elements_3; auto.
Qed.

(** * [fold] *)

Function fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) {struct m} :  A :=
  match m with
   | nil => acc
   | (k,e)::m' => fold f m' (f k e acc)
  end.

Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A),
  fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
Proof.
 intros; functional induction (fold f m i); auto.
Qed.

(** * [equal] *)

Function equal (cmp:elt->elt->bool)(m m' : t elt) {struct m} : bool :=
  match m, m' with
   | nil, nil => true
   | (x,e)::l, (x',e')::l' =>
      match X.compare x x' with
       | EQ _ => cmp e e' && equal cmp l l'
       | _    => false
      end
   | _, _ => false
  end.

Definition Equivb cmp m m' :=
  (forall k, In k m <-> In k m') /\
  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).

Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp,
  Equivb cmp m m' -> equal cmp m m' = true.
Proof.
 intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
 functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb;
 intuition; subst.
 match goal with H: X.compare _ _ = _ |- _ => clear H end.
 assert (cmp_e_e':cmp e e' = true).
  apply H1 with x; auto.
 rewrite cmp_e_e'; simpl.
 apply IHb; auto.
 inversion_clear Hm; auto.
 inversion_clear Hm'; auto.
 unfold Equivb; intuition.
 destruct (H0 k).
 assert (In k ((x,e) ::l)).
  destruct H as (e'', hyp); exists e''; auto.
 destruct (In_inv (H2 H4)); auto.
 inversion_clear Hm.
 elim (Sort_Inf_NotIn H6 H7).
 destruct H as (e'', hyp); exists e''; auto.
 apply MapsTo_eq with k; auto; order.
 destruct (H0 k).
 assert (In k ((x',e') ::l')).
  destruct H as (e'', hyp); exists e''; auto.
 destruct (In_inv (H3 H4)); auto.
 inversion_clear Hm'.
 elim (Sort_Inf_NotIn H6 H7).
 destruct H as (e'', hyp); exists e''; auto.
 apply MapsTo_eq with k; auto; order.
 apply H1 with k; destruct (X.eq_dec x k); auto.

 destruct (X.compare x x'); try contradiction; clear y.
 destruct (H0 x).
 assert (In x ((x',e')::l')).
  apply H; auto.
  exists e; auto.
 destruct (In_inv H3).
 order.
 inversion_clear Hm'.
 assert (Inf (x,e) l').
 apply Inf_lt with (x',e'); auto.
 elim (Sort_Inf_NotIn H5 H7 H4).

 destruct (H0 x').
 assert (In x' ((x,e)::l)).
  apply H2; auto.
  exists e'; auto.
 destruct (In_inv H3).
 order.
 inversion_clear Hm.
 assert (Inf (x',e') l).
  apply Inf_lt with (x,e); auto.
 elim (Sort_Inf_NotIn H5 H7 H4).

 destruct m;
 destruct m';try contradiction.

 clear H1;destruct p as (k,e).
 destruct (H0 k).
 destruct H1.
 exists e; auto.
 inversion H1.

 destruct p as (x,e).
 destruct (H0 x).
 destruct H.
 exists e; auto.
 inversion H.

 destruct p;destruct p0;contradiction.
Qed.

Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp,
  equal cmp m m' = true -> Equivb cmp m m'.
Proof.
 intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
 functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb;
  intuition; try discriminate; subst;
  try match goal with H: X.compare _ _ = _ |- _ => clear H end.

 inversion H0.

 inversion_clear Hm;inversion_clear Hm'.
 destruct (andb_prop _ _ H); clear H.
 destruct (IHb H1 H3 H6).
 destruct (In_inv H0).
 exists e'; constructor; split; trivial; apply X.eq_trans with x; auto.
 destruct (H k).
 destruct (H9 H8) as (e'',hyp).
 exists e''; auto.

 inversion_clear Hm;inversion_clear Hm'.
 destruct (andb_prop _ _ H); clear H.
 destruct (IHb H1 H3 H6).
 destruct (In_inv H0).
 exists e; constructor; split; trivial; apply X.eq_trans with x'; auto.
 destruct (H k).
 destruct (H10 H8) as (e'',hyp).
 exists e''; auto.

 inversion_clear Hm;inversion_clear Hm'.
 destruct (andb_prop _ _ H); clear H.
 destruct (IHb H2 H4 H7).
 inversion_clear H0.
 destruct H9; simpl in *; subst.
 inversion_clear H1.
 destruct H9; simpl in *; subst; auto.
 elim (Sort_Inf_NotIn H4 H5).
 exists e'0; apply MapsTo_eq with k; auto; order.
 inversion_clear H1.
 destruct H0; simpl in *; subst; auto.
 elim (Sort_Inf_NotIn H2 H3).
 exists e0; apply MapsTo_eq with k; auto; order.
 apply H8 with k; auto.
Qed.

(** This lemma isn't part of the spec of [Equivb], but is used in [FMapAVL] *)

Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) ->
  eqk x y -> cmp (snd x) (snd y) = true ->
  (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)).
Proof.
 intros.
 inversion H; subst.
 inversion H0; subst.
 destruct x; destruct y; compute in H1, H2.
 split; intros.
 apply equal_2; auto.
 simpl.
 elim_comp.
 rewrite H2; simpl.
 apply equal_1; auto.
 apply equal_2; auto.
 generalize (equal_1 H H0 H3).
 simpl.
 elim_comp.
 rewrite H2; simpl; auto.
Qed.

Variable elt':Type.

(** * [map] and [mapi] *)

Fixpoint map (f:elt -> elt') (m:t elt) : t elt' :=
  match m with
   | nil => nil
   | (k,e)::m' => (k,f e) :: map f m'
  end.

Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' :=
  match m with
   | nil => nil
   | (k,e)::m' => (k,f k e) :: mapi f m'
  end.

End Elt.
Section Elt2.
(* A new section is necessary for previous definitions to work
   with different [elt], especially [MapsTo]... *)

Variable elt elt' : Type.

(** Specification of [map] *)

Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'),
  MapsTo x e m -> MapsTo x (f e) (map f m).
Proof.
 intros m x e f.
 (* functional induction map elt elt' f m.  *) (* Marche pas ??? *)
 induction m.
 inversion 1.

 destruct a as (x',e').
 simpl.
 inversion_clear 1.
 constructor 1.
 unfold eqke in *; simpl in *; intuition congruence.
 constructor 2.
 unfold MapsTo in *; auto.
Qed.

Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'),
  In x (map f m) -> In x m.
Proof.
 intros m x f.
 (* functional induction map elt elt' f m. *) (* Marche pas ??? *)
 induction m; simpl.
 intros (e,abs).
 inversion abs.

 destruct a as (x',e).
 intros hyp.
 inversion hyp. clear hyp.
 inversion H; subst; rename x0 into e'.
 exists e; constructor.
 unfold eqke in *; simpl in *; intuition.
 destruct IHm as (e'',hyp).
 exists e'; auto.
 exists e''.
 constructor 2; auto.
Qed.

Lemma map_lelistA : forall (m: t elt)(x:key)(e:elt)(e':elt')(f:elt->elt'),
  lelistA (@ltk elt) (x,e) m ->
  lelistA (@ltk elt') (x,e') (map f m).
Proof.
 induction m; simpl; auto.
 intros.
 destruct a as (x0,e0).
 inversion_clear H; auto.
Qed.

Hint Resolve map_lelistA.

Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'),
  sort (@ltk elt') (map f m).
Proof.
 induction m; simpl; auto.
 intros.
 destruct a as (x',e').
 inversion_clear Hm.
 constructor; auto.
 exact (map_lelistA _ _ H0).
Qed.

(** Specification of [mapi] *)

Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'),
  MapsTo x e m ->
  exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m).
Proof.
 intros m x e f.
 (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
 induction m.
 inversion 1.

 destruct a as (x',e').
 simpl.
 inversion_clear 1.
 exists x'.
 destruct H0; simpl in *.
 split; auto.
 constructor 1.
 unfold eqke in *; simpl in *; intuition congruence.
 destruct IHm as (y, hyp); auto.
 exists y; intuition.
Qed.

Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'),
  In x (mapi f m) -> In x m.
Proof.
 intros m x f.
 (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
 induction m; simpl.
 intros (e,abs).
 inversion abs.

 destruct a as (x',e).
 intros hyp.
 inversion hyp. clear hyp.
 inversion H; subst; rename x0 into e'.
 exists e; constructor.
 unfold eqke in *; simpl in *; intuition.
 destruct IHm as (e'',hyp).
 exists e'; auto.
 exists e''.
 constructor 2; auto.
Qed.

Lemma mapi_lelistA : forall (m: t elt)(x:key)(e:elt)(f:key->elt->elt'),
  lelistA (@ltk elt) (x,e) m ->
  lelistA (@ltk elt') (x,f x e) (mapi f m).
Proof.
 induction m; simpl; auto.
 intros.
 destruct a as (x',e').
 inversion_clear H; auto.
Qed.

Hint Resolve mapi_lelistA.

Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'),
  sort (@ltk elt') (mapi f m).
Proof.
 induction m; simpl; auto.
 intros.
 destruct a as (x',e').
 inversion_clear Hm; auto.
Qed.

End Elt2.
Section Elt3.

(** * [map2] *)

Variable elt elt' elt'' : Type.
Variable f : option elt -> option elt' -> option elt''.

Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) :=
  match o with
   | Some e => (k,e)::l
   | None => l
  end.

Fixpoint map2_l (m : t elt) : t elt'' :=
  match m with
   | nil => nil
   | (k,e)::l => option_cons k (f (Some e) None) (map2_l l)
  end.

Fixpoint map2_r (m' : t elt') : t elt'' :=
  match m' with
   | nil => nil
   | (k,e')::l' => option_cons k (f None (Some e')) (map2_r l')
  end.

Fixpoint map2 (m : t elt) : t elt' -> t elt'' :=
  match m with
   | nil => map2_r
   | (k,e) :: l =>
      fix map2_aux (m' : t elt') : t elt'' :=
        match m' with
         | nil => map2_l m
         | (k',e') :: l' =>
            match X.compare k k' with
             | LT _ => option_cons k (f (Some e) None) (map2 l m')
             | EQ _ => option_cons k (f (Some e) (Some e')) (map2 l l')
             | GT _ => option_cons k' (f None (Some e')) (map2_aux l')
            end
        end
  end.

Notation oee' := (option elt * option elt')%type.

Fixpoint combine (m : t elt) : t elt' -> t oee' :=
  match m with
   | nil => map (fun e' => (None,Some e'))
   | (k,e) :: l =>
      fix combine_aux (m':t elt') : list (key * oee') :=
        match m' with
         | nil => map (fun e => (Some e,None)) m
         | (k',e') :: l' =>
            match X.compare k k' with
             | LT _ => (k,(Some e, None))::combine l m'
             | EQ _ => (k,(Some e, Some e'))::combine l l'
             | GT _ => (k',(None,Some e'))::combine_aux l'
            end
        end
  end.

Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) :=
  List.fold_right (fun p => f (fst p) (snd p)) i l.

Definition map2_alt m m' :=
  let m0 : t oee' := combine m m' in
  let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in
  fold_right_pair (option_cons (A:=elt'')) m1 nil.

Lemma map2_alt_equiv : forall m m', map2_alt m m' = map2 m m'.
Proof.
 unfold map2_alt.
 induction m.
 simpl; auto; intros.
 (* map2_r *)
 induction m'; try destruct a; simpl; auto.
 rewrite IHm'; auto.
 (* fin map2_r *)
 induction m'; destruct a.
 simpl; f_equal.
 (* map2_l *)
 clear IHm.
 induction m; try destruct a; simpl; auto.
 rewrite IHm; auto.
 (* fin map2_l *)
 destruct a0.
 simpl.
 destruct (X.compare t0 t1); simpl; f_equal.
 apply IHm.
 apply IHm.
 apply IHm'.
Qed.

Lemma combine_lelistA :
  forall m m' (x:key)(e:elt)(e':elt')(e'':oee'),
  lelistA (@ltk elt) (x,e) m ->
  lelistA (@ltk elt') (x,e') m' ->
  lelistA (@ltk oee') (x,e'') (combine m m').
Proof.
 induction m.
 intros.
 simpl.
 exact (map_lelistA _ _ H0).
 induction m'.
 intros.
 destruct a.
 replace (combine ((t0, e0) :: m) nil) with
             (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto.
 exact (map_lelistA _ _ H).
 intros.
 simpl.
 destruct a as (k,e0); destruct a0 as (k',e0').
 destruct (X.compare k k').
 inversion_clear H; auto.
 inversion_clear H; auto.
 inversion_clear H0; auto.
Qed.
Hint Resolve combine_lelistA.

Lemma combine_sorted :
  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'),
  sort (@ltk oee') (combine m m').
Proof.
 induction m.
 intros; clear Hm.
 simpl.
 apply map_sorted; auto.
 induction m'.
 intros; clear Hm'.
 destruct a.
 replace (combine ((t0, e) :: m) nil) with
             (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto.
 apply map_sorted; auto.
 intros.
 simpl.
 destruct a as (k,e); destruct a0 as (k',e').
 destruct (X.compare k k').
 inversion_clear Hm.
 constructor; auto.
 assert (lelistA (ltk (elt:=elt')) (k, e') ((k',e')::m')) by auto.
 exact (combine_lelistA _ H0 H1).
 inversion_clear Hm; inversion_clear Hm'.
 constructor; auto.
 assert (lelistA (ltk (elt:=elt')) (k, e') m') by (apply Inf_eq with (k',e'); auto).
 exact (combine_lelistA _ H0 H3).
 inversion_clear Hm; inversion_clear Hm'.
 constructor; auto.
 change (lelistA (ltk (elt:=oee')) (k', (None, Some e'))
                 (combine ((k,e)::m) m')).
 assert (lelistA (ltk (elt:=elt)) (k', e) ((k,e)::m)) by auto.
 exact (combine_lelistA _  H3 H2).
Qed.

Lemma map2_sorted :
  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'),
  sort (@ltk elt'') (map2 m m').
Proof.
 intros.
 rewrite <- map2_alt_equiv.
 unfold map2_alt.
 assert (H0:=combine_sorted Hm Hm').
 set (l0:=combine m m') in *; clearbody l0.
 set (f':= fun p : oee' => f (fst p) (snd p)).
 assert (H1:=map_sorted (elt' := option elt'') H0 f').
 set (l1:=map f' l0) in *; clearbody l1.
 clear f' f H0 l0 Hm Hm' m m'.
 induction l1.
 simpl; auto.
 inversion_clear H1.
 destruct a; destruct o; auto.
 simpl.
 constructor; auto.
 clear IHl1.
 induction l1.
 simpl; auto.
 destruct a; destruct o; simpl; auto.
 inversion_clear H0; auto.
 inversion_clear H0.
 red in H1; simpl in H1.
 inversion_clear H.
 apply IHl1; auto.
 apply Inf_lt with (t1, None (A:=elt'')); auto.
Qed.

Definition at_least_one (o:option elt)(o':option elt') :=
  match o, o' with
   | None, None => None
   | _, _  => Some (o,o')
  end.

Lemma combine_1 :
  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key),
  find x (combine m m') = at_least_one (find x m) (find x m').
Proof.
 induction m.
 intros.
 simpl.
 induction m'.
 intros; simpl; auto.
 simpl; destruct a.
 simpl; destruct (X.compare x t0); simpl; auto.
 inversion_clear Hm'; auto.
 induction m'.
 (* m' = nil *)
 intros; destruct a; simpl.
 destruct (X.compare x t0); simpl; auto.
 inversion_clear Hm; clear H0 l Hm' IHm t0.
 induction m; simpl; auto.
 inversion_clear H.
 destruct a.
 simpl; destruct (X.compare x t0); simpl; auto.
 (* m' <> nil *)
 intros.
 destruct a as (k,e); destruct a0 as (k',e'); simpl.
 inversion Hm; inversion Hm'; subst.
 destruct (X.compare k k'); simpl;
  destruct (X.compare x k);
   elim_comp || destruct (X.compare x k'); simpl; auto.
 rewrite IHm; auto; simpl; elim_comp; auto.
 rewrite IHm; auto; simpl; elim_comp; auto.
 rewrite IHm; auto; simpl; elim_comp; auto.
 change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')).
 rewrite IHm'; auto.
 simpl find; elim_comp; auto.
 change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')).
 rewrite IHm'; auto.
 simpl find; elim_comp; auto.
 change (find x (combine ((k, e) :: m) m') =
         at_least_one (find x m) (find x m')).
 rewrite IHm'; auto.
 simpl find; elim_comp; auto.
Qed.

Definition at_least_one_then_f (o:option elt)(o':option elt') :=
  match o, o' with
   | None, None => None
   | _, _  => f o o'
  end.

Lemma map2_0 :
  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key),
  find x (map2 m m') = at_least_one_then_f (find x m) (find x m').
Proof.
 intros.
 rewrite <- map2_alt_equiv.
 unfold map2_alt.
 assert (H:=combine_1 Hm Hm' x).
 assert (H2:=combine_sorted Hm Hm').
 set (f':= fun p : oee' => f (fst p) (snd p)).
 set (m0 := combine m m') in *; clearbody m0.
 set (o:=find x m) in *; clearbody o.
 set (o':=find x m') in *; clearbody o'.
 clear Hm Hm' m m'.
 generalize H; clear H.
 match goal with |- ?m=?n -> ?p=?q =>
   assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end.
 induction m0; simpl in *; intuition.
 destruct o; destruct o'; simpl in *; try discriminate; auto.
 destruct a as (k,(oo,oo')); simpl in *.
 inversion_clear H2.
 destruct (X.compare x k); simpl in *.
 (* x < k *)
 destruct (f' (oo,oo')); simpl.
 elim_comp.
 destruct o; destruct o'; simpl in *; try discriminate; auto.
 destruct (IHm0 H0) as (H2,_); apply H2; auto.
 rewrite <- H.
 case_eq (find x m0); intros; auto.
 assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
  red; auto.
 destruct (Sort_Inf_NotIn H0 (Inf_lt H4 H1)).
 exists p; apply find_2; auto.
 (* x = k *)
 assert (at_least_one_then_f o o' = f oo oo').
  destruct o; destruct o'; simpl in *; inversion_clear H; auto.
 rewrite H2.
 unfold f'; simpl.
 destruct (f oo oo'); simpl.
 elim_comp; auto.
 destruct (IHm0 H0) as (_,H4); apply H4; auto.
 case_eq (find x m0); intros; auto.
 assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))).
  red; auto.
 destruct (Sort_Inf_NotIn H0 (Inf_eq (eqk_sym H5) H1)).
 exists p; apply find_2; auto.
 (* k < x *)
 unfold f'; simpl.
 destruct (f oo oo'); simpl.
 elim_comp; auto.
 destruct (IHm0 H0) as (H3,_); apply H3; auto.
 destruct (IHm0 H0) as (H3,_); apply H3; auto.

 (* None -> None *)
 destruct a as (k,(oo,oo')).
 simpl.
 inversion_clear H2.
 destruct (X.compare x k).
 (* x < k *)
 unfold f'; simpl.
 destruct (f oo oo'); simpl.
 elim_comp; auto.
 destruct (IHm0 H0) as (_,H4); apply H4; auto.
 case_eq (find x m0); intros; auto.
 assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
  red; auto.
 destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)).
 exists p; apply find_2; auto.
 (* x = k *)
 discriminate.
 (* k < x *)
 unfold f'; simpl.
 destruct (f oo oo'); simpl.
 elim_comp; auto.
 destruct (IHm0 H0) as (_,H4); apply H4; auto.
 destruct (IHm0 H0) as (_,H4); apply H4; auto.
Qed.

(** Specification of [map2] *)

Lemma map2_1 :
  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key),
  In x m \/ In x m' ->
  find x (map2 m m') = f (find x m) (find x m').
Proof.
 intros.
 rewrite map2_0; auto.
 destruct H as [(e,H)|(e,H)].
 rewrite (find_1 Hm H).
 destruct (find x m'); simpl; auto.
 rewrite (find_1 Hm' H).
 destruct (find x m); simpl; auto.
Qed.

Lemma map2_2 :
  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key),
  In x (map2 m m') -> In x m \/ In x m'.
Proof.
 intros.
 destruct H as (e,H).
 generalize (map2_0 Hm Hm' x).
 rewrite (find_1 (map2_sorted Hm Hm') H).
 generalize (@find_2 _ m x).
 generalize (@find_2 _ m' x).
 destruct (find x m);
   destruct (find x m'); simpl; intros.
 left; exists e0; auto.
 left; exists e0; auto.
 right; exists e0; auto.
 discriminate.
Qed.

End Elt3.
End Raw.

Module Make (X: OrderedType) <: S with Module E := X.
Module Raw := Raw X.
Module E := X.

Definition key := E.t.

Record slist (elt:Type) :=
  {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}.
Definition t (elt:Type) : Type := slist elt.

Section Elt.
 Variable elt elt' elt'':Type.

 Implicit Types m : t elt.
 Implicit Types x y : key.
 Implicit Types e : elt.

 Definition empty : t elt := Build_slist (Raw.empty_sorted elt).
 Definition is_empty m : bool := Raw.is_empty m.(this).
 Definition add x e m : t elt := Build_slist (Raw.add_sorted m.(sorted) x e).
 Definition find x m : option elt := Raw.find x m.(this).
 Definition remove x m : t elt := Build_slist (Raw.remove_sorted m.(sorted) x).
 Definition mem x m : bool := Raw.mem x m.(this).
 Definition map f m : t elt' := Build_slist (Raw.map_sorted m.(sorted) f).
 Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_sorted m.(sorted) f).
 Definition map2 f m (m':t elt') : t elt'' :=
   Build_slist (Raw.map2_sorted f m.(sorted) m'.(sorted)).
 Definition elements m : list (key*elt) := @Raw.elements elt m.(this).
 Definition cardinal m := length m.(this).
 Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f m.(this) i.
 Definition equal cmp m m' : bool := @Raw.equal elt cmp m.(this) m'.(this).

 Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this).
 Definition In x m : Prop := Raw.PX.In x m.(this).
 Definition Empty m : Prop := Raw.Empty m.(this).

 Definition Equal m m' := forall y, find y m = find y m'.
 Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
         (forall k, In k m <-> In k m') /\
         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
 Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this).

 Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt.
 Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt.
 Definition lt_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.ltk elt.

 Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m.
 Proof. intros m; exact (@Raw.PX.MapsTo_eq elt m.(this)). Qed.

 Lemma mem_1 : forall m x, In x m -> mem x m = true.
 Proof. intros m; exact (@Raw.mem_1 elt m.(this) m.(sorted)). Qed.
 Lemma mem_2 : forall m x, mem x m = true -> In x m.
 Proof. intros m; exact (@Raw.mem_2 elt m.(this) m.(sorted)). Qed.

 Lemma empty_1 : Empty empty.
 Proof. exact (@Raw.empty_1 elt). Qed.

 Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
 Proof. intros m; exact (@Raw.is_empty_1 elt m.(this)). Qed.
 Lemma is_empty_2 :  forall m, is_empty m = true -> Empty m.
 Proof. intros m; exact (@Raw.is_empty_2 elt m.(this)). Qed.

 Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m).
 Proof. intros m; exact (@Raw.add_1 elt m.(this)). Qed.
 Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
 Proof. intros m; exact (@Raw.add_2 elt m.(this)). Qed.
 Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
 Proof. intros m; exact (@Raw.add_3 elt m.(this)). Qed.

 Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m).
 Proof. intros m; exact (@Raw.remove_1 elt m.(this) m.(sorted)). Qed.
 Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
 Proof. intros m; exact (@Raw.remove_2 elt m.(this) m.(sorted)). Qed.
 Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
 Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(sorted)). Qed.

 Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e.
 Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(sorted)). Qed.
 Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
 Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed.

 Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
 Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed.
 Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
 Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed.
 Lemma elements_3 : forall m, sort lt_key (elements m).
 Proof. intros m; exact (@Raw.elements_3 elt m.(this) m.(sorted)). Qed.
 Lemma elements_3w : forall m, NoDupA eq_key (elements m).
 Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(sorted)). Qed.

 Lemma cardinal_1 : forall m, cardinal m = length (elements m).
 Proof. intros; reflexivity. Qed.

 Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A),
        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
 Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed.

 Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true.
 Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed.
 Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'.
 Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed.

 End Elt.

 Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
        MapsTo x e m -> MapsTo x (f e) (map f m).
 Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed.
 Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
        In x (map f m) -> In x m.
 Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed.

 Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
        (f:key->elt->elt'), MapsTo x e m ->
        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
 Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed.
 Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
        (f:key->elt->elt'), In x (mapi f m) -> In x m.
 Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed.

 Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
	(x:key)(f:option elt->option elt'->option elt''),
	In x m \/ In x m' ->
        find x (map2 f m m') = f (find x m) (find x m').
 Proof.
 intros elt elt' elt'' m m' x f;
 exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x).
 Qed.
 Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
	(x:key)(f:option elt->option elt'->option elt''),
        In x (map2 f m m') -> In x m \/ In x m'.
 Proof.
 intros elt elt' elt'' m m' x f;
 exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x).
 Qed.

End Make.

Module Make_ord (X: OrderedType)(D : OrderedType) <:
Sord with Module Data := D
        with Module MapS.E := X.

Module Data := D.
Module MapS := Make(X).
Import MapS.

Module MD := OrderedTypeFacts(D).
Import MD.

Definition t := MapS.t D.t.

Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end.

Fixpoint eq_list (m m' : list (X.t * D.t)) : Prop :=
  match m, m' with
   | nil, nil => True
   | (x,e)::l, (x',e')::l' =>
      match X.compare x x' with
       | EQ _ => D.eq e e' /\ eq_list l l'
       | _       => False
      end
   | _, _ => False
  end.

Definition eq m m' := eq_list m.(this) m'.(this).

Fixpoint lt_list (m m' : list (X.t * D.t)) : Prop :=
  match m, m' with
   | nil, nil => False
   | nil, _  => True
   | _, nil  => False
   | (x,e)::l, (x',e')::l' =>
      match X.compare x x' with
       | LT _ => True
       | GT _ => False
       | EQ _ => D.lt e e' \/ (D.eq e e' /\ lt_list l l')
      end
  end.

Definition lt m m' := lt_list m.(this) m'.(this).

Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true.
Proof.
 intros (l,Hl); induction l.
 intros (l',Hl'); unfold eq; simpl.
 destruct l'; unfold equal; simpl; intuition.
 intros (l',Hl'); unfold eq.
 destruct l'.
 destruct a; unfold equal; simpl; intuition.
 destruct a as (x,e).
 destruct p as (x',e').
 unfold equal; simpl.
 destruct (X.compare x x'); simpl; intuition.
 unfold cmp at 1.
 MD.elim_comp; clear H; simpl.
 inversion_clear Hl.
 inversion_clear Hl'.
 destruct (IHl H (Build_slist H3)).
 unfold equal, eq in H5; simpl in H5; auto.
 destruct (andb_prop _ _ H); clear H.
 generalize H0; unfold cmp.
 MD.elim_comp; auto; intro; discriminate.
 destruct (andb_prop _ _ H); clear H.
 inversion_clear Hl.
 inversion_clear Hl'.
 destruct (IHl H (Build_slist H3)).
 unfold equal, eq in H6; simpl in H6; auto.
Qed.

Lemma eq_1 : forall m m', Equivb cmp m m' -> eq m m'.
Proof.
 intros.
 generalize (@equal_1 D.t m m' cmp).
 generalize (@eq_equal m m').
 intuition.
Qed.

Lemma eq_2 : forall m m', eq m m' -> Equivb cmp m m'.
Proof.
 intros.
 generalize (@equal_2 D.t m m' cmp).
 generalize (@eq_equal m m').
 intuition.
Qed.

Lemma eq_refl : forall m : t, eq m m.
Proof.
 intros (m,Hm); induction m; unfold eq; simpl; auto.
 destruct a.
 destruct (X.compare t0 t0); auto.
 apply (MapS.Raw.MX.lt_antirefl l); auto.
 split.
 apply D.eq_refl.
 inversion_clear Hm.
 apply (IHm H).
 apply (MapS.Raw.MX.lt_antirefl l); auto.
Qed.

Lemma  eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
Proof.
 intros (m,Hm); induction m;
 intros (m', Hm'); destruct m'; unfold eq; simpl;
 try destruct a as (x,e); try destruct p as (x',e'); auto.
 destruct (X.compare x x'); MapS.Raw.MX.elim_comp; intuition.
 inversion_clear Hm; inversion_clear Hm'.
 apply (IHm H0 (Build_slist H4)); auto.
Qed.

Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
Proof.
 intros (m1,Hm1); induction m1;
 intros (m2, Hm2); destruct m2;
 intros (m3, Hm3); destruct m3; unfold eq; simpl;
 try destruct a as (x,e);
 try destruct p as (x',e');
 try destruct p0 as (x'',e''); try contradiction; auto.
 destruct (X.compare x x');
  destruct (X.compare x' x'');
   MapS.Raw.MX.elim_comp; intuition.
 apply D.eq_trans with e'; auto.
 inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
 apply (IHm1 H1 (Build_slist H6) (Build_slist H8)); intuition.
Qed.

Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
Proof.
 intros (m1,Hm1); induction m1;
 intros (m2, Hm2); destruct m2;
 intros (m3, Hm3); destruct m3; unfold lt; simpl;
 try destruct a as (x,e);
 try destruct p as (x',e');
 try destruct p0 as (x'',e''); try contradiction; auto.
 destruct (X.compare x x');
  destruct (X.compare x' x'');
   MapS.Raw.MX.elim_comp; intuition.
 left; apply D.lt_trans with e'; auto.
 left; apply lt_eq with e'; auto.
 left; apply eq_lt with e'; auto.
 right.
 split.
 apply D.eq_trans with e'; auto.
 inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
 apply (IHm1 H2 (Build_slist H6) (Build_slist H8)); intuition.
Qed.

Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
Proof.
 intros (m1,Hm1); induction m1;
 intros (m2, Hm2); destruct m2; unfold eq, lt; simpl;
 try destruct a as (x,e);
 try destruct p as (x',e'); try contradiction; auto.
 destruct (X.compare x x'); auto.
 intuition.
 exact (D.lt_not_eq H0 H1).
 inversion_clear Hm1; inversion_clear Hm2.
 apply (IHm1 H0 (Build_slist H5)); intuition.
Qed.

Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto.

Definition compare : forall m1 m2, Compare lt eq m1 m2.
Proof.
 intros (m1,Hm1); induction m1;
 intros (m2, Hm2); destruct m2;
  [ apply EQ | apply LT | apply GT | ]; cmp_solve.
 destruct a as (x,e); destruct p as (x',e').
 destruct (X.compare x x');
  [ apply LT | | apply GT ]; cmp_solve.
 destruct (D.compare e e');
  [ apply LT | | apply GT ]; cmp_solve.
 assert (Hm11 : sort (Raw.PX.ltk (elt:=D.t)) m1).
  inversion_clear Hm1; auto.
 assert (Hm22 : sort (Raw.PX.ltk (elt:=D.t)) m2).
  inversion_clear Hm2; auto.
 destruct (IHm1 Hm11 (Build_slist Hm22));
  [ apply LT | apply EQ | apply GT ]; cmp_solve.
Qed.

End Make_ord.


(** * Equivalence on syntax *)
Require Import Fiat.Parsers.Reflective.Syntax Fiat.Parsers.Reflective.ParserSyntax.
Require Import Fiat.Parsers.Reflective.SyntaxEquivalence.

Section has_parse_term_equiv.
  Context (var1 var2 : TypeCode -> Type).

  Inductive has_parse_term_equiv {T} : ctxt var1 var2 -> has_parse_term var1 T -> has_parse_term var2 T -> Prop :=
  | EqFix2
      (G_length : nat) (up_to_G_length : list nat)
      (valid_len : nat)
      (valids : list nat)
      (nt_idx : nat)
    : forall G f1 f2 default1 default2,
      Term_equiv G f1 f2
      -> Term_equiv G default1 default2
      -> has_parse_term_equiv
           G
           (RFix2 G_length up_to_G_length f1 default1 valid_len valids nt_idx)
           (RFix2 G_length up_to_G_length f2 default2 valid_len valids nt_idx).
End has_parse_term_equiv.