Require Import ssreflect ssrfun ssrbool eqtype fintype finfun seq tuple.
Require Import ilogic.

(* Importing this file really only makes sense if you also import ilogic, so we
   force that. *)
Require Export ilogic bilogic.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import FunctionalExtensionality.

(* This should not be here, //Jesper *)

Section ILogicSSReflect.
  Context {A} `{ILogic A}.

  Lemma lpropandT P : true /\\ P -|- P.
  Proof. rewrite /lpropand. split; [by apply lexistsL | by apply lexistsR]. Qed.

  Lemma lpropandF P : false /\\ P -|- lfalse.
  Proof. rewrite /lpropand. split; [by apply lexistsL | done]. Qed.

End ILogicSSReflect.

(* Tactics for doing forward reasoning from a hypothesis. *)
Lemma lforwardR {Frm} `{IL: ILogic Frm} P Q R:
  Q |-- R -> P |-- Q -> P |-- R.
Proof. intros; etransitivity; eassumption. Qed.
Tactic Notation "lforwardR" hyp(H) := eapply lforwardR in H; last first.

Lemma lforwardL {Frm} `{IL: ILogic Frm} P Q R:
  P |-- Q -> Q |-- R -> P |-- R.
Proof. intros; etransitivity; eassumption. Qed.
Tactic Notation "lforwardL" hyp(H) := eapply lforwardL in H; last first.

(* This tactic is a ilogic version of [move:]. Can it be done easier? *)
Ltac lrevert x :=
  move: x;
  match goal with
  | |- ?P -> _ |-- ?G =>
      move=> x;
      transitivity (P ->> G);
      [clear x | apply lpropimplL; [exact x|reflexivity] ]
  | |- forall a, _ |-- @?G a =>
      move=> x;
      transitivity (lforall G);
      [clear x | apply lforallL with x; reflexivity ]
  end.


(*
 * Listkit: A library for working with lists in Coq.
 * Copyright Ezra Cooper, 2008-2020.
 *)

Require Import List.

Set Universe Polymorphism.

Fixpoint zip A B xs ys {struct xs} : list (A*B) :=
  match xs with
  | nil => nil
  | x::xs' => match ys with
        | nil => nil
        | y::ys' => (x, y) :: zip A B xs' ys'
        end
end.

Fixpoint zip_with A B C (f : A->B->C) xs ys {struct xs} : list C :=
  match xs with
  | nil => nil
  | x::xs' => match ys with
        | nil => nil
        | y::ys' => f x y :: zip_with A B C f xs' ys'
        end
end.

(** Assert that a predicate is true for each element of a list. *)
Definition foreach A (xs : list A) (P : A -> Prop) :=
  fold_right and True (map P xs).

(** When we have [foreach xs P] then indexing with [nth_error] into
    [xs] gives something with [P] *)
Lemma foreach_member : forall A P v n xs,
    foreach A xs P -> value v = nth_error xs n -> P v.
Proof.
 induction n; simpl; intros; destruct xs; try discriminate.
  unfold foreach in H.
  simpl in H.
  inversion H0.
  cut (P a); intuition.
 firstorder.
Qed.

(** Assert that a (Type-valued) predicate is true for each element of a list. *)
Definition foreach_ty A (xs : list A) (P : A -> Type) :=
  fold_right (fun x y => x*y)%type True (map P xs).

(** Assert that all corresponding elements of two lists stand in a certain relation. *)
Definition foreach2 A B (xs : list A) (ys : list B ) (P : A -> B -> Prop) :=
  fold_right and True
    (map (fun pr:A*B => let (x, y) := pr in P x y)
         (zip A B xs ys)).

Lemma foreach2_member : forall A B R v w n xs ys,
    (foreach2 A B xs ys R) ->
    value v = nth_error xs n ->
    value w = nth_error ys n ->
    R v w.
Proof.
 induction n; simpl; intros; destruct xs; destruct ys; try discriminate.
  unfold foreach2 in H.
  simpl in H.
  inversion H0.
  inversion H1.
  firstorder.
 firstorder.
Qed.

(** Assert that all corresponding elements of two lists stand in a
    certain (Type-valued) relation. *)
Definition foreach2_ty A B (xs : list A) (ys : list B ) (P : A -> B -> Type) :=
  fold_right
    (fun x y => x*y)%type
    unit%type
    (map (fun pr:A*B => let (x, y) := pr in P x y) (zip A B xs ys)).

Lemma foreach2_ty_member : forall A B R v w n xs ys,
    (foreach2_ty A B xs ys R) ->
    value v = nth_error xs n ->
    value w = nth_error ys n ->
    R v w.
Proof.
 induction n; simpl; intros; destruct xs; destruct ys; try discriminate.
  unfold foreach2_ty in X.
  simpl in X.
  inversion H.
  inversion H0.
  firstorder.
 firstorder.
Qed.

(* Unused: remove? *)
Lemma foreach_cut A (P Q : A -> Prop) xs:
   (forall x, In x xs -> P x -> Q x) -> foreach _ xs P -> foreach _ xs Q.
Proof.
 induction xs; firstorder.
Qed.

(* Unused: remove? *)
Lemma foreach2_cut A B (P Q : A -> B -> Prop):
  forall xs ys,
    (forall x y, In x xs -> In y ys -> P x y -> Q x y) ->
    foreach2 _ _ xs ys P -> foreach2 _ _ xs ys Q.
Proof.
 induction xs; [idtac|destruct ys]; firstorder.
 apply IHxs; auto.
 intros; apply H; auto.
 apply in_cons; auto.
 apply in_cons; auto.
Qed.

(* Unused: remove? *)
Lemma foreach2_ty_cons :
  forall A B x xs y ys R,
  foreach2_ty A B (x::xs) (y::ys) R =
   (R x y * foreach2_ty A B xs ys R)%type.
Proof.
 intuition.
Qed.

(* Unused: remove? *)
Lemma foreach2_ty_cut A B (P Q : A -> B -> Type):
  forall xs ys,
    (forall x y, In x xs -> In y ys -> P x y -> Q x y) ->
    foreach2_ty _ _ xs ys P -> foreach2_ty _ _ xs ys Q.
Proof.
 induction xs; [idtac|destruct ys]; firstorder.
 apply IHxs; auto.
 intros; apply X; auto.
 apply in_cons; auto.
 apply in_cons; auto.
Qed.

Lemma foreach_ty_map :
  forall A f P xs,
    foreach_ty A (map f xs) P = foreach_ty A xs (fun x => P (f x)).
Proof.
 induction xs; unfold foreach_ty; auto.
 rewrite map_map.
 trivial.
Qed.

Lemma foreach_ty_impl :
  forall A P Q xs,
    (forall x, P x -> Q x) -> foreach_ty A xs P -> foreach_ty A xs Q.
Proof.
 unfold foreach_ty.
 unfold fold_right.
 induction xs; simpl; intros P_impl_Q H.
  auto.
 inversion H.
 split.
  auto.
 apply IHxs; auto.
Qed.

Lemma foreach_ty_member : forall A P v,
  forall n xs,
    (foreach_ty A xs P) ->
    value v = nth_error xs n -> P v.
Proof.
 induction n; simpl; intros; destruct xs; try discriminate.
  unfold foreach_ty in X.
  simpl in X.
  inversion H.
  intuition.
 firstorder.
Qed.

Lemma foreach_universal:
  forall A (f:A->Prop), (forall x, f x) -> forall xs, foreach _ xs f.
Proof.
 induction xs; unfold foreach; simpl; intros.
  auto.
 auto.
Qed.

Lemma zip_map_diamond:
  forall A B1 B2 (f1:A->B1) (f2:A->B2) xs,
    zip _ _ (map f1 xs) (map f2 xs) = map (fun x => (f1 x, f2 x)) xs.
Proof.
 induction xs; simpl; intros.
  auto.
 f_equal.
 auto.
Qed.


(* ========================== *)
(* Elaboration rules          *)
(* ========================== *)

Require Import Basics.
Require Import Syntax.
Require Import SemObjects.
Require Import CpdtTactics.
Require Import ElabCore.
Require Import NomEnv.

Module FreshTSetEnv := NomN.Fresh NomN.PFin PermSemOb.
Module FreshTSet := NomN.Fresh NomN.PFin NomN.PFin.

Infix ":U:" := TSetMod.union (at level 40).
Infix "#" := FreshTSetEnv.fresh (at level 40) : env_scope.
Infix "#" := FreshTSet.fresh (at level 40) : set_scope.

Delimit Scope env_scope with E.
Delimit Scope set_scope with S.

(* ------------------------------------------------------ *)
(* Elaboration rules for modules types and specifications *)
(* ------------------------------------------------------ *)

(* Currently, we ignore the issues with variables bound in module types
   and functors and assume these sets of bound variables to be empty *)

Inductive Mty_melab : Env -> mty -> MTy -> Prop :=
| Bra_mty_melab : forall E spec S,
    Spec_melab E spec S -> Mty_melab E (Bra_mty spec) S
| Mtid_mty_melab : forall E mtid S,
    lookLongMtid mtid E = Some S -> Mty_melab E (Mtid_mty mtid) S
| Arr_mty_melab : forall E mty1 mty2 E' M,
    Mty_melab E mty1 (MSigma emptyTSet (NonParamMod E')) -> Mty_melab E mty2 (MSigma emptyTSet M) ->
    Mty_melab E (Arr_mty None mty1 mty2) (MSigma emptyTSet (Ftor emptyTSet E' (MSigma emptyTSet M)))
with Spec_melab : Env -> spec -> MTy -> Prop :=
| Type_spec_none_elab : forall (E:Env) (id:tid) (t:Tv),
    Spec_melab E (Type_spec id None) (MSigma (addTSet t emptyTSet) (NonParamMod (addEnvTid id (Tv_Ty t) emptyEnv)))
| Type_spec_some_melab : forall E tid ty Ty,
    Ty_elab E ty Ty -> Spec_melab E (Type_spec tid (Some ty))
                                  (MSigma emptyTSet (NonParamMod (addEnvTid tid Ty emptyEnv)))
| Val_spec_melab : forall E vid ty Ty,
    Ty_elab E ty Ty -> Spec_melab E (Val_spec vid ty)
                                  (MSigma emptyTSet (NonParamMod (addEnvVid vid Ty emptyEnv)))
| Module_spec_nonparam_melab : forall E E' mid mty,
    Mty_melab E mty (MSigma emptyTSet (NonParamMod E')) ->
    Spec_melab E (Module_spec mid mty) (MSigma emptyTSet (NonParamMod (addEnvMid mid (NonParamMod E') emptyEnv)))
| Module_spec_param_melab : forall E E' M mid mty,
    Mty_melab E mty (MSigma emptyTSet (Ftor emptyTSet E' M)) ->
    Spec_melab E (Module_spec mid mty)
               (MSigma emptyTSet (NonParamMod (addEnvMid mid (Ftor emptyTSet E' M) emptyEnv)))
| Include_spec_melab : forall E mty M,
    Mty_melab E mty M -> Spec_melab E (Include_spec mty) M
| Seq_spec_elab : forall E s1 s2 E1 E2 T1 T2,
    Spec_melab E s1 (MSigma T1 (NonParamMod E1)) ->
    Spec_melab (plusEnvEnv E E1) s2 (MSigma T2 (NonParamMod E2)) ->
    (T1 # T2)%S ->
    (T1 # PermSemOb.fvs E)%S ->
    Spec_melab E (Seq_spec s1 s2) (MSigma (T1 :U: T2) (NonParamMod (plusEnvEnv E1 E2)))
| Emp_spec_melab : forall E,
    Spec_melab E Emp_spec (MSigma emptyTSet (NonParamMod emptyEnv)).

Module Examples.
(* ---------------------------------------------*)
(* {} |- type t type s : ({t1,t2}){t->t1,s->t2} *)
(* ---------------------------------------------*)

  Import SemObjects.EnvMod.
  Import TSetMod.

  Parameter s : ID.t.
  Parameter t : ID.t.

  Definition ex1 : spec := Seq_spec (Type_spec t None) (Type_spec s None).

  Lemma singleton_add a : singleton a = add a empty.
  Proof.
    apply set_extensionality; intros; split; intros; auto with set.
  Qed.

  Lemma singleton_neq_disj a b : a <> b -> Disjoint (singleton a) (singleton b).
  Proof.
    rewrite TSetMod.Disjoint_spec. intros. unfold not.
    intros H1.
    destruct H1.
      assert (k=a). rewrite TSetMod.OP.P.Dec.F.singleton_iff in *.
      auto with set.
      assert (k=b).  unfold NomN.PFin.supp in *. rewrite TSetMod.OP.P.Dec.F.singleton_iff in *.
      auto with set. congruence.
  Qed.

  Lemma empty_disj X : Disjoint X empty.
  Proof.
    rewrite TSetMod.Disjoint_spec. intros. unfold not.
    intros. destruct H as [H1 H2]. cbv in H2. inversion H2.
  Qed.

  Lemma ex1elab: Spec_melab emptyEnv ex1
                          (MSigma ((singleton 2) :U: (singleton 1))
                                  (NonParamMod (addEnvTid s (Tv_Ty 1)
                                                          (addEnvTid t (Tv_Ty 2) emptyEnv)))).
  Proof.
    unfold ex1.
    rewrite map1.
    repeat rewrite singleton_add.
    repeat econstructor.
    - repeat rewrite <- singleton_add.
      apply singleton_neq_disj. auto.
    - rewrite <- singleton_add.
      apply empty_disj.
  Qed.

  (* --------------------------------------------*)
  (* {} |- type t type s=t : ({t1}){t->t1,s->t1} *)
  (* --------------------------------------------*)
  Definition ex2 : spec :=
    Seq_spec (Type_spec t None) (Type_spec s (Some (Longtid_ty (Tid_longtid t)))).

  Lemma ex2elab: Spec_melab emptyEnv ex2
                          (MSigma (addTSet 1 emptyTSet)
                                  (NonParamMod (addEnvTid s (Tv_Ty 1)
                                                          (addEnvTid t (Tv_Ty 1) emptyEnv)))).

  Proof.
    unfold ex2. rewrite set1. rewrite map1.
    repeat constructor; try (rewrite <- singleton_add; apply empty_disj). simpl.
    apply EnvMod.add_lookup.
  Qed.

End Examples.

Section Examples1.

  Import EnvMod.

  Parameter int : tid.
  Parameter t : tid.
  Parameter s : tid.

  (* ----------------------------------- *)
  (* {int->t1} |- type s=int : (){s->t1} *)
  (* ----------------------------------- *)

  Definition E0 : Env := plusEnvEnv emptyEnv (addEnvTid int (Tv_Ty 1) emptyEnv).

  Definition ex3 : spec := Type_spec s (Some (Longtid_ty (Tid_longtid int))).

  Set Printing Coercions.

  Lemma ex3lem: Spec_melab E0 ex3
                           (MSigma emptyTSet
                                   (NonParamMod (addEnvTid s (Tv_Ty 1) emptyEnv))).

  Proof.
    unfold ex3. repeat constructor. simpl.
    rewrite <- mapAddPlusEmpty. rewrite EnvMod.add_lookup.
    reflexivity.
  Qed.
End Examples1.

  (* ---------------------------------------------------------- *)
  (* Elaboration rules for modules expressions and declarations *)
  (* ---------------------------------------------------------- *)

Inductive Mexp_melab : Env -> mexp -> TSet -> Mod -> Prop :=
  | Bra_mexp_melab : forall E mdec E',
      Mdec_melab E mdec emptyTSet E'  ->
      Mexp_melab E (Bra_mexp mdec) emptyTSet (NonParamMod E')
  | Mid_mexp_melab : forall E mid M,
      lookMidE mid E = Some M ->
      Mexp_melab E (Mid_mexp mid) emptyTSet M
  | Prj_mexp_melab : forall E mexp mid E' M,
      Mexp_melab E mexp emptyTSet (NonParamMod E') ->
      lookMidE mid E' = Some M ->
      Mexp_melab E (Prj_mexp mexp mid) emptyTSet M
  | Funct_mexp_melab : forall E0 mid mty mexp E E',
      Mty_melab E0 mty (MSigma emptyTSet (NonParamMod E)) ->
      Mexp_melab (addEnvMid mid (NonParamMod E) E0) mexp emptyTSet E' ->
      Mexp_melab E0 (Funct_mexp mid mty mexp)
                 emptyTSet (Ftor emptyTSet E (MSigma emptyTSet E'))
  | App_mexp_melab : forall E0 longmid mexp E E' E'',
      lookLongMid longmid E0 = Some (Ftor emptyTSet E' (MSigma emptyTSet (NonParamMod E''))) ->
      Mexp_melab E0 mexp emptyTSet (NonParamMod E) ->
      enriches E E' ->
      Mexp_melab E0 (App_mexp longmid mexp) emptyTSet (NonParamMod E'')
  with Mdec_melab : Env -> mdec -> TSet -> Env -> Prop :=
  | Dec_mdec_melab : forall E dec E',
      Dec_elab E dec E' ->
      Mdec_melab E (Dec_mdec dec) emptyTSet E'
  | Type_mdec_melab : forall E tid ty Ty,
      Ty_elab E ty Ty ->
      Mdec_melab E (Type_mdec tid ty) emptyTSet (addEnvTid tid Ty emptyEnv)
  | Mod_mdec_melab : forall E0 mid mexp M,
      Mexp_melab E0 mexp emptyTSet M ->
      Mdec_melab E0 (Mod_mdec mid mexp) emptyTSet (addEnvMid mid M emptyEnv)
  | ModTyp_mdec_melab : forall E mtid mty S,
      Mty_melab E mty S ->
      Mdec_melab E (ModTyp_mdec mtid mty) emptyTSet (addEnvMtid mtid S emptyEnv)
  | Open_mdec_melab : forall E0 mexp E,
      Mexp_melab E0 mexp emptyTSet (NonParamMod E) ->
      Mdec_melab E0 (Open_mdec mexp) emptyTSet E
  | Seq_mdec_melab : forall E mdec1 mdec2 E1 E2 T1 T2,
      Mdec_melab E mdec1 T1 E1 ->
      Mdec_melab (plusEnvEnv E E1) mdec2 T2 E2 ->
      (T1 # T2)%S ->
      (T1 # PermSemOb.fvs E)%S ->
      Mdec_melab E (Seq_mdec mdec1 mdec2) (T1 :U: T2) (plusEnvEnv E1 E2)
  | Emp_mdec_melab : forall E,
      Mdec_melab E Emp_mdec emptyTSet emptyEnv.

Scheme melab_mexp_mut :=
    Induction for Mexp_melab Sort Prop
  with melab_mdec_mut := Induction for Mdec_melab Sort Prop.

Combined Scheme melab_mut from melab_mexp_mut, melab_mdec_mut.

Section Examples2.

  Parameter two : tid.
  Parameter X : tid.
  Parameter a : vid.
  Parameter b : vid.

  (* p1 = module X = { val a = two } val b = X.a *)

  Definition p1 : mdec :=
    Mod_mdec X (Bra_mexp (Dec_mdec (Val_dec a (Longvid_exp (Vid_longvid two))))).

  Definition p2 : mdec :=
    Dec_mdec (Val_dec b (Longvid_exp (Long_longvid X (Vid_longvid a)))).

  Definition p : mdec := Seq_mdec p1 p2.

  Definition E1 : Env :=
    plusEnvEnv E0 (addEnvVid two (Tv_Ty 1) emptyEnv).

  Definition E : Env := addEnvVid a (Tv_Ty 1) emptyEnv.

  Definition E' : Env :=
    addEnvVid b (Tv_Ty 1)
              (addEnvMid X (NonParamMod E) emptyEnv).

End Examples2.


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 O A B C Aprime Bprime Cprime : Universe, ((wd_ Aprime Cprime /\ (wd_ O Aprime /\ (wd_ O Bprime /\ (wd_ O Cprime /\ (wd_ A Aprime /\ (wd_ C Cprime /\ (wd_ A C /\ (wd_ O C /\ (wd_ O B /\ (wd_ O A /\ (col_ O A C /\ (col_ A B C /\ (col_ O Aprime Cprime /\ (col_ A C Cprime /\ (col_ Aprime C Cprime /\ col_ Aprime Bprime Cprime))))))))))))))) -> col_ O C Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

(** Characterization and properties of deterministic external worlds
  and deterministic semantics *)

Require Import String.
Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Events.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Behaviors.

(** * Deterministic worlds *)

(** One source of possible nondeterminism is that our semantics leave
  unspecified the results of system calls.
  Different results to e.g. a "read" operation can of
  course lead to different behaviors for the program.
  We address this issue by modeling a notion of deterministic
  external world that uniquely determines the results of external calls. *)

(** An external world is a function that, given the name of an
  external call and its arguments, returns either [None], meaning
  that this external call gets stuck, or [Some(r,w)], meaning
  that this external call succeeds, has result [r], and changes
  the world to [w]. *)

CoInductive world: Type :=
  World (io: string -> list eventval -> option (eventval * world))
        (vload: memory_chunk -> ident -> int -> option (eventval * world))
        (vstore: memory_chunk -> ident -> int -> eventval -> option world).

Definition nextworld_io (w: world) (evname: string) (evargs: list eventval) :
                     option (eventval * world) :=
  match w with World io vl vs => io evname evargs end.

Definition nextworld_vload (w: world) (chunk: memory_chunk) (id: ident) (ofs: int) :
                     option (eventval * world) :=
  match w with World io vl vs => vl chunk id ofs end.

Definition nextworld_vstore (w: world) (chunk: memory_chunk) (id: ident) (ofs: int) (v: eventval):
                     option world :=
  match w with World io vl vs => vs chunk id ofs v end.

(** A trace is possible in a given world if all events correspond
  to non-stuck external calls according to the given world.
  Two predicates are defined, for finite and infinite traces respectively:
- [possible_trace w t w'], where [w] is the initial state of the
  world, [t] the finite trace of interest, and [w'] the state of the
  world after performing trace [t].
- [possible_traceinf w T], where [w] is the initial state of the
  world and [T] the infinite trace of interest.
*)

Inductive possible_event: world -> event -> world -> Prop :=
  | possible_event_syscall: forall w1 evname evargs evres w2,
      nextworld_io w1 evname evargs = Some (evres, w2) ->
      possible_event w1 (Event_syscall evname evargs evres) w2
  | possible_event_vload: forall w1 chunk id ofs evres w2,
      nextworld_vload w1 chunk id ofs = Some (evres, w2) ->
      possible_event w1 (Event_vload chunk id ofs evres) w2
  | possible_event_vstore: forall w1 chunk id ofs evarg w2,
      nextworld_vstore w1 chunk id ofs evarg = Some w2 ->
      possible_event w1 (Event_vstore chunk id ofs evarg) w2
  | possible_event_annot: forall w1 id args,
      possible_event w1 (Event_annot id args) w1.

Inductive possible_trace: world -> trace -> world -> Prop :=
  | possible_trace_nil: forall w,
      possible_trace w E0 w
  | possible_trace_cons: forall w1 ev w2 t w3,
      possible_event w1 ev w2 -> possible_trace w2 t w3 ->
      possible_trace w1 (ev :: t) w3.

Lemma possible_trace_app:
  forall t2 w2 w0 t1 w1,
  possible_trace w0 t1 w1 -> possible_trace w1 t2 w2 ->
  possible_trace w0 (t1 ** t2) w2.
Proof.
  induction 1; simpl; intros.
  auto.
  econstructor; eauto.
Qed.

Lemma possible_trace_app_inv:
  forall t2 w2 t1 w0,
  possible_trace w0 (t1 ** t2) w2 ->
  exists w1, possible_trace w0 t1 w1 /\ possible_trace w1 t2 w2.
Proof.
  induction t1; simpl; intros.
  exists w0; split. constructor. auto.
  inv H. exploit IHt1; eauto. intros [w1 [A B]].
  exists w1; split. econstructor; eauto. auto.
Qed.

Lemma match_possible_traces:
  forall ge t1 t2 w0 w1 w2,
  match_traces ge t1 t2 -> possible_trace w0 t1 w1 -> possible_trace w0 t2 w2 ->
  t1 = t2 /\ w1 = w2.
Proof.
  intros. inv H; inv H1; inv H0.
  auto.
  inv H7; inv H6. inv H9; inv H10. split; congruence.
  inv H7; inv H6. inv H9; inv H10. split; congruence.
  inv H4; inv H3. inv H6; inv H7. split; congruence.
  inv H4; inv H3. inv H7; inv H6. auto.
Qed.

CoInductive possible_traceinf: world -> traceinf -> Prop :=
  | possible_traceinf_cons: forall w1 ev w2 T,
      possible_event w1 ev w2 ->
      possible_traceinf w2 T ->
      possible_traceinf w1 (Econsinf ev T).

Lemma possible_traceinf_app:
  forall t2 w0 t1 w1,
  possible_trace w0 t1 w1 -> possible_traceinf w1 t2 ->
  possible_traceinf w0 (t1 *** t2).
Proof.
  induction 1; simpl; intros.
  auto.
  econstructor; eauto.
Qed.

Lemma possible_traceinf_app_inv:
  forall t2 t1 w0,
  possible_traceinf w0 (t1 *** t2) ->
  exists w1, possible_trace w0 t1 w1 /\ possible_traceinf w1 t2.
Proof.
  induction t1; simpl; intros.
  exists w0; split. constructor. auto.
  inv H. exploit IHt1; eauto. intros [w1 [A B]].
  exists w1; split. econstructor; eauto. auto.
Qed.

Ltac possibleTraceInv :=
  match goal with
  | [H: possible_trace _ E0 _ |- _] =>
      inversion H; clear H; subst; possibleTraceInv
  | [H: possible_trace _ (_ ** _) _ |- _] =>
      let P1 := fresh "P" in
      let w := fresh "w" in
      let P2 := fresh "P" in
      elim (possible_trace_app_inv _ _ _ _ H); clear H;
      intros w [P1 P2];
      possibleTraceInv
  | [H: possible_traceinf _ (_ *** _) |- _] =>
      let P1 := fresh "P" in
      let w := fresh "w" in
      let P2 := fresh "P" in
      elim (possible_traceinf_app_inv _ _ _ H); clear H;
      intros w [P1 P2];
      possibleTraceInv
  | [H: exists w, possible_trace _ _ w |- _] =>
      let P := fresh "P" in let w := fresh "w" in
      destruct H as [w P]; possibleTraceInv
  | _ => idtac
  end.

Definition possible_behavior (w: world) (b: program_behavior) : Prop :=
  match b with
  | Terminates t r => exists w', possible_trace w t w'
  | Diverges t => exists w', possible_trace w t w'
  | Reacts T => possible_traceinf w T
  | Goes_wrong t => exists w', possible_trace w t w'
  end.

CoInductive possible_traceinf': world -> traceinf -> Prop :=
  | possible_traceinf'_app: forall w1 t w2 T,
      possible_trace w1 t w2 -> t <> E0 ->
      possible_traceinf' w2 T ->
      possible_traceinf' w1 (t *** T).

Lemma possible_traceinf'_traceinf:
  forall w T, possible_traceinf' w T -> possible_traceinf w T.
Proof.
  cofix COINDHYP; intros. inv H. inv H0. congruence.
  simpl. econstructor. eauto. apply COINDHYP.
  inv H3. simpl. auto. econstructor; eauto. econstructor; eauto. unfold E0; congruence.
Qed.

(** * Definition and properties of deterministic semantics *)

Record sem_deterministic (L: semantics) := mk_deterministic {
  det_step: forall s0 t1 s1 t2 s2,
    Step L s0 t1 s1 -> Step L s0 t2 s2 -> s1 = s2 /\ t1 = t2;
  det_initial_state: forall s1 s2,
    initial_state L s1 -> initial_state L s2 -> s1 = s2;
  det_final_state: forall s r1 r2,
    final_state L s r1 -> final_state L s r2 -> r1 = r2;
  det_final_nostep: forall s r,
    final_state L s r -> Nostep L s
}.

Section DETERM_SEM.

Variable L: semantics.
Hypothesis DET: sem_deterministic L.

Ltac use_step_deterministic :=
  match goal with
  | [ S1: Step L _ ?t1 _, S2: Step L _ ?t2 _ |- _ ] =>
    destruct (det_step L DET _ _ _ _ _ S1 S2) as [EQ1 EQ2]; subst
  end.

(** Determinism for finite transition sequences. *)

Lemma star_step_diamond:
  forall s0 t1 s1, Star L s0 t1 s1 ->
  forall t2 s2, Star L s0 t2 s2 ->
  exists t,
     (Star L s1 t s2 /\ t2 = t1 ** t)
  \/ (Star L s2 t s1 /\ t1 = t2 ** t).
Proof.
  induction 1; intros.
  exists t2; auto.
  inv H2. exists (t1 ** t2); right.
    split. econstructor; eauto. auto.
  use_step_deterministic.
  exploit IHstar. eexact H4. intros [t A]. exists t.
  destruct A. left; intuition. traceEq. right; intuition. traceEq.
Qed.

Ltac use_star_step_diamond :=
  match goal with
  | [ S1: Star L _ ?t1 _, S2: Star L _ ?t2 _ |- _ ] =>
    let t := fresh "t" in let P := fresh "P" in let EQ := fresh "EQ" in
    destruct (star_step_diamond _ _ _ S1 _ _ S2)
    as [t [ [P EQ] | [P EQ] ]]; subst
 end.

Ltac use_nostep :=
  match goal with
  | [ S: Step L ?s _ _, NO: Nostep L ?s |- _ ] => elim (NO _ _ S)
  end.

Lemma star_step_triangle:
  forall s0 t1 s1 t2 s2,
  Star L s0 t1 s1 ->
  Star L s0 t2 s2 ->
  Nostep L s2 ->
  exists t,
  Star L s1 t s2 /\ t2 = t1 ** t.
Proof.
  intros. use_star_step_diamond.
  exists t; auto.
  inv P. exists E0. split. constructor. traceEq.
  use_nostep.
Qed.

Ltac use_star_step_triangle :=
  match goal with
  | [ S1: Star L _ ?t1 _, S2: Star L _ ?t2 ?s2, NO: Nostep L ?s2 |- _ ] =>
    let t := fresh "t" in let P := fresh "P" in let EQ := fresh "EQ" in
    destruct (star_step_triangle _ _ _ _ _ S1 S2 NO)
    as [t [P EQ]]; subst
  end.

Lemma steps_deterministic:
  forall s0 t1 s1 t2 s2,
  Star L s0 t1 s1 -> Star L s0 t2 s2 ->
  Nostep L s1 -> Nostep L s2 ->
  t1 = t2 /\ s1 = s2.
Proof.
  intros. use_star_step_triangle. inv P.
  split; auto; traceEq. use_nostep.
Qed.

Lemma terminates_not_goes_wrong:
  forall s t1 s1 r t2 s2,
  Star L s t1 s1 -> final_state L s1 r ->
  Star L s t2 s2 -> Nostep L s2 ->
  (forall r, ~final_state L s2 r) -> False.
Proof.
  intros.
  assert (t1 = t2 /\ s1 = s2).
    eapply steps_deterministic; eauto. eapply det_final_nostep; eauto.
  destruct H4; subst. elim (H3 _ H0).
Qed.

(** Determinism for infinite transition sequences. *)

Lemma star_final_not_forever_silent:
  forall s t s', Star L s t s' ->
  Nostep L s' ->
  Forever_silent L s -> False.
Proof.
  induction 1; intros.
  inv H0. use_nostep.
  inv H3. use_step_deterministic. eauto.
Qed.

Lemma star2_final_not_forever_silent:
  forall s t1 s1 t2 s2,
  Star L s t1 s1 -> Nostep L s1 ->
  Star L s t2 s2 -> Forever_silent L s2 ->
  False.
Proof.
  intros. use_star_step_triangle.
  eapply star_final_not_forever_silent. eexact P. eauto. auto.
Qed.

Lemma star_final_not_forever_reactive:
  forall s t s', Star L s t s' ->
  forall T, Nostep L s' -> Forever_reactive L s T -> False.
Proof.
  induction 1; intros.
  inv H0. inv H1. congruence. use_nostep.
  inv H3. inv H4. congruence.
  use_step_deterministic.
  eapply IHstar with (T := t4 *** T0). eauto.
  eapply star_forever_reactive; eauto.
Qed.

Lemma star_forever_silent_inv:
  forall s t s', Star L s t s' ->
  Forever_silent L s ->
  t = E0 /\ Forever_silent L s'.
Proof.
  induction 1; intros.
  auto.
  subst. inv H2. use_step_deterministic. eauto.
Qed.

Lemma forever_silent_reactive_exclusive:
  forall s T,
  Forever_silent L s -> Forever_reactive L s T -> False.
Proof.
  intros. inv H0. exploit star_forever_silent_inv; eauto.
  intros [A B]. contradiction.
Qed.

Lemma forever_reactive_inv2:
  forall s t1 s1, Star L s t1 s1 ->
  forall t2 s2 T1 T2,
  Star L s t2 s2 ->
  t1 <> E0 -> t2 <> E0 ->
  Forever_reactive L s1 T1 ->
  Forever_reactive L s2 T2 ->
  exists s', exists t, exists T1', exists T2',
  t <> E0 /\
  Forever_reactive L s' T1' /\
  Forever_reactive L s' T2' /\
  t1 *** T1 = t *** T1' /\
  t2 *** T2 = t *** T2'.
Proof.
  induction 1; intros.
  congruence.
  inv H2. congruence. use_step_deterministic.
  destruct t3.
  (* inductive case *)
  simpl in *. eapply IHstar; eauto.
  (* base case *)
  exists s5; exists (e :: t3);
  exists (t2 *** T1); exists (t4 *** T2).
  split. unfold E0; congruence.
  split. eapply star_forever_reactive; eauto.
  split. eapply star_forever_reactive; eauto.
  split; traceEq.
Qed.

Lemma forever_reactive_determ':
  forall s T1 T2,
  Forever_reactive L s T1 ->
  Forever_reactive L s T2 ->
  traceinf_sim' T1 T2.
Proof.
  cofix COINDHYP; intros.
  inv H. inv H0.
  destruct (forever_reactive_inv2 _ _ _ H t s2 T0 T)
  as [s' [t' [T1' [T2' [A [B [C [D E]]]]]]]]; auto.
  rewrite D; rewrite E. constructor. auto.
  eapply COINDHYP; eauto.
Qed.

Lemma forever_reactive_determ:
  forall s T1 T2,
  Forever_reactive L s T1 ->
  Forever_reactive L s T2 ->
  traceinf_sim T1 T2.
Proof.
  intros. apply traceinf_sim'_sim. eapply forever_reactive_determ'; eauto.
Qed.

Lemma star_forever_reactive_inv:
  forall s t s', Star L s t s' ->
  forall T, Forever_reactive L s T ->
  exists T', Forever_reactive L s' T' /\ T = t *** T'.
Proof.
  induction 1; intros.
  exists T; auto.
  inv H2. inv H3. congruence.
  use_step_deterministic.
  exploit IHstar. eapply star_forever_reactive. 2: eauto. eauto.
  intros [T' [A B]]. exists T'; intuition. traceEq. congruence.
Qed.

Lemma forever_silent_reactive_exclusive2:
  forall s t s' T,
  Star L s t s' -> Forever_silent L s' ->
  Forever_reactive L s T ->
  False.
Proof.
  intros. exploit star_forever_reactive_inv; eauto.
  intros [T' [A B]]. subst T.
  eapply forever_silent_reactive_exclusive; eauto.
Qed.

(** Determinism for program executions *)

Definition same_behaviors (beh1 beh2: program_behavior) : Prop :=
  match beh1, beh2 with
  | Terminates t1 r1, Terminates t2 r2 => t1 = t2 /\ r1 = r2
  | Diverges t1, Diverges t2 => t1 = t2
  | Reacts t1, Reacts t2 => traceinf_sim t1 t2
  | Goes_wrong t1, Goes_wrong t2 => t1 = t2
  | _, _ => False
  end.

Lemma state_behaves_deterministic:
  forall s beh1 beh2,
  state_behaves L s beh1 -> state_behaves L s beh2 -> same_behaviors beh1 beh2.
Proof.
  generalize (det_final_nostep L DET); intro dfns.
  intros until beh2; intros BEH1 BEH2.
  inv BEH1; inv BEH2; red.
(* terminates, terminates *)
  assert (t = t0 /\ s' = s'0). eapply steps_deterministic; eauto.
  destruct H3. split; auto. subst. eapply det_final_state; eauto.
(* terminates, diverges *)
  eapply star2_final_not_forever_silent with (s1 := s') (s2 := s'0); eauto.
(* terminates, reacts *)
  eapply star_final_not_forever_reactive; eauto.
(* terminates, goes_wrong *)
  eapply terminates_not_goes_wrong with (s1 := s') (s2 := s'0); eauto.
(* diverges, terminates *)
  eapply star2_final_not_forever_silent with (s2 := s') (s1 := s'0); eauto.
(* diverges, diverges *)
  use_star_step_diamond.
  exploit star_forever_silent_inv. eexact P. eauto.
  intros [A B]. subst; traceEq.
  exploit star_forever_silent_inv. eexact P. eauto.
  intros [A B]. subst; traceEq.
(* diverges, reacts *)
  eapply forever_silent_reactive_exclusive2; eauto.
(* diverges, goes wrong *)
  eapply star2_final_not_forever_silent with (s1 := s'0) (s2 := s'); eauto.
(* reacts, terminates *)
  eapply star_final_not_forever_reactive; eauto.
(* reacts, diverges *)
  eapply forever_silent_reactive_exclusive2; eauto.
(* reacts, reacts *)
  eapply forever_reactive_determ; eauto.
(* reacts, goes wrong *)
  eapply star_final_not_forever_reactive; eauto.
(* goes wrong, terminate *)
  eapply terminates_not_goes_wrong with (s1 := s'0) (s2 := s'); eauto.
(* goes wrong, diverges *)
  eapply star2_final_not_forever_silent with (s1 := s') (s2 := s'0); eauto.
(* goes wrong, reacts *)
  eapply star_final_not_forever_reactive; eauto.
(* goes wrong, goes wrong *)
  assert (t = t0 /\ s' = s'0). eapply steps_deterministic; eauto.
  tauto.
Qed.

Theorem program_behaves_deterministic:
  forall beh1 beh2,
  program_behaves L beh1 -> program_behaves L beh2 ->
  same_behaviors beh1 beh2.
Proof.
  intros until beh2; intros BEH1 BEH2. inv BEH1; inv BEH2.
(* both initial states defined *)
  assert (s = s0) by (eapply det_initial_state; eauto). subst s0.
  eapply state_behaves_deterministic; eauto.
(* one initial state defined, the other undefined *)
  elim (H1 _ H).
  elim (H _ H0).
(* both initial states undefined *)
  red; auto.
Qed.

End DETERM_SEM.

(** * Integrating an external world in a semantics. *)

(** Given a transition semantics, we can build another semantics that
  integrates an external world in its state and allows only world-possible
  transitions. *)

Section WORLD_SEM.

Variable L: semantics.
Variable initial_world: world.

Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.
Local Open Scope pair_scope.

Definition world_sem : semantics := @Semantics_gen
  (state L * world)%type
  (genvtype L)
  (fun ge s t s' => step L ge s#1 t s'#1 /\ possible_trace s#2 t s'#2)
  (fun s => initial_state L s#1 /\ s#2 = initial_world)
  (fun s r => final_state L s#1 r)
  (globalenv L)
  (symbolenv L).

(** If the original semantics is determinate, the world-aware semantics is deterministic. *)

Hypothesis D: determinate L.

Theorem world_sem_deterministic: sem_deterministic world_sem.
Proof.
  constructor; simpl; intros.
(* steps *)
  destruct H; destruct H0.
  exploit (sd_determ D). eexact H. eexact H0. intros [A B].
  exploit match_possible_traces; eauto. intros [EQ1 EQ2]. subst t2.
  split; auto.
  rewrite (surjective_pairing s1). rewrite (surjective_pairing s2). intuition congruence.
(* initial states *)
  destruct H; destruct H0.
  rewrite (surjective_pairing s1). rewrite (surjective_pairing s2). decEq.
  eapply (sd_initial_determ D); eauto.
  congruence.
(* final states *)
  eapply (sd_final_determ D); eauto.
(* final no step *)
  red; simpl; intros. red; intros [A B]. exploit (sd_final_nostep D); eauto.
Qed.

End WORLD_SEM.


From iris.base_logic Require Import invariants.
(* From iris.bi Require Import ascii. *)
From iris.algebra Require Import ofe cmra frac agree gmap.

Definition fractionalR (o : ofeT) : cmraT := prodR fracR (agreeR (leibnizO o)).
Lemma fractional_op A p q (rv : agreeR (leibnizO A)) :
  (p, rv) ⋅ (q, rv) ≡ ((p + q)%Qp, rv).
Proof. by rewrite -pair_op agree_idemp. Qed.

Section sec.
Context {A : ofeT} `{!inG Σ (fractionalR A)}.

Lemma own_fractional_sep γ p q (rv : agreeR (leibnizO A)) :
  own γ ((p + q)%Qp, rv) ⊣⊢
  own γ (p, rv) ∗ own γ (q, rv).
Proof. by rewrite -own_op fractional_op. Qed.
End sec.

(* Copied from Iris [gmap], I don't have it in my old version. *)
Lemma singleton_op `{Countable K} {A : cmraT} (i : K) (x y : A) :
  {[ i := x ]} ⋅ {[ i := y ]} =@{gmap K A} {[ i := x ⋅ y ]}.
Proof. by apply (merge_singleton _ _ _ x y). Qed.

Section sec.
Context {A : ofeT} `{Countable L} `{!inG Σ (gmapR L (fractionalR A))}.

Definition frac_pack (a : L) (p : frac) (rv : agreeR A)  :=
  singletonM (K := L) (M := gmap L (fractionalR _)) a (p, rv).

Lemma frac_pack_op p q (rv : agreeR (leibnizO A)) (a : L) :
  frac_pack a (p + q) rv ≡ frac_pack a p rv ⋅ frac_pack a q rv.
Proof. by rewrite /frac_pack -fractional_op singleton_op. Qed.

Lemma own_frac_pack_sep γ p q (rv : agreeR (leibnizO A)) (a : L) :
  own γ (frac_pack a (p + q)%Qp rv) ⊣⊢
  own γ (frac_pack a p rv) ∗ own γ (frac_pack a q rv).
Proof. by rewrite -own_op frac_pack_op. Qed.
End sec.


(** * bordernode_fun.v : Functional Model of BorderNode*)
Require Import VST.floyd.functional_base.
Require Import DB.common.
Require Import DB.tactics.
Require Import DB.functional.keyslice.
Require Import DB.functional.key.

(* For now, client values are well-distinguished, therefore option type should be fine *)
(* However, internal nodes are only distinguishable by nullptr *)

Module BorderNode.
  Section Parametrized.
    (* [ext_value] are the values for clients, [int_value] are the values for internal nodes *)
    Context {ext_value int_value: Type}.
    Definition table: Type := list (option ext_value) * (option ((string * ext_value) + int_value)).
    Definition empty: table := (list_repeat (Z.to_nat keyslice_length) None, None).

    Instance inh_option_ext_value: Inhabitant (option ext_value) := None.

    Definition put_prefix (k: Z) (v: ext_value) (t: table): table :=
      match t with
      | (prefixes, suffix) =>
        (upd_Znth (k - 1) prefixes (Some v), suffix)
      end.

    Definition get_prefix (k: Z) (t: table): option ext_value :=
      match t with
      | (prefixes, _) => Znth (k - 1) prefixes
      end.

    Definition put_suffix (k: string) (v: ext_value) (t: table): table :=
      match t with
      | (prefixes, _) =>
        (prefixes, Some (inl (k, v)))
      end.

    Definition get_suffix (k: string) (t: table): option ext_value :=
      match t with
      | (_, Some (inl (k', v))) =>
        if eq_dec k k' then Some v else None
      | _ => None
      end.

    Definition put_link (v: int_value) (t: table): table :=
      match t with
      | (prefixes, _) =>
        (prefixes, Some (inr v))
      end.

    Definition get_link (t: table): option int_value :=
      match t with
      | (prefixes, Some (inr v)) =>
        Some v
      | _ => None
      end.

    Definition test_suffix (k: string) (t: table): bool :=
      match t with
      | (_, Some (inl (k', v))) =>
        if eq_dec k k' then true else false
      | _ => false
      end.

    Definition get_suffix_pair (t: table): option (string * ext_value) :=
      match t with
      | (_, Some (inl (k, v))) => Some (k, v)
      | _ => None
      end.

    Definition is_link (t: table): bool :=
      match t with
      | (_, Some (inr _)) => true
      | _ => false
      end.

    Definition put_value (key: string) (v: ext_value) (t: table): table :=
      if (Z_le_dec (Zlength key) keyslice_length) then
        put_prefix (Zlength key) v t
      else
        put_suffix (keyslice.get_suffix key) v t.

    Definition invariant (t: table) := Zlength (fst t) = keyslice_length.
    (* This is not a complete invariant:
     * if a bordernode associate with keyslice 'abcdefgh', then all of the prefix field should be empty *)

    Lemma empty_invariant: invariant empty.
    Proof.
      unfold invariant.
      simpl.
      rewrite Zlength_list_repeat; rep_lia.
    Qed.

    Lemma get_prefix_empty: forall k,
        0 < k <= keyslice_length -> get_prefix k empty = None.
    Proof.
      intros.
      simpl.
      rewrite Znth_list_repeat_inrange by rep_lia.
      reflexivity.
    Qed.

    Lemma get_suffix_empty: forall k,
        get_suffix k empty = None.
    Proof.
      intros.
      simpl.
      reflexivity.
    Qed.

    Lemma put_prefix_invariant: forall k v t,
        invariant t -> 0 < k <= keyslice_length -> invariant (put_prefix k v t).
    Proof.
      intros.
      destruct t as [].
      unfold invariant in *.
      simpl in *.
      rewrite upd_Znth_Zlength by list_solve.
      assumption.
    Qed.

    Lemma put_suffix_invariant: forall k v t,
        invariant t -> invariant (put_suffix k v t).
    Proof.
      intros.
      destruct t as [].
      unfold invariant in *.
      simpl in *.
      assumption.
    Qed.

    Lemma get_put_prefix_same: forall k v t,
        invariant t -> 0 < k <= keyslice_length -> get_prefix k (put_prefix k v t) = Some v.
    Proof.
      intros.
      destruct t as [].
      unfold invariant in *.
      simpl in *.
      rewrite upd_Znth_same by list_solve.
      reflexivity.
    Qed.

    Lemma get_put_prefix_diff: forall k1 k2 v t,
        invariant t -> 0 < k1 <= keyslice_length -> 0 < k2 <= keyslice_length -> k1 <> k2 ->
        get_prefix k1 (put_prefix k2 v t) = get_prefix k1 t.
    Proof.
      intros.
      destruct t as [].
      unfold invariant in *.
      simpl in *.
      rewrite upd_Znth_diff by list_solve.
      reflexivity.
    Qed.

    Lemma get_put_suffix_same: forall k v t,
        get_suffix k (put_suffix k v t) = Some v.
    Proof.
      intros.
      destruct t as [].
      simpl.
      rewrite if_true by auto.
      reflexivity.
    Qed.

    Lemma get_put_suffix_diff: forall k1 k2 v t,
        k1 <> k2 -> get_suffix k1 (put_suffix k2 v t) = None.
    Proof.
      intros.
      destruct t as [].
      simpl.
      rewrite if_false by auto.
      reflexivity.
    Qed.

    Lemma get_put_suffix_pair_same: forall k v t,
        get_suffix_pair (put_suffix k v t) = Some (k, v).
    Proof.
      intros.
      destruct t as [].
      simpl.
      reflexivity.
    Qed.

    Lemma put_permute: forall k1 k2 v1 v2 t,
        put_prefix k1 v1 (put_suffix k2 v2 t) = put_suffix k2 v2 (put_prefix k1 v1 t).
    Proof.
      intros.
      destruct t as [].
      reflexivity.
    Qed.

    Lemma put_permute': forall k1 k2 v1 v2 t,
        0 < k1 <= keyslice_length ->
        0 < k2 <= keyslice_length ->
        invariant t ->
        k1 <> k2 ->
        put_prefix k1 v1 (put_prefix k2 v2 t) = put_prefix k2 v2 (put_prefix k1 v1 t).
    Proof.
      intros.
      destruct t as [].
      simpl.
      f_equal.
      f_equal.
    Abort.

    Lemma get_put_non_interference1: forall k1 k2 v t,
        get_prefix k1 (put_suffix k2 v t) = get_prefix k1 t.
    Proof.
      intros.
      destruct t as []; reflexivity.
    Qed.

    Lemma get_put_non_interference2: forall k1 k2 v t,
        get_suffix k1 (put_prefix k2 v t) = get_suffix k1 t.
    Proof.
      intros.
      destruct t as []; reflexivity.
    Qed.

    Hint Rewrite get_put_prefix_same: bordernode.
    Hint Rewrite get_put_prefix_diff: bordernode.
    Hint Rewrite get_put_prefix_same: bordernode.
    Hint Rewrite get_put_suffix_diff: bordernode.
    Hint Rewrite get_put_non_interference1: bordernode.
    Hint Rewrite get_put_non_interference2: bordernode.

    (* extra definitions and lemmas for cursor *)

    Inductive cursor: Type :=
    | before_prefix: Z -> cursor
    | before_suffix: cursor
    | after_suffix: cursor.

    (* for this function, [after_suffix] actually means a fail *)
    Fixpoint next_cursor' (bnode_cursor: cursor) (bnode: table) (n: nat) :=
      match n with
      | S n' =>
        match bnode_cursor with
        | before_prefix len =>
          if (get_prefix len bnode) then
            before_prefix len
          else
            if Z_lt_dec len keyslice_length then
              next_cursor' (before_prefix (len + 1)) bnode n'
            else
              next_cursor' before_suffix bnode n'
        | before_suffix =>
          if (snd bnode) then
            before_suffix
          else
            after_suffix
        | after_suffix => after_suffix
        end
      | O => after_suffix
      end.

    Definition next_cursor (bnode_cursor: cursor) (bnode: table) :=
      next_cursor' bnode_cursor bnode (Z.to_nat (keyslice_length + 2)).

    Definition first_cursor (bnode: table) :=
      next_cursor (before_prefix 1) bnode.

    Definition cursor_correct (bnode_cursor: cursor): Prop :=
      match bnode_cursor with
      | before_prefix len => 0 < len <= keyslice_length
      | _ => True
      end.

    Lemma next_cursor_prefix_correct': forall bnode_cursor bnode len n,
        next_cursor' bnode_cursor bnode n = before_prefix len ->
        get_prefix len bnode <> None.
    Proof.
      intros.
      generalize dependent bnode_cursor.
      induction n; intros.
      - inv H.
      - simpl in H.
        destruct bnode_cursor.
        + if_tac Heqn in H.
          * congruence.
          * if_tac in H; eauto.
        + destruct (snd bnode); congruence.
        + congruence.
    Qed.

    Lemma next_cursor_prefix_correct: forall bnode_cursor bnode len,
        next_cursor bnode_cursor bnode = before_prefix len ->
        get_prefix len bnode <> None.
    Proof.
      intros.
      eapply next_cursor_prefix_correct'; eauto.
    Qed.

    Lemma next_cursor_suffix_correct': forall bnode_cursor bnode n,
        next_cursor' bnode_cursor bnode n = before_suffix ->
        snd bnode <> None.
    Proof.
      intros.
      generalize dependent bnode_cursor.
      induction n; intros.
      - inv H.
      - simpl in H.
        destruct bnode_cursor.
        + if_tac in H; try congruence.
          if_tac in H.
          * apply IHn in H.
            assumption.
          * destruct n; simpl in H; try congruence.
            if_tac in H; congruence.
        + if_tac in H; congruence.
        + congruence.
    Qed.

    Lemma next_cursor_suffix_correct: forall bnode_cursor bnode,
        next_cursor bnode_cursor bnode = before_suffix ->
        snd bnode <> None.
    Proof.
      intros.
      eapply next_cursor_suffix_correct'; eauto.
    Qed.

    Lemma next_cursor_idempotent: forall bnode_cursor bnode_cursor' bnode,
        next_cursor bnode_cursor bnode = bnode_cursor' ->
        next_cursor bnode_cursor' bnode = bnode_cursor'.
    Proof.
      intros.
      unfold next_cursor in *.
      remember (Z.to_nat (keyslice_length + 2)).
      clear Heqn.
      destruct n.
      - simpl in H.
        simpl.
        congruence.
      - simpl in *. subst.
        destruct bnode_cursor; simpl.
        + repeat first [if_tac | match_tac];
            repeat match goal with
            | H: next_cursor' _ bnode _ = before_prefix _ |- _ => apply next_cursor_prefix_correct' in H
            | H: next_cursor' _ bnode _ = before_suffix |- _ => apply next_cursor_suffix_correct' in H
            end; try first [congruence | eauto].
        + if_tac; reflexivity.
        + reflexivity.
    Qed.

    Lemma next_cursor_bnode_correct: forall bnode_cursor bnode,
        cursor_correct bnode_cursor ->
        cursor_correct (next_cursor bnode_cursor bnode).
    Proof.
      intros.
      generalize dependent bnode.
      generalize dependent bnode_cursor.
      unfold next_cursor.
      remember (Z.to_nat (keyslice_length + 2)).
      clear Heqn.
      induction n; intros.
      - firstorder.
      - simpl.
        destruct bnode_cursor.
        + repeat if_tac.
          * assumption.
          * apply IHn.
            simpl.
            simpl in H.
            lia.
          * apply IHn.
            constructor.
        + if_tac; auto.
        + auto.
    Qed.

    Lemma next_cursor_terminate: forall len bnode v,
        0 < len <= keyslice_length ->
        invariant bnode ->
        next_cursor (before_prefix len) (put_prefix len v bnode) = before_prefix len.
    Proof.
      intros.
      unfold next_cursor.
      assert (Z.to_nat (keyslice_length + 2) > 0)%nat. {
        rewrite <- Nat2Z.id.
        apply Z2Nat.inj_lt; rep_lia.
      }
      destruct (Z.to_nat (keyslice_length + 2)).
      - lia.
      - simpl.
        destruct bnode as [].
        unfold get_prefix, put_prefix, invariant in *.
        simpl in *.
        rewrite upd_Znth_same by rep_lia.
        congruence.
    Qed.

    Lemma next_cursor_terminate_permute1: forall len1 len2 bnode v,
        0 < len1 <= keyslice_length ->
        0 < len2 <= keyslice_length ->
        len1 <> len2 ->
        invariant bnode ->
        next_cursor (before_prefix len1) bnode = before_prefix len1 ->
        next_cursor (before_prefix len1) (put_prefix len2 v bnode) = before_prefix len1.
    Proof.
      intros.
      pose proof (next_cursor_prefix_correct _ _ _ H3).
      unfold next_cursor.
      assert (Z.to_nat (keyslice_length + 2) > 0)%nat. {
        rewrite <- Nat2Z.id.
        apply Z2Nat.inj_lt; rep_lia.
      }
      destruct (Z.to_nat (keyslice_length + 2)).
      - lia.
      - simpl.
        destruct bnode as [].
        unfold get_prefix, put_prefix, invariant in *.
        simpl in *.
        rewrite upd_Znth_diff by rep_lia.
        if_tac; congruence.
    Qed.

    Lemma next_cursor_terminate_permute2: forall len bnode k v,
        0 < len <= keyslice_length ->
        invariant bnode ->
        next_cursor (before_prefix len) bnode = before_prefix len ->
        next_cursor (before_prefix len) (put_suffix k v bnode) = before_prefix len.
    Proof.
      intros.
      pose proof (next_cursor_prefix_correct _ _ _ H1).
      unfold next_cursor.
      assert (Z.to_nat (keyslice_length + 2) > 0)%nat. {
        rewrite <- Nat2Z.id.
        apply Z2Nat.inj_lt; rep_lia.
      }
      destruct (Z.to_nat (keyslice_length + 2)).
      - lia.
      - simpl.
        destruct bnode as [].
        unfold get_prefix, put_prefix, invariant in *.
        simpl in *.
        if_tac; congruence.
    Qed.

    Definition length_to_cursor (len: Z): cursor :=
      if Z_le_dec len keyslice_length then
        before_prefix len
      else
        before_suffix.

    Definition cursor_to_int (c: cursor): Z :=
      match c with
      | before_prefix len => len
      | before_suffix => keyslice_length + 1
      | after_suffix => keyslice_length + 2
      end.

  End Parametrized.

  Arguments table: clear implicits.
End BorderNode.


Require Import Coq.Strings.String.
Require Import Psatz.

Require Export SystemFR.Syntax.
Require Export SystemFR.Tactics.
Require Export SystemFR.AssocList.

Require Export SystemFR.ListUtils.

Require Export SystemFR.WFLemmas.

Open Scope string_scope.
Open Scope list_scope.

Lemma wf_close:
  forall t k x,
    wf t k ->
    wf (close k t x) (S k).
Proof.
  induction t; steps.
Qed.

Lemma wf_tclose:
  forall t i j x,
    wf t i ->
    wf (tclose j t x) i.
Proof.
  induction t; steps.
Qed.

Lemma twf_tclose:
  forall T k X,
    twf T k ->
    twf (tclose k T X) (S k).
Proof.
  induction T; steps.
Qed.

Lemma twf_close:
  forall t i j x,
    twf t i ->
    twf (close j t x) i.
Proof.
  induction t; steps.
Qed.

#[global]
Hint Resolve wf_close: wf.
#[global]
Hint Resolve twf_tclose: twf.
#[global]
Hint Resolve wf_tclose: wf.
#[global]
Hint Resolve twf_close: twf.


Require Export Iron.Language.SystemF2Data.Exp.
Require Export Iron.Language.SystemF2Data.Step.Context.
Require Export Iron.Language.SystemF2Data.Step.Prim.

(********************************************************************)
(** * Single Small Step Evaluation *)
(** The single step rules model the individual transitions that the
     machine can make at runtime. *)
Inductive STEP : exp -> exp -> Prop :=
 (* Step some sub-expression in an evaluation context *)
 | EsContext
   :  forall C x x'
   ,  exp_ctx C
   -> STEP x x'
   -> STEP (C x) (C x')

 (* Function application. *)
 | EsLamApp
   : forall t11 x12 v2
   ,  wnfX v2
   -> STEP (XApp   (XLam t11 x12) v2)
           (substXX 0 v2 x12)

 (* Type application. *)
 | EsLAMAPP
   :  forall x12 t2
   ,  STEP (XAPP (XLAM x12) t2)
           (substTX 0 t2 x12)

 (* Case branching. *)
 | EsCaseAlt
   :  forall dc ts vs alts x
   ,  Forall wnfX vs
   -> getAlt dc alts = Some (AAlt dc x)
   -> STEP (XCase (XCon dc ts vs) alts)
           (substXXs 0 vs x)

 (* Primitives. *)
 | EsPrim
   :  forall p vs vResult
   ,  Forall wnfX vs
   -> stepPrim p vs = Some vResult
   -> STEP (XPrim p vs) vResult.

Hint Constructors STEP.

(********************************************************************)
(* Stepping a wnf doesn't change it. *)
Lemma step_wnfX
 :  forall x v
 ,  wnfX x -> STEP x v -> v = x.
Proof.
 intros x v HW HS.
 induction HS; nope.

 - Case "Step in context".
   destruct H; auto; nope.

   + SCase "XCon".
     inverts HW.
     have (wnfX x)
      by (eapply exps_ctx_Forall; eauto).
     have (x' = x).
     subst. auto.
Qed.

(********************************************************************)
Lemma step_context_XPrim_exists
 :  forall C x p
 ,  exps_ctx wnfX C
 -> (exists x', STEP x x')
 -> (exists x', STEP (XPrim p (C x)) (XPrim p (C x'))).
Proof.
 intros C x p HC HS.
 shift x'.
 eapply (EsContext (fun xx => XPrim p (C xx))); auto.
Qed.

Lemma step_context_XCon_exists
 :  forall C x dc ts
 ,  exps_ctx wnfX C
 -> (exists x', STEP x x')
 -> (exists x', STEP (XCon dc ts (C x)) (XCon dc ts (C x'))).
Proof.
 intros C x dc ts HC HS.
 shift x'.
 eapply (EsContext (fun xx => XCon dc ts (C xx))); auto.
Qed.


Require Import Eqdep_dec Setoid Bool List Quote.
Require Export ZArith Qcanon.
Close Scope Qc_scope.
Open Scope lazy_bool_scope.

Lemma bdiscr : forall P, false = true -> P.
Proof. intros; discriminate. Qed.

(** * Different kinds of arithmetic that we handle *)
Inductive arith_domain : Set :=
| DomainNat
| DomainN
| DomainPos
| DomainZ
| DomainQ.

Definition dom_interp (d : arith_domain) : Set :=
  match d with
    | DomainNat => nat
    | DomainN => N
    | DomainPos => positive
    | DomainZ => Z
    | DomainQ => Qc
  end.
Definition dom_equal (d d' : arith_domain) : bool :=
  match d, d' with
    | DomainNat, DomainNat => true
    | DomainN, DomainN => true
    | DomainPos, DomainPos => true
    | DomainZ, DomainZ => true
    | DomainQ, DomainQ => true
    | _, _ => false
  end.

(** * Reification of types *)
Inductive type : Set :=
| typeCst (tidx : index)
| typeDefault
| typeArith (dom : arith_domain)
| typeArrow (_ _ : type).
Definition typeUnop dom :=
  typeArrow (typeArith dom) (typeArith dom).
Definition typeBinop dom :=
  typeArrow (typeArith dom) (typeArrow (typeArith dom) (typeArith dom)).

Section TInterp.
  Definition type_env := varmap Type.
  Variable vtypes : type_env.

  Inductive dummy : Set := mk_dummy.

  Fixpoint tinterp (t : type) : Type :=
    match t with
      | typeCst idx => varmap_find Set idx vtypes
      | typeDefault => dummy
      | typeArith d =>  dom_interp d
      | typeArrow t1 t2 => (tinterp t1) -> (tinterp t2)
    end.
End TInterp.

Fixpoint tequal (t t' : type) : bool :=
  match t, t' with
    | typeCst tidx, typeCst tidx' => index_eq tidx tidx'
    | typeDefault, typeDefault => true
    | typeArith dom, typeArith dom' =>  dom_equal dom dom'
    | typeArrow t1 t2, typeArrow t'1 t'2 =>
      tequal t1 t'1 &&& tequal t2 t'2
    | _, _ => false
  end.

Property tequal_1 : forall t t', tequal t t' = true -> t = t'.
Proof.
  cut (forall i i', index_eq i i' = true -> i = i').
  intro cut; induction t; destruct t'; simpl; intro; try discriminate.
  rewrite (cut _ _ H); reflexivity.
  reflexivity.
  destruct dom; destruct dom0; try discriminate H; reflexivity.
  assert (IH1 := IHt1 t'1); clear IHt1.
  assert (IH2 := IHt2 t'2); clear IHt2.
  destruct (tequal t1 t'1); simpl in H.
  rewrite IH1, IH2; auto.
  exact (bdiscr _ H).
  induction i; destruct i'; intro H; try (exact (bdiscr _ H)).
  rewrite (IHi _ H); reflexivity.
  rewrite (IHi _ H); reflexivity.
  reflexivity.
Defined.
Property tequal_2 : forall t t', t = t' -> tequal t t' = true.
Proof.
  intros t t' H; subst; induction t'; simpl.
  induction tidx; simpl; auto.
  reflexivity. destruct dom; reflexivity.
  apply andb_true_intro; auto.
Qed.
Corollary tequal_iff : forall t t', tequal t t' = true <-> t = t'.
Proof.
  intros t t'; split; intro H; [apply tequal_1 | apply tequal_2]; auto.
Qed.
Corollary type_dec : forall (t t' : type), {t = t'} + {~(t = t')}.
Proof.
  intros t t'; case_eq (tequal t t'); intro Heq; [left | right].
  apply tequal_1; auto.
  intro abs; rewrite (tequal_2 _ _ abs) in Heq; discriminate.
Qed.

(** * Terms *)
Inductive arithop : Set :=
| Plus | Minus | Opp | Mult | Div.
Inductive symbol : Set :=
| Unint (ty_idx t_idx : index) (* uninterpreted symbol *)
| Cst (dom : arith_domain) (z : dom_interp dom) (* arithmetic constant *)
| Op (dom : arith_domain) (op : arithop). (* arithmetic operations *)

Definition mk_symbol ty_idx t_idx : symbol := Unint ty_idx t_idx.

Inductive term : Set :=
| app (f : symbol) (lt : list term).
Notation terms := (list term).
Notation tnil := (@nil term).
Notation tcons := (@cons term).

Section TermInduction.
  Variable P : term -> Type.
  Variable P0 : terms -> Type.
  Variable Hlift : forall (f : symbol) (lt : terms), P0 lt -> P (app f lt).
  Variable Hnil : P0 tnil.
  Variable Hcons :
    forall (t : term), P t -> forall (lt : terms), P0 lt -> P0 (tcons t lt).

  Fixpoint term_terms_rect (t : term) : P t :=
    match t as T return P T with
      | app f l =>
        Hlift f l
        ((fix aux (l : terms) : P0 l :=
          match l as L return P0 L with
            | nil => Hnil
            | cons a q => Hcons a (term_terms_rect a) q (aux q)
          end) l)
    end.
End TermInduction.

Definition arithop_equal (o o' : arithop) : bool :=
  match o, o' with
    | Plus, Plus => true
    | Minus, Minus => true
    | Opp, Opp => true
    | Mult, Mult => true
    | Div, Div => true
    | _, _ => false
  end.
Definition cst_equal (d d' : arith_domain) :=
  match d as a, d' as b
    return dom_interp a -> dom_interp b -> bool with
    | DomainNat, DomainNat => beq_nat
    | DomainPos, DomainPos =>
      fun p p' => match Pcompare p p' Eq with Eq => true | _ => false end
    | DomainN, DomainN => N.eqb
    | DomainZ, DomainZ => Z.eqb
    | DomainQ, DomainQ => Qc_eq_bool
    | _, _ => fun  _ _ => false
  end.
Definition symbol_equal (f g : symbol) : bool :=
  match f, g with
    | Unint ty_idx s_idx, Unint ty_idx' s_idx' =>
      index_eq ty_idx ty_idx' &&& index_eq s_idx s_idx'
    | Cst d z, Cst d' z' => cst_equal d d' z z'
    | Op d o, Op d' o' => dom_equal d d' &&& arithop_equal o o'
    | _, _ => false
  end.
Fixpoint term_equal (u v : term) : bool :=
  match u, v with
    | app f l, app g l' =>
      if symbol_equal f g then
        (fix terms_equal l l' : bool :=
          match l, l' with
            | nil, nil => true
            | nil, _ | _, nil => false
            | t::q, t'::q' =>
              if term_equal t t' then terms_equal q q' else false
          end) l l'
        else false
  end.
Axiom term_equal_1 : forall u v, term_equal u v = true -> u = v.
Axiom term_equal_2 : forall u v, term_equal u v = false -> u <> v.

Section Interp.
  Variable vtypes : type_env.
  Notation "[| type |]" := (tinterp vtypes type).

  Definition depvarmap := {t : type & ([|t|] * varmap [|t|])%type}.
  Definition mk_depvmap (ty : type) (c : [|ty|]) (v : varmap [|ty|])
    : depvarmap := existT _ ty (c, v).
  Definition term_env := varmap depvarmap.
  Variable v : term_env.
(*   Variable qvars : varmap Z. *)

  Definition lookup_type (f : symbol) : type :=
    match f with
      | Unint ty_idx _ =>
        projT1 (varmap_find
          (existT _ typeDefault (mk_dummy, @Empty_vm dummy)) ty_idx v)
      | Cst d _ => typeArith d
      | Op d (Plus | Minus | Mult | Div) => typeBinop d
      | Op d Opp => typeUnop d
    end.
  Definition interp_op (d : arith_domain) (o : arithop)
    : [| lookup_type (Op d o) |] :=
    match d, o with
      (* nat arith : plus, mult are interpreted *)
      | DomainNat, Plus => plus
      | DomainNat, Mult => mult
      | DomainNat, Minus => fun _ _ => 0%nat
      | DomainNat, Div => fun _ _ => O%nat
      | DomainNat, Opp => fun _ => O%nat
      (* N arith : plus, mult are interpreted *)
      | DomainN, Plus => Nplus
      | DomainN, Mult => Nmult
      | DomainN, Minus => fun _ _ => N0
      | DomainN, Div => fun _ _ => N0
      | DomainN, Opp => fun _ => N0
      (* pos arith : plus, mult are interpreted *)
      | DomainPos, Plus => Pplus
      | DomainPos, Mult => Pmult
      | DomainPos, Minus => fun _ _ => xH
      | DomainPos, Div => fun _ _ => xH
      | DomainPos, Opp => fun _ => xH
      (* Z arith : plus, mult, opp, minus are interpreted *)
      | DomainZ, Plus => Zplus
      | DomainZ, Mult => Zmult
      | DomainZ, Minus => Zminus
      | DomainZ, Div => Zdiv
      | DomainZ, Opp => Zopp
      (* Q arith : plus, mult, opp, minus, div are interpreted *)
      | DomainQ, Plus => Qcplus
      | DomainQ, Mult => Qcmult
      | DomainQ, Minus => Qcminus
      | DomainQ, Div => Qcdiv
      | DomainQ, Opp => Qcopp
    end.
  Definition lookup (f : symbol) : [| lookup_type f |] :=
    match f with
      | Unint ty_idx s_idx =>
        let (d, vs) :=
          projT2 (varmap_find
            (existT _ typeDefault (mk_dummy, @Empty_vm dummy)) ty_idx v) in
          varmap_find d s_idx vs
      | Cst d q => q
(*       | Var v_idx => varmap_find 0%Z v_idx qvars *)
      | Op d op => interp_op d op
    end.

(*   Require Import Nfix. *)
(*   Nested Fixpoint type_of (t : term) : type := *)
(*     match t with *)
(*       | app f l => types_of l (lookup_type f) *)
(*     end *)
(*   with types_of (l : terms) (ret : type) : type := *)
(*     match l with *)
(*       | nil => ret *)
(*       | cons _ l => *)
(*         match ret with *)
(*           | typeArrow _ t2 => types_of l t2 *)
(*           | _ => typeDefault (* absurd *) *)
(*         end *)
(*     end. *)
  Fixpoint types_of (l : terms) (ret : type) : type :=
    match l with
      | nil => ret
      | cons _ l =>
        match ret with
          | typeArrow _ t2 => types_of l t2
          | _ => typeDefault (* dummy *)
        end
    end.
  Definition type_of (t : term) : type :=
    match t with
      | app f l => types_of l (lookup_type f)
    end.

  Inductive well_typed : term -> type -> Prop :=
  | wt_app :
    forall f lt res,
      well_typed_terms lt (lookup_type f) res ->
      well_typed (app f lt) res
  with well_typed_terms : terms -> type -> type -> Prop :=
  | wf_tnil :
    forall res, well_typed_terms tnil res res
  | wf_tcons :
    forall t lt t1 t2 res,
      well_typed_terms lt t2 res ->
      well_typed t t1 ->
      well_typed_terms (tcons t lt) (typeArrow t1 t2) res.

(*   Require Import Nfix. *)
(*   Nested Fixpoint has_type (t : term) (type : type) : bool := *)
(*     match t with *)
(*       | app f l =>  *)
(*         (fix have_type (l : terms) type res : bool := *)
(*           match l with *)
(*             | nil => tequal type res *)
(*             | cons t l =>  *)
(*               match type with *)
(*                 | typeArrow t1 t2 => has_type t t1 &&& have_type l t2 res *)
(*                 | _ => false *)
(*               end *)
(*           end           *)
(*         ) l (lookup_type f) type *)
(*     end *)
(*     with have_type (l : terms) (type res : type) : bool := *)
(*     match l with *)
(*       | nil => tequal type res *)
(*       | cons t l =>  *)
(*         match type with *)
(*           | typeArrow t1 t2 => has_type t t1 &&& have_type l t2 res *)
(*           | _ => false *)
(*         end *)
(*     end. *)

  Fixpoint has_type (t : term) (type : type) {struct t} : bool :=
    match t with
      | app f l =>
        (fix have_type (l : terms) type res : bool :=
          match l with
            | nil => tequal type res
            | cons t l =>
              match type with
                | typeArrow t1 t2 => has_type t t1 &&& have_type l t2 res
                | _ => false
              end
          end
        ) l (lookup_type f) type
    end.
  Definition have_type :=
    fix have_type (l : terms) type res : bool :=
    match l with
      | nil => tequal type res
      | cons t l =>
        match type with
          | typeArrow t1 t2 => has_type t t1 &&& have_type l t2 res
          | _ => false
        end
    end.
  Remark has_type_unfold : forall t ty,
    has_type t ty =
    match t with | app f l => have_type l (lookup_type f) ty end.
  Proof.
    intros; unfold has_type; destruct t; reflexivity.
  Qed.

  Property has_type_1 : forall t ty, has_type t ty = true -> well_typed t ty.
  Proof.
    intro t; pattern t; apply term_terms_rect
      with (P0 := fun lt => forall ty res,
        have_type lt ty res = true -> well_typed_terms lt ty res); clear t.
    intros f lt IH ty Happ; simpl in Happ; constructor; auto.
    intros ty res H; simpl in H; rewrite tequal_iff in H; subst; constructor.
    intros t IHt lt IHlt ty res H; simpl in H.
    destruct ty; try discriminate; constructor;
      destruct (andb_prop _ _ H); auto.
  Qed.
  Property has_type_2 : forall t ty, well_typed t ty -> has_type t ty = true.
  Proof.
    intro t; pattern t; apply term_terms_rect
      with (P0 := fun lt => forall ty res,
        well_typed_terms lt ty res -> have_type lt ty res = true); clear t.
    intros f lt IH ty Happ; inversion Happ; subst; simpl; auto.
    intros ty res H; inversion H; subst; simpl; apply tequal_2; auto.
    intros t IHt lt IHlt ty res H; inversion H; subst.
    simpl; apply andb_true_intro; auto.
  Qed.
  Corollary has_type_iff :
    forall t ty, has_type t ty = true <-> well_typed t ty.
  Proof.
    intros t t'; split; intro H; [apply has_type_1 | apply has_type_2]; auto.
  Qed.
  Corollary well_typed_dec :
    forall t ty, { well_typed t ty } + {~(well_typed t ty)}.
  Proof.
    intros; case_eq (has_type t ty); intro H; [left | right].
    apply has_type_1; auto.
    intro c; rewrite (has_type_2 _ _ c) in H; discriminate.
  Qed.

(*   Require Import Nfix. *)
(*   Nested Fixpoint interp (t : term) (ty : type) (H : has_type t ty = true) *)
(*     : [| ty |] := *)
(*     (match t as a *)
(*        return has_type a ty = true -> [| ty |] with *)
(*        | app f l => *)
(*          fun H => interps l _ ty (lookup f) H *)
(*      end) H *)
(*   with interps (l : terms) (ty res : type) (f : [| ty |]) *)
(*       (H : have_type l ty res = true) : [| res |] := *)
(*       (match l as a return have_type a ty res = true -> [| res |] with *)
(*          | nil => *)
(*            fun H => eq_rect _ (fun x => [| x |]) f _ (tequal_1 _ _ H) *)
(*          | cons t lt => *)
(*            (match ty as b *)
(*               return [| b |] -> have_type (tcons t lt) b res = true *)
(*               -> [| res |] with *)
(*               | typeArrow t1 t2 => *)
(*                 fun f H => *)
(*                   let H1 := proj1 (andb_prop _ _ H) in *)
(*                   let H2 := proj2 (andb_prop _ _ H) in *)
(*                   interps_ lt t2 res (f (interp t t1 H1)) H2 *)
(*               | _ => *)
(*                 fun f => bdiscr [| res |] *)
(*             end) f *)
(*        end) H. *)

  Section Interps.
    Variable interp :
      forall (t : term) (ty : type) (H : has_type t ty = true), [| ty |].
    Fixpoint interps_ (l : terms) (ty res : type) (f : [| ty |])
      (H : have_type l ty res = true) : [| res |] :=
      (match l as a return have_type a ty res = true -> [| res |] with
         | nil =>
           fun H => eq_rect _ (fun x => [| x |]) f _ (tequal_1 _ _ H)
         | cons t lt =>
           (match ty as b
              return [| b |] -> have_type (tcons t lt) b res = true
              -> [| res |] with
              | typeArrow t1 t2 =>
                fun f H =>
                  let H1 := proj1 (andb_prop _ _ H) in
                  let H2 := proj2 (andb_prop _ _ H) in
                  interps_ lt t2 res (f (interp t t1 H1)) H2
              | _ =>
                fun f => bdiscr [| res |]
            end) f
       end) H.
  End Interps.
  Fixpoint interp (t : term) (ty : type) (H : has_type t ty = true)
    : [| ty |] :=
    (match t as a
       return has_type a ty = true -> [| ty |] with
       | app f l =>
         fun H => interps_ interp l _ ty (lookup f) H
     end) H.
  Definition interps := interps_ interp.
  Remark interp_unfold : forall t ty H, interp t ty H =
    (match t as a return has_type a ty = true -> [| ty |] with
       | app f l =>
         fun H => interps l _ ty (lookup f) H
     end) H.
  Proof. intros; unfold interp; destruct t; reflexivity. Qed.

  Definition interp' (t : term) := interp t (type_of t).
End Interp.

Module Test.
  Close Scope Z_scope.
  Implicit Arguments Empty_vm [[A]].

  Definition nat_idx := End_idx.
  Definition bool_idx := Left_idx End_idx.
  Definition nat_arrow_bool_idx := Right_idx End_idx.
  Definition nat_arrow_nat_idx := Right_idx (Left_idx End_idx).

  Definition vtypes : type_env :=
    @Node_vm Type nat
      (@Node_vm Type bool Empty_vm Empty_vm)
      Empty_vm.
  Notation "[| type |]" := (tinterp vtypes type).

  Definition tnat : type := typeCst nat_idx.
  Definition tbool : type := typeCst bool_idx.
  Definition tnat_arrow_bool : type := typeArrow tnat tbool.
  Definition tnat_arrow_nat : type := typeArrow tnat tnat.

  Variable natx : nat.
  Variable boolx : bool.

  Definition nat_varmap : varmap nat :=
    Node_vm 0%nat
    (Node_vm 1%nat (Node_vm natx Empty_vm Empty_vm) Empty_vm)
    (Node_vm 2 Empty_vm Empty_vm).

  (** Paths to reified values *)
  Definition n0 := Unint nat_idx End_idx.
  Definition n1 := Unint nat_idx (Left_idx End_idx).
  Definition n2 := Unint nat_idx (Right_idx End_idx).
  Definition nx := Unint nat_idx (Left_idx (Left_idx End_idx)).

  Definition bool_varmap : varmap bool :=
    Node_vm true
    (Node_vm false Empty_vm Empty_vm)
    (Node_vm boolx (Node_vm false Empty_vm Empty_vm) Empty_vm).

  (** Path to reified values *)
  Definition btrue := Unint bool_idx End_idx.
  Definition bfalse := Unint bool_idx (Left_idx End_idx).
  Definition bx := Unint bool_idx (Right_idx End_idx).
  Definition bfalse2 := Unint bool_idx (Left_idx (Left_idx End_idx)).

  Variable natbool : nat -> bool.
  Definition nat_arrow_bool_varmap : varmap (nat -> bool) :=
    Node_vm (fun x : nat => match x with 0 => true | _ => false end)
    (Node_vm natbool Empty_vm Empty_vm)
    Empty_vm.

  Variable natnat : nat -> nat.
  Definition nat_arrow_nat_varmap : varmap (nat -> nat) :=
    Node_vm S (Node_vm natnat Empty_vm Empty_vm) Empty_vm.

  (** Path to reified values *)
  Definition test0 := Unint nat_arrow_bool_idx End_idx.
  Definition anatbool := Unint nat_arrow_bool_idx (Left_idx End_idx).
  Definition succ := Unint nat_arrow_nat_idx End_idx.
  Definition anatnat := Unint nat_arrow_nat_idx (Left_idx End_idx).

  Definition variables : term_env vtypes :=
    Node_vm (existT _ tnat (0%nat, nat_varmap))
    (Node_vm (existT _ tbool (false, bool_varmap)) Empty_vm Empty_vm)
    (Node_vm (existT _ tnat_arrow_bool (fun x => false, nat_arrow_bool_varmap))
      (Node_vm (existT _ tnat_arrow_nat (fun x => O, nat_arrow_nat_varmap))
        Empty_vm Empty_vm)
      Empty_vm).
(*   Definition qvars : varmap Z := Empty_vm. *)

  Definition interp (t : term) := interp' vtypes variables t.

  Definition two := app n2 tnil.
  Definition itwo : nat := interp two (refl_equal _).
  Time Eval vm_compute in itwo.
  Definition zero := app n0 tnil.
  Definition izero : nat := interp zero (refl_equal _).
  Time Eval vm_compute in izero.
  Definition x := app nx tnil.
  Definition ix : nat := interp x (refl_equal _).
  Time Eval vm_compute in ix.

  Definition a := app test0 (tcons zero tnil).
  Definition ia : bool := interp a (refl_equal _).
  Time Eval vm_compute in ia.

  Definition b := app test0 (tcons two tnil).
  Definition ib : bool := interp b (refl_equal _).
  Time Eval vm_compute in ib.

  Definition anatbool_x := app anatbool (tcons x tnil).
  Definition inbx : bool := interp anatbool_x (refl_equal _).
  Time Eval vm_compute in inbx.

  Fixpoint power f a (n : nat) :=
    match n with
      | O => a
      | S n0 => app f (tcons (power f a n0) tnil)
    end.
  Definition fx := power anatnat x 1.
  Definition f3x := power anatnat x 3.
  Definition f5x := power anatnat x 5.
  Time Eval vm_compute in (interp f5x (refl_equal _)).
End Test.

Module TestWithNat.
  Open Scope nat_scope.
  Implicit Arguments Empty_vm [[A]].
  Definition nat_idx := End_idx.
  Definition bool_idx := Left_idx End_idx.
  Definition nat_arrow_bool_idx := Right_idx End_idx.
  Definition nat_arrow_nat_idx := Right_idx (Left_idx End_idx).

  Definition vtypes : type_env :=
    @Node_vm Type nat
      (@Node_vm Type bool Empty_vm Empty_vm)
      Empty_vm.
  Notation "[| type |]" := (tinterp vtypes type).

  Definition tnat : type := typeArith DomainNat.
  Definition tbool : type := typeCst bool_idx.
  Definition tnat_arrow_bool : type := typeArrow tnat tbool.
  Definition tnat_arrow_nat : type := typeArrow tnat tnat.

  Variable natx : nat.
  Variable boolx : bool.

  Definition nat_varmap : varmap nat :=
    Node_vm natx Empty_vm Empty_vm.

  (** Paths to reified values *)
  Definition n0 := Cst DomainNat 0.
  Definition n1 := Cst DomainNat 1.
  Definition n2 := Cst DomainNat 2.
  Definition nx := Unint nat_idx End_idx.

  Definition bool_varmap : varmap bool :=
    Node_vm true
    (Node_vm false Empty_vm Empty_vm)
    (Node_vm boolx (Node_vm false Empty_vm Empty_vm) Empty_vm).

  (** Path to reified values *)
  Definition btrue := Unint bool_idx End_idx.
  Definition bfalse := Unint bool_idx (Left_idx End_idx).
  Definition bx := Unint bool_idx (Right_idx End_idx).
  Definition bfalse2 := Unint bool_idx (Left_idx (Left_idx End_idx)).

  Variable natbool : nat -> bool.
  Definition nat_arrow_bool_varmap : varmap (nat -> bool) :=
    Node_vm (fun x : nat => match x with 0 => true | _ => false end)
    (Node_vm natbool Empty_vm Empty_vm)
    Empty_vm.

  Variable natnat : nat -> nat.
  Definition nat_arrow_nat_varmap : varmap (nat -> nat) :=
    Node_vm S (Node_vm natnat Empty_vm Empty_vm) Empty_vm.

  (** Path to reified values *)
  Definition test0 := Unint nat_arrow_bool_idx End_idx.
  Definition anatbool := Unint nat_arrow_bool_idx (Left_idx End_idx).
  Definition succ := Unint nat_arrow_nat_idx End_idx.
  Definition anatnat := Unint nat_arrow_nat_idx (Left_idx End_idx).

  Definition variables : term_env vtypes :=
    Node_vm (existT _ tnat (0, nat_varmap))
    (Node_vm (existT _ tbool (false, bool_varmap)) Empty_vm Empty_vm)
    (Node_vm (existT _ tnat_arrow_bool (fun x => false, nat_arrow_bool_varmap))
      (Node_vm (existT _ tnat_arrow_nat (fun x => O, nat_arrow_nat_varmap))
        Empty_vm Empty_vm)
      Empty_vm).

  Definition interp (t : term) := interp' vtypes variables t.

  Definition two := app n2 tnil.
  Definition itwo : nat := interp two (refl_equal _).
  Time Eval vm_compute in itwo.
  Definition zero := app n0 tnil.
  Definition izero : nat := interp zero (refl_equal _).
  Time Eval vm_compute in izero.
  Definition x := app nx tnil.
  Definition ix : nat := interp x (refl_equal _).
  Time Eval vm_compute in ix.

  Definition a := app test0 (tcons zero tnil).
  Definition ia : bool := interp a (refl_equal _).
  Time Eval vm_compute in ia.

  Definition b := app test0 (tcons two tnil).
  Definition ib : bool := interp b (refl_equal _).
  Time Eval vm_compute in ib.

  Definition anatbool_x := app anatbool (tcons x tnil).
  Definition inbx : bool := interp anatbool_x (refl_equal _).
  Time Eval vm_compute in inbx.

  Fixpoint power f a (n : nat) :=
    match n with
      | O => a
      | S n0 => app f (tcons (power f a n0) tnil)
    end.
  Definition fx := power anatnat x 1.
  Definition f3x := power anatnat x 3.
  Definition f5x := power anatnat x 5.
  Time Eval vm_compute in (interp f5x (refl_equal _)).
End TestWithNat.

Module BoolasDT <: DecidableType.
  Definition U := bool.
  Definition eq_dec := bool_dec.
End BoolasDT.
Module BoolEqDep := DecidableEqDep(BoolasDT).

Module TypeasDT <: DecidableType.
  Definition U := type.
  Definition eq_dec := type_dec.
End TypeasDT.
Module TypeEqDep := DecidableEqDep(TypeasDT).

Section CanonicalStructure.
  Variable vtypes : varmap Type.
  Variable v : varmap (depvarmap vtypes).

  Definition dom := option (sigT (tinterp vtypes)).
  Definition int (t : term) : dom :=
    let ty := type_of vtypes v t in
      (match has_type vtypes v t ty as a
         return has_type vtypes v t ty = a -> dom with
         | true => fun H =>
           Some (existT (tinterp vtypes) ty (interp' vtypes v t H))
         | false => fun _ => None
       end) (refl_equal _).
  Definition eq (t t' : term) := int t = int t'.

  Property eq_refl : forall t, eq t t.
  Proof. reflexivity. Qed.
  Property eq_sym : forall t t', eq t t' -> eq t' t.
  Proof. congruence. Qed.
  Property eq_trans : forall t t' t'', eq t t' -> eq t' t'' -> eq t t''.
  Proof. congruence. Qed.

  Lemma has_type_is_type_of :
    forall t ty, has_type vtypes v t ty = true -> ty = type_of vtypes v t.
  Proof.
    intro t; pattern t.
    apply term_terms_rect with
      (P0 := fun lt => forall ty res, have_type vtypes v lt ty res = true ->
        res = types_of lt ty); clear t.
    intros f lt IH ty Heq; rewrite (IH _ _ Heq); reflexivity.
    intros ty res H; simpl in *; symmetry; apply tequal_1; auto.
    intros t IHt lt IHlt ty res Heq.
    simpl in Heq; destruct ty; try discriminate.
    destruct (andb_prop _ _ Heq) as [H1 H2]; simpl.
    apply IHlt; auto.
  Qed.

  Inductive eq_terms : terms -> terms -> Prop :=
  | eq_terms_nil : eq_terms nil nil
  | eq_terms_cons :
    forall a a' q q', eq a a' -> eq_terms q q' -> eq_terms (a::q) (a'::q').

  Property eq_terms_refl : forall l, eq_terms l l.
  Proof. induction l; constructor; auto using eq_refl. Qed.
  Property eq_terms_sym : forall l l', eq_terms l l' -> eq_terms l' l.
  Proof.
    intros l l' H; induction H; subst; constructor; auto using eq_sym.
  Qed.
  Property eq_terms_trans : forall l l' l'',
    eq_terms l l' -> eq_terms l' l'' -> eq_terms l l''.
  Proof.
    intros l l' l'' H; revert l''; induction H; intros l'' H'; inversion H';
      subst; constructor; eauto using eq_trans.
  Qed.

  Lemma types_of_congr :
    forall ty lt lt', eq_terms lt lt' -> types_of lt ty = types_of lt' ty.
  Proof.
    intros ty lt lt' Heq; revert ty; induction Heq; intro ty; simpl.
    reflexivity.
    destruct ty; auto.
  Qed.
  Lemma type_of_congr :
    forall f lt lt', eq_terms lt lt' ->
      type_of vtypes v (app f lt) = type_of vtypes v (app f lt').
  Proof.
    intros; unfold type_of; rewrite (types_of_congr _ lt lt' H); auto.
  Qed.

  Lemma has_type_congr :
    forall ty t t', eq t t' ->
      has_type vtypes v t ty = has_type vtypes v t' ty.
  Proof.
    intros ty t t' Heq.
    case_eq (has_type vtypes v t ty); intro H;
      case_eq (has_type vtypes v t' ty); intro H'; auto.
    assert (R := has_type_is_type_of t ty H); subst.
    unfold eq, int in Heq.
    set (Z := interp' vtypes v t) in *; clearbody Z.
    destruct (has_type vtypes v t (type_of vtypes v t)); try discriminate.
    set (Z' := interp' vtypes v t') in *; clearbody Z'.
    case_eq (has_type vtypes v t' (type_of vtypes v t')); intro H''.
    cut (type_of vtypes v t = type_of vtypes v t' -> False);
      [ intro cut |
        intro abs; rewrite abs in H'; rewrite H' in H''; discriminate].
    destruct (has_type vtypes v t' (type_of vtypes v t')); try discriminate.
    inversion Heq; contradiction cut; assumption.
    destruct (has_type vtypes v t' (type_of vtypes v t')); try discriminate.
    assert (R := has_type_is_type_of t' ty H'); subst.
    unfold eq, int in Heq.
    set (Z' := interp' vtypes v t') in *; clearbody Z'.
    destruct (has_type vtypes v t' (type_of vtypes v t')); try discriminate.
    set (Z := interp' vtypes v t) in *; clearbody Z.
    case_eq (has_type vtypes v t (type_of vtypes v t)); intro H''.
    cut (type_of vtypes v t = type_of vtypes v t' -> False);
      [ intro cut |
        intro abs; rewrite abs in H''; rewrite H in H''; discriminate].
    destruct (has_type vtypes v t (type_of vtypes v t)); try discriminate.
    inversion Heq; contradiction cut; assumption.
    destruct (has_type vtypes v t (type_of vtypes v t)); try discriminate.
  Qed.
  Lemma have_type_congr :
    forall lt ty res lt', eq_terms lt lt' ->
      have_type vtypes v lt ty res = have_type vtypes v lt' ty res.
  Proof.
    induction lt; intros ty res lt' Heq; inversion Heq; subst.
    reflexivity.
    simpl; destruct ty; auto.
    rewrite (IHlt _ _ _ H3), (has_type_congr _ _ _ H1); reflexivity.
  Qed.

  Corollary has_type_type_of_congr :
    forall f lt lt', eq_terms lt lt' ->
      has_type vtypes v (app f lt) (type_of vtypes v (app f lt)) =
      has_type vtypes v (app f lt') (type_of vtypes v (app f lt')).
  Proof.
    intros f lt lt' Heq.
    rewrite (type_of_congr f lt lt' Heq).
    generalize (type_of vtypes v (app f lt')) as ty.
    intro ty; rewrite 2has_type_unfold; revert ty.
    induction Heq; intro ty; simpl.
    reflexivity.
    unfold has_type in *; destruct (lookup_type vtypes v f); auto.
    fold (has_type vtypes v a t1); fold (has_type vtypes v a' t1).
    fold (have_type vtypes v q t2); fold (have_type vtypes v q' t2).
    rewrite (has_type_congr t1 a a' H).
    rewrite (have_type_congr _ _ _ _ Heq); reflexivity.
  Qed.

  Lemma interp_congr : forall ty f lt lt' H H',
    eq_terms lt lt' ->
    interp vtypes v (app f lt) ty H = interp vtypes v (app f lt') ty H'.
  Proof.
    intros ty f lt lt' H H' Heq.
    change (interps vtypes v lt _ ty (lookup vtypes v f) H =
      interps vtypes v lt' _ ty (lookup vtypes v f) H').
    generalize (lookup vtypes v f) as F.
    change (have_type vtypes v lt' (lookup_type vtypes v f) ty = true) in H'.
    change (have_type vtypes v lt (lookup_type vtypes v f) ty = true) in H.
    revert H H'; remember (lookup_type vtypes v f) as tyf; clear Heqtyf.
    revert ty tyf; induction Heq; intros res tyf Hty Hty' fi.
    simpl in *; assert (R := tequal_1 _ _ Hty); subst.
    do 2 rewrite <- (Eqdep_dec.eq_rect_eq_dec type_dec); reflexivity.
    unfold interps; destruct tyf.
    rewrite (BoolEqDep.UIP false true Hty Hty'); reflexivity.
    rewrite (BoolEqDep.UIP false true Hty Hty'); reflexivity.
    rewrite (BoolEqDep.UIP false true Hty Hty'); reflexivity.
    change (
      (let h1 := has_type vtypes v a tyf1 in
       let h2 := have_type vtypes v q tyf2 res in
       let H1 := proj1 (andb_prop h1 h2 Hty) in
       let H2 := proj2 (andb_prop h1 h2 Hty) in
         interps vtypes v q tyf2 res (fi (interp vtypes v a tyf1 H1)) H2) =
      (let h1 := has_type vtypes v a' tyf1 in
       let h2 := have_type vtypes v q' tyf2 res in
       let H1 := proj1 (andb_prop h1 h2 Hty') in
       let H2 := proj2 (andb_prop h1 h2 Hty') in
         interps vtypes v q' tyf2 res (fi (interp vtypes v a' tyf1 H1)) H2)).
    set (h1 := has_type vtypes v a tyf1).
    set (h2 := have_type vtypes v q tyf2 res).
    set (H1 := proj1 (andb_prop h1 h2 Hty)).
    set (h1' := has_type vtypes v a' tyf1).
    set (h2' := have_type vtypes v q' tyf2 res).
    set (H1' := proj1 (andb_prop h1' h2' Hty')).
    simpl.

    cut (fi (interp vtypes v a tyf1 H1) = fi (interp vtypes v a' tyf1 H1')).
    intro R; fold H1; rewrite R; apply IHHeq.
    clear IHHeq; f_equal; unfold eq, int, interp' in H.
    assert (Rty := has_type_is_type_of _ _ H1).
    assert (Rty' := has_type_is_type_of _ _ H1').
    clearbody H1 H1'; clear Hty Hty'.
    unfold h1, h2, h1', h2' in *; clear h1 h2 h1' h2'; subst.
    revert H fi H1 H1' Rty'.
    generalize (type_of vtypes v a) as ty;
      generalize (type_of vtypes v a') as ty'; intros; subst.
    set (Z := interp vtypes v a ty') in *; clearbody Z.
    set (Z' := interp vtypes v a' ty') in *; clearbody Z'.
    destruct (has_type vtypes v a ty'); try discriminate.
    destruct (has_type vtypes v a' ty'); try discriminate.
    inversion H; subst.
    rewrite (BoolEqDep.UIP _ _ H1 H1'), (BoolEqDep.UIP_refl _ H1').
    exact (TypeEqDep.inj_pairT2 _ _ _ _ H2).
  Qed.

  Property eq_congr : forall f l l',
    eq_terms l l' -> eq (app f l) (app f l').
  Proof.
    intros f l l' Heq.
    unfold eq, int.
    assert (Teq := has_type_type_of_congr f l l' Heq).
    assert (icongr := fun H H' =>
      interp_congr (type_of vtypes v (app f l)) f l l' H H' Heq).
    assert (R :=  type_of_congr f l l' Heq).
    unfold interp'.
    revert Teq R icongr.
    generalize (type_of vtypes v (app f l)) as ty;
      generalize (type_of vtypes v (app f l')) as ty'.
    intros ty ? ? Teq icongr; subst.
    set (Z := interp vtypes v (app f l) ty) in *; clearbody Z.
    set (Z' := interp vtypes v (app f l') ty) in *; clearbody Z'.
    destruct (has_type vtypes v (app f l) ty);
      destruct (has_type vtypes v (app f l') ty);
        try discriminate; auto.
    rewrite (icongr (refl_equal _) (refl_equal _)); reflexivity.
  Qed.
End CanonicalStructure.
(* Print Assumptions model. *)

Theorem replace : forall vty vsy ty ra rb a b,
  int vty vsy a = Some (existT _ ty ra) ->
  int vty vsy b = Some (existT _ ty rb) ->
    (ra = rb <-> eq vty vsy a b).
Proof.
  intros vty vsy ty ra rb a b Ha Hb;
    unfold eq; split; intro R.
  congruence.
  rewrite Ha, Hb in R; inversion R.
  exact (TypeEqDep.inj_pairT2 _ _ _ _ H0).
Qed.

Lemma has_type_irrelevant :
  forall vty vsy r ty (H H' : has_type vty vsy r ty = true), H = H'.
Proof.
  intros; apply BoolEqDep.UIP.
Qed.
Lemma interp_irrelevant :
  forall vty vsy r ty (H H' : has_type vty vsy r ty = true),
    interp vty vsy r ty H = interp vty vsy r ty H'.
Proof.
  intros; rewrite (has_type_irrelevant vty vsy r ty H H'); reflexivity.
Qed.

Theorem replace' :
  forall vty vsy (ra rb : term) (ty : type)
    (Ha : has_type vty vsy ra ty = true) (Hb : has_type vty vsy rb ty = true),
    interp vty vsy ra ty Ha = interp vty vsy rb ty Hb
    <-> eq vty vsy ra rb.
Proof.
  intros.
  unfold eq, int, interp'.
  assert (ty = type_of vty vsy ra).
  apply has_type_is_type_of; assumption.
  rewrite <- H; clear H.
  assert (ty = type_of vty vsy rb).
  apply has_type_is_type_of; assumption.
  rewrite <- H; clear H.
  assert (Iirr := fun r => interp_irrelevant vty vsy r ty).
  assert (Iirra := Iirr ra Ha). assert (Iirrb := Iirr rb Hb). clear Iirr.
  set (Ia := interp vty vsy ra ty) in *; clearbody Ia.
  set (Ib := interp vty vsy rb ty) in *; clearbody Ib.
  set (Za := has_type vty vsy ra ty) in *; clearbody Za.
  set (Zb := has_type vty vsy rb ty) in *; clearbody Zb.
  destruct Za; destruct Zb; try discriminate.
  generalize (Iirra (refl_equal _)) (Iirrb (refl_equal _)); intros; split.
  intro; congruence.
  intro abs; inversion abs;
    assert (ZZ := TypeEqDep.inj_pairT2 _ _ _ _ H2); congruence.
Qed.

(* Section CanonicalStructure2. *)
(*   Variable vtypes : varmap Type. *)
(*   Variable v : varmap (depvarmap vtypes). *)

(*   Inductive int_spec (t : term) : dom vtypes -> Prop := *)
(*   | int_spec_Some :  *)
(*     let ty := type_of vtypes v t in *)
(*       forall (it : tinterp vtypes ty) *)
(*         (H_wt : has_type vtypes v t ty = true) *)
(*         (Hit : it = interp vtypes v t ty H_wt), *)
(*         int_spec t (Some (existT _ ty it)) *)
(*   | int_spec_None :  *)
(*     forall (H_nwt : has_type vtypes v t (type_of vtypes v t) = false), *)
(*       int_spec t None. *)
(*   Theorem int_dec : forall t, int_spec t (int vtypes v t). *)
(*   Proof. *)
(*     intro t; unfold int, interp'. *)
(*     assert (C1 := int_spec_Some t); revert C1; simpl. *)
(*     set (Z := interp vtypes v t (type_of vtypes v t)); clearbody Z; revert Z. *)
(*     destruct (has_type vtypes v t (type_of vtypes v t)) as [ ]_eqn:Hht. *)
(*     intros; apply C1 with (refl_equal _); auto. *)
(*     intros; constructor (auto). *)
(*   Qed. *)
(*   Tactic Notation "decide" "int" := *)
(*     match goal with *)
(*       | |- context f [int vtypes v ?T] => destruct (int_dec T) *)
(*       | _ => fail "No occurrence of 'int' found in goal." *)
(*     end.     *)

(*   Require Import Nfix. *)
(*   Nested Fixpoint eq2 (x y : term) : Prop := *)
(*     match int vtypes v x, int vtypes v y with *)
(*       | Some sx, Some sy => sx = sy *)
(*       | Some _, None | None, Some _ => False *)
(*       | None, None =>  *)
(*         match x, y with *)
(*           | app f l, app g l' => f = g /\ eq2_terms l l' *)
(*         end *)
(*     end *)
(*   with eq2_terms (lx ly : terms) : Prop := *)
(*     match lx, ly with *)
(*       | nil, nil => True *)
(*       | cons _ _, nil | nil, cons _ _ => False *)
(*       | x::qx, y::qy => eq2 x y /\ eq2_terms qx qy *)
(*     end. *)

(*   Property eq2_refl : forall t, eq2 t t. *)
(*   Proof.  *)
(*     intro t; unfold eq2. *)
(*     decide int; reflexivity. *)
(*   Qed. *)
(*   Property eq2_sym : forall t t', eq2 t t' -> eq2 t' t. *)
(*   Proof. *)
(*     intros t t'; unfold eq2. *)
(*     do 2 decide int; intuition. *)
(*   Qed. *)
(*   Property eq2_trans : forall t t' t'', eq2 t t' -> eq2 t' t'' -> eq2 t t''. *)
(*   Proof.  *)
(*     intros t t' t''; unfold eq2. *)
(*     do 3 decide int; intuition; eapply transitivity; eassumption. *)
(*   Qed. *)

(*   Inductive eq2_terms : terms -> terms -> Prop := *)
(*   | eq2_terms_nil : eq2_terms nil nil *)
(*   | eq2_terms_cons :  *)
(*     forall a a' q q', eq2 a a' -> eq2_terms q q' -> eq2_terms (a::q) (a'::q'). *)
(*   Property eq2_terms_refl : forall l, eq2_terms l l. *)
(*   Proof. induction l; constructor (auto using eq2_refl). Qed. *)
(*   Property eq2_terms_sym : forall l l', eq2_terms l l' -> eq2_terms l' l. *)
(*   Proof. *)
(*     intros l l' H; induction H; subst; constructor (auto using eq2_sym). *)
(*   Qed. *)
(*   Property eq2_terms_trans : forall l l' l'',  *)
(*     eq2_terms l l' -> eq2_terms l' l'' -> eq2_terms l l''. *)
(*   Proof. *)
(*     intros l l' l'' H; revert l''; induction H; intros l'' H'; inversion H';  *)
(*       subst; constructor; eauto using eq2_trans. *)
(*   Qed. *)

(*   Lemma types_of_congr2 : *)
(*     forall ty lt lt', eq2_terms lt lt' -> types_of lt ty = types_of lt' ty. *)
(*   Proof. *)
(*     intros ty lt lt' Heq; revert ty; induction Heq; intro ty; simpl. *)
(*     reflexivity. *)
(*     destruct ty; auto. *)
(*   Qed. *)
(*   Lemma type_of_congr2 : *)
(*     forall f lt lt', eq2_terms lt lt' -> *)
(*       type_of vtypes v (app f lt) = type_of vtypes v (app f lt'). *)
(*   Proof. *)
(*     intros; unfold type_of; rewrite (types_of_congr2 _ lt lt' H); auto. *)
(*   Qed. *)

(*   Lemma has_type_congr2 : *)
(*     forall ty t t', eq2 t t' -> *)
(*       has_type vtypes v t ty = has_type vtypes v t' ty. *)
(*   Proof. *)
(*     intros ty t t'; unfold eq2. *)
(*     do 2 decide int; intuition. *)
(*     inversion H; subst; clear H H2. *)
(*     case_eq (has_type vtypes v t ty); intro. *)
(*     rewrite (has_type_is_type_of _ _ _ _ H) in *; congruence. *)
(*     case_eq (has_type vtypes v t' ty); intro; auto. *)
(*     rewrite (has_type_is_type_of _ _ _ _ H0) in *. *)
(*     fold ty1 in H; congruence. *)
(*     congruence. *)
(*   Qed. *)
(*   Lemma have_type_congr2 : *)
(*     forall lt ty res lt', eq2_terms lt lt' -> *)
(*       have_type vtypes v lt ty res = have_type vtypes v lt' ty res. *)
(*   Proof. *)
(*     induction lt; intros ty res lt' Heq; inversion Heq; subst. *)
(*     reflexivity. *)
(*     simpl; destruct ty; auto. *)
(*     rewrite (IHlt _ _ _ H3), (has_type_congr2 _ _ _ H1); reflexivity. *)
(*   Qed. *)

(*   Corollary has_type_type_of_congr2 : *)
(*     forall f lt lt', eq2_terms lt lt' -> *)
(*       has_type vtypes v (app f lt) (type_of vtypes v (app f lt)) = *)
(*       has_type vtypes v (app f lt') (type_of vtypes v (app f lt')). *)
(*   Proof. *)
(*     intros f lt lt' Heq. *)
(*     rewrite (type_of_congr2 f lt lt' Heq). *)
(*     generalize (type_of vtypes v (app f lt')) as ty. *)
(*     intro ty; rewrite 2has_type_unfold; revert ty. *)
(*     induction Heq; intro ty; simpl. *)
(*     reflexivity. *)
(*     unfold has_type in *; destruct (lookup_type vtypes v f); auto. *)
(*     fold (has_type vtypes v a t1); fold (has_type vtypes v a' t1). *)
(*     fold (have_type vtypes v q t2); fold (have_type vtypes v q' t2). *)
(*     rewrite (has_type_congr2 t1 a a' H). *)
(*     rewrite (have_type_congr2 _ _ _ _ Heq); reflexivity. *)
(*   Qed. *)

(*   Lemma interp_congr2 : forall ty f lt lt' H H', *)
(*     eq2_terms lt lt' -> *)
(*     interp vtypes v (app f lt) ty H = interp vtypes v (app f lt') ty H'. *)
(*   Proof. *)
(*     intros ty f lt lt' H H' Heq. *)
(*     change (interps vtypes v lt _ ty (lookup vtypes v f) H = *)
(*       interps vtypes v lt' _ ty (lookup vtypes v f) H'). *)
(*     generalize (lookup vtypes v f) as F. *)
(*     change (have_type vtypes v lt' (lookup_type vtypes v f) ty = true) in H'. *)
(*     change (have_type vtypes v lt (lookup_type vtypes v f) ty = true) in H. *)
(*     revert H H'; remember (lookup_type vtypes v f) as tyf; clear Heqtyf. *)
(*     revert ty tyf; induction Heq; intros res tyf Hty Hty' fi. *)
(*     simpl in *; assert (R := tequal_1 _ _ Hty); subst. *)
(*     do 2 rewrite <- (Eqdep_dec.eq_rect_eq_dec type_dec); reflexivity. *)
(*     unfold interps; destruct tyf. *)
(*     rewrite (BoolEqDep.UIP false true Hty Hty'); reflexivity. *)
(*     rewrite (BoolEqDep.UIP false true Hty Hty'); reflexivity. *)
(*     rewrite (BoolEqDep.UIP false true Hty Hty'); reflexivity. *)
(*     change ( *)
(*       (let h1 := has_type vtypes v a tyf1 in *)
(*        let h2 := have_type vtypes v q tyf2 res in *)
(*        let H1 := proj1 (andb_prop h1 h2 Hty) in *)
(*        let H2 := proj2 (andb_prop h1 h2 Hty) in *)
(*          interps vtypes v q tyf2 res (fi (interp vtypes v a tyf1 H1)) H2) = *)
(*       (let h1 := has_type vtypes v a' tyf1 in *)
(*        let h2 := have_type vtypes v q' tyf2 res in *)
(*        let H1 := proj1 (andb_prop h1 h2 Hty') in *)
(*        let H2 := proj2 (andb_prop h1 h2 Hty') in *)
(*          interps vtypes v q' tyf2 res (fi (interp vtypes v a' tyf1 H1)) H2)). *)
(*     set (h1 := has_type vtypes v a tyf1). *)
(*     set (h2 := have_type vtypes v q tyf2 res). *)
(*     set (H1 := proj1 (andb_prop h1 h2 Hty)). *)
(*     set (h1' := has_type vtypes v a' tyf1). *)
(*     set (h2' := have_type vtypes v q' tyf2 res). *)
(*     set (H1' := proj1 (andb_prop h1' h2' Hty')). *)
(*     simpl. *)

(*     cut (fi (interp vtypes v a tyf1 H1) = fi (interp vtypes v a' tyf1 H1')). *)
(*     intro R; fold H1; rewrite R; apply IHHeq. *)
(*     clear IHHeq; f_equal; unfold eq2 in H. *)
(*     revert H; do 2 decide int; intro H; try contradiction. *)
(*     assert (Rty := has_type_is_type_of _ _ _ _ H1). *)
(*     assert (Rty' := has_type_is_type_of _ _ _ _ H1'). *)
(*     clearbody H1 H1'; clear Hty Hty'. *)
(*     unfold h1, h2, h1', h2' in *; clear h1 h2 h1' h2'; subst. *)
(*     unfold ty, ty0 in *; clear ty ty0; subst. *)
(*     revert  H_wt H_wt0 H fi H1 H1' Rty'. *)
(*     generalize (type_of vtypes v a) as ty; *)
(*       generalize (type_of vtypes v a') as ty'; intros; subst. *)
(*     set (Z := interp vtypes v a ty') in *; clearbody Z. *)
(*     set (Z' := interp vtypes v a' ty') in *; clearbody Z'. *)
(*     destruct (has_type vtypes v a ty'); try discriminate. *)
(*     destruct (has_type vtypes v a' ty'); try discriminate. *)
(*     inversion H; subst. *)
(*     rewrite (BoolEqDep.UIP _ _ H1 H1'), (BoolEqDep.UIP_refl _ H1'). *)
(*     rewrite (BoolEqDep.UIP _ _ H_wt0 H_wt), (BoolEqDep.UIP_refl _ H_wt) in H2. *)
(*     exact (TypeEqDep.inj_pairT2 _ _ _ _ H2). *)

(*     assert (Rty := has_type_is_type_of _ _ _ _ H1). *)
(*     assert (Rty' := has_type_is_type_of _ _ _ _ H1'). *)
(*     clearbody H1 H1'; clear Hty Hty'. *)
(*     unfold h1, h2, h1', h2' in *; clear h1 h2 h1' h2'; subst. *)
(*     congruence. *)
(*   Qed. *)

(*   Property eq2_congr : forall f l l',  *)
(*     eq2_terms l l' -> eq2 (app f l) (app f l'). *)
(*   Proof. *)
(*     intros f l l' Heq. *)
(*     unfold eq2. *)
(*     assert (Teq := has_type_type_of_congr2 f l l' Heq). *)
(*     assert (icongr := fun H H' => *)
(*       interp_congr2 (type_of vtypes v (app f l)) f l l' H H' Heq). *)
(*     assert (R :=  type_of_congr2 f l l' Heq). *)
(*     do 2 decide int; subst. *)
(*     unfold ty, ty0 in *; clear ty ty0. *)
(*     admit. *)
(*     unfold ty in *; clear ty; congruence. *)
(*     unfold ty in *; clear ty; congruence. *)

(*     unfold interp'. *)
(*     revert Teq R icongr. *)
(*     generalize (type_of vtypes v (app f l)) as ty; *)
(*       generalize (type_of vtypes v (app f l')) as ty'. *)
(*     intros ty ? ? Teq icongr; subst. *)
(*     set (Z := interp vtypes v (app f l) ty) in *; clearbody Z. *)
(*     set (Z' := interp vtypes v (app f l') ty) in *; clearbody Z'. *)
(*     destruct (has_type vtypes v (app f l) ty); *)
(*       destruct (has_type vtypes v (app f l') ty); *)
(*         try discriminate; auto. *)
(*     rewrite (icongr (refl_equal _) (refl_equal _)); reflexivity. *)
(*   Qed. *)
(* End CanonicalStructure. *)
(* Print Assumptions model. *)