Require Export UnitaryListRepresentation.
Require Export SQIR.DensitySem.

Local Open Scope com_scope.
Local Close Scope R_scope.
Local Open Scope signature_scope.

(* This file extends UnitaryListRepr with a 'list of lists' representation
   for non-unitary programs. *)

(** List-of-lists representation for non-unitary programs. **)

Inductive instr (U: nat -> Set) (dim : nat): Set :=
| UC : gate_list U dim -> instr U dim
| Meas : nat -> list (instr U dim) -> list (instr U dim) -> instr U dim.

Definition com_list U dim := list (instr U dim).

Arguments UC {U dim}.
Arguments Meas {U dim}.

(** Useful operations on the com list representation. **)

Fixpoint does_not_reference_instr {U dim} q (i : instr U dim) :=
  match i with
  | UC u => does_not_reference u q
  | Meas n l1 l2 =>
      negb (q =? n) &&
      forallb (does_not_reference_instr q) l1 &&
      forallb (does_not_reference_instr q) l2
  end.
Definition does_not_reference_c {U dim} (l : com_list U dim) (q : nat) :=
  forallb (does_not_reference_instr q) l.

(* Get the next measurement operation on qubit q. *)
Fixpoint next_measurement {U dim} (l : com_list U dim) q :=
  match l with
  | [] => None
  | UC u :: t =>
      if does_not_reference u q
      then match next_measurement t q with
           | None => None
           | Some (l1, l1', l2', l2) =>
               Some (UC u :: l1, l1', l2', l2)
           end
      else None
  | Meas n l1 l2 :: t =>
      if q =? n
      then Some ([], l1, l2, t)
      else if does_not_reference_c l1 q && does_not_reference_c l2 q
           then match next_measurement t q with
                | None => None
                | Some (l1', l1'', l2'', l2') =>
                    Some (Meas n l1 l2 :: l1', l1'', l2'', l2')
                end
           else None
  end.

(* Count the number of UC/Meas operations in a non-unitary program. This is useful
   when we're too lazy to write functions in a nested recursive style & use the
   special induction principle 'com_list_ind'. Instead, we can use the result of
   this function as initial fuel to a function and recurse on the size of the fuel.
   (This only works if the function in question performs N operations where N
   can be over-approximated by an expression involving count_ops.) *)
Fixpoint count_ops_instr {U dim} (i : instr U dim) :=
  match i with
  | UC u => 1%nat
  | Meas n l1 l2 =>
      let fix f l := match l with
                     | [] => O
                     | h :: t => (count_ops_instr h + f t)%nat
                     end in
      (1 + f l1 + f l2)%nat
  end.
Fixpoint count_ops {U dim} (l : com_list U dim) :=
  match l with
  | [] => O
  | h :: t => (count_ops_instr h + count_ops t)%nat
  end.

(* 'canonicalize' a non-unitary program by combining adjacent UC terms and
   removing empty UC terms. This will allow for more effective application
   of unitary optimizations (and nicer printing). *)
Fixpoint canonicalize_com_l' {U dim} (l : com_list U dim) n : com_list U dim :=
  match n with
  | O => l
  | S n' => match l with
           | [] => []
           | Meas n l1 l2 :: t =>
               let l1' := canonicalize_com_l' l1 n' in
               let l2' := canonicalize_com_l' l2 n' in
               Meas n l1' l2' :: (canonicalize_com_l' t n')
           | UC [] :: t => canonicalize_com_l' t n'
           | UC u1 :: UC u2 :: t => canonicalize_com_l' ((UC (u1 ++ u2)) :: t) n'

           | h :: t => h :: (canonicalize_com_l' t n')
           end
  end.
Definition canonicalize_com_l {U dim} (l : com_list U dim) :=
  canonicalize_com_l' l (count_ops l).

(** Correctness properties for non-unitary programs. **)

Module NUListProofs (G : GateSet).

Module UL := UListProofs G.
Export UL.

(* Well-typedness *)
Inductive c_well_typed_l {dim} : com_list G.U dim -> Prop :=
| WT_nilc : c_well_typed_l []
| WT_UC : forall u t, uc_well_typed_l u -> c_well_typed_l t -> c_well_typed_l ((UC u) :: t)
| WT_Meas : forall n l1 l2 t, (n < dim)%nat -> c_well_typed_l l1 -> c_well_typed_l l2
            -> c_well_typed_l t -> c_well_typed_l ((Meas n l1 l2) :: t).

(* Induction principle for com_list *)
Section com_list_ind.
  Variable dim : nat.
  Variable P : com_list G.U dim -> Prop.

  Hypothesis Nil_case : P ([] : com_list G.U dim).
  Hypothesis UC_case : forall (u : gate_list G.U dim) t,
    P t -> P ((UC u) :: t).
  Hypothesis Meas_case : forall n (l1 l2 : com_list G.U dim) t,
    P l1 -> P l2 -> P t -> P ((Meas n l1 l2) :: t).

  Fixpoint instr_ind_aux (i : instr G.U dim) :=
    match i with
    | UC u => (fun t Pft => UC_case u t Pft)
    | Meas n l1 l2 =>
        let fix f (l : com_list G.U dim) :=
           match l with
           | [] => Nil_case
           | h :: t => instr_ind_aux h t (f t)
           end in
        (fun t Pft => Meas_case n l1 l2 t (f l1) (f l2) Pft)
    end.

  Fixpoint com_list_ind (l : com_list G.U dim) : P l :=
    match l with
    | [] => Nil_case
    | h :: t => instr_ind_aux h t (com_list_ind t)
    end.

End com_list_ind.

(* Conversion to the base gate set - written awkwardly to convince Coq of
   termination. *)
Fixpoint instr_to_com {dim} (i : instr G.U dim) : base_com dim :=
  match i with
  | UC u => uc (list_to_ucom u)
  | Meas n l1 l2 =>
      let fix f l := match l with
                     | [] => skip
                     | h :: t => instr_to_com h ; f t
                     end in
      meas n (f l1) (f l2)
  end.
Fixpoint list_to_com {dim} (l : com_list G.U dim) : base_com dim :=
  match l with
  | [] => skip
  | h :: t => instr_to_com h ; list_to_com t
  end.

Lemma instr_to_com_UC : forall dim (u : gate_list G.U dim),
  instr_to_com (UC u) = uc (list_to_ucom u).
Proof. intros. reflexivity. Qed.

Lemma instr_to_com_Meas : forall dim n (l1 : com_list G.U dim) l2,
  instr_to_com (Meas n l1 l2) = meas n (list_to_com l1) (list_to_com l2).
Proof.
  intros.
  simpl.
  apply f_equal2.
  - induction l1; try rewrite IHl1; reflexivity.
  - induction l2; try rewrite IHl2; reflexivity.
Qed.
Global Opaque instr_to_com.
Hint Rewrite instr_to_com_UC instr_to_com_Meas.

Lemma list_to_com_append : forall {dim} (l1 l2 : com_list G.U dim),
  list_to_com (l1 ++ l2) ≡ list_to_com l1 ; list_to_com l2.
Proof.
  intros dim l1 l2.
  unfold c_equiv.
  induction l1; simpl; try reflexivity.
  destruct a; simpl; intros;
  unfold compose_super; rewrite IHl1;
  auto with wf_db.
Qed.

Lemma list_to_com_WT : forall {dim} (l : com_list G.U dim),
  c_well_typed_l l <-> c_well_typed (list_to_com l).
Proof.
  intros; split; intros H.
  - induction H; constructor;
    try rewrite instr_to_com_UC; try rewrite instr_to_com_Meas; try constructor;
    auto.
    apply list_to_ucom_WT. assumption.
  - induction l using (com_list_ind dim); inversion H; subst;
    try rewrite instr_to_com_UC in H2; try rewrite instr_to_com_Meas in H2; try inversion H2; subst;
    constructor; auto.
    apply list_to_ucom_WT. assumption.
Qed.

(** Equivalences over non-unitary programs. **)

Definition c_equiv_l {dim} (l1 l2 : com_list G.U dim) :=
  list_to_com l1 ≡ list_to_com l2.
Infix "=l=" := c_equiv_l (at level 70) : com_scope.

Lemma c_equiv_l_refl : forall {dim} (l1 : com_list G.U dim), l1 =l= l1.
Proof. easy. Qed.

Lemma c_equiv_l_sym : forall {dim} (l1 l2 : com_list G.U dim), l1 =l= l2 -> l2 =l= l1.
Proof. unfold c_equiv_l. easy. Qed.

Lemma c_equiv_l_trans : forall {dim} (l1 l2 l3 : com_list G.U dim),
  l1 =l= l2 -> l2 =l= l3 -> l1 =l= l3.
Proof. unfold c_equiv_l. intros dim l1 l2 l3 H12 H23. rewrite H12. easy. Qed.

Lemma c_cons_congruence : forall {dim} (i : instr G.U dim)  (l l' : com_list G.U dim),
  l =l= l' ->
  i :: l =l= i :: l'.
Proof.
  unfold c_equiv_l.
  intros dim i l l' Hl.
  simpl. rewrite Hl. reflexivity.
Qed.

Lemma c_app_congruence : forall {dim} (l1 l1' l2 l2' : com_list G.U dim),
  l1 =l= l1' ->
  l2 =l= l2' ->
  l1 ++ l2 =l= l1' ++ l2'.
Proof.
  unfold c_equiv_l.
  intros dim l1 l1' l2 l2' Hl1 Hl2.
  repeat rewrite list_to_com_append; simpl.
  rewrite Hl1, Hl2.
  reflexivity.
Qed.

Add Parametric Relation (dim : nat) : (com_list G.U dim) (@c_equiv_l dim)
  reflexivity proved by c_equiv_l_refl
  symmetry proved by c_equiv_l_sym
  transitivity proved by c_equiv_l_trans
  as c_equiv_l_rel.

Add Parametric Morphism (dim : nat) : (@List.cons (instr G.U dim))
  with signature eq ==> (@c_equiv_l dim) ==> (@c_equiv_l dim) as c_cons_mor.
Proof. intros y x0 y0 H0. apply c_cons_congruence; easy. Qed.

Add Parametric Morphism (dim : nat) : (@app (instr G.U dim))
  with signature (@c_equiv_l dim) ==> (@c_equiv_l dim) ==> (@c_equiv_l dim) as c_app_mor.
Proof. intros x y H x0 y0 H0. apply c_app_congruence; easy. Qed.

Lemma uc_equiv_l_implies_c_equiv_l : forall dim (u u' : gate_list G.U dim),
  (u =l= u')%ucom ->
  [UC u] =l= [UC u'].
Proof.
  unfold uc_equiv_l, uc_equiv, c_equiv_l, c_equiv.
  intros dim u u' H Hdim ρ WFρ.
  simpl.
  repeat rewrite instr_to_com_UC.
  simpl; rewrite H; reflexivity.
Qed.

Lemma UC_append : forall {dim} (l1 l2: gate_list G.U dim),
  [UC (l1 ++ l2)] =l= [UC l1] ++ [UC l2].
Proof.
  intros.
  unfold c_equiv_l, c_equiv; simpl.
  intros.
  repeat rewrite instr_to_com_UC; simpl.
  rewrite list_to_ucom_append; simpl.
  rewrite compose_super_assoc.
  unfold compose_super, super. Msimpl.
  repeat rewrite Mmult_assoc.
  reflexivity.
Qed.

Lemma UC_nil : forall dim,
  [UC []] =l= ([] : com_list G.U dim).
Proof.
  unfold c_equiv_l, c_equiv.
  intros; simpl.
  rewrite instr_to_com_UC; simpl.
  unfold compose_super, super.
  rewrite denote_SKIP; try assumption.
  Msimpl; reflexivity.
Qed.

(* Also useful to have a congruence lemma for rewriting inside Meas. *)
Definition c_eval_l {dim} (l : com_list G.U dim) := c_eval (list_to_com l).
Local Coercion Nat.b2n : bool >-> nat.
Definition project_onto {dim} ρ n (b : bool) := super (@pad 1 n dim (∣b⟩ × ∣b⟩†)) ρ.
Lemma Meas_cons_congruence : forall dim n (l1 l2 l1' l2' l l' : com_list G.U dim),
  (forall ρ, WF_Matrix ρ ->
   c_eval_l l1 (project_onto ρ n true) = c_eval_l l1' (project_onto ρ n true)) ->
  (forall ρ, WF_Matrix ρ ->
   c_eval_l l2 (project_onto ρ n false) = c_eval_l l2' (project_onto ρ n false)) ->
  l =l= l' ->
  Meas n l1 l2 :: l =l= Meas n l1' l2' :: l'.
Proof.
  intros.
  unfold c_equiv_l; simpl.
  repeat rewrite instr_to_com_Meas.
  apply seq_congruence; auto.
  unfold c_equiv; simpl.
  intros Hdim ρ WFρ.
  unfold Splus, compose_super; simpl.
  unfold c_eval_l, project_onto in *.
  simpl in *.
  rewrite H, H0; auto.
Qed.

Lemma does_not_reference_instr_UC : forall dim q (u : gate_list G.U dim),
  does_not_reference_instr q (UC u) = does_not_reference u q.
Proof. intros. reflexivity. Qed.

Lemma does_not_reference_instr_Meas : forall dim q n (l1 : com_list G.U dim) l2,
  does_not_reference_instr q (Meas n l1 l2) = negb (q =? n) && does_not_reference_c l1 q && does_not_reference_c l2 q.
Proof.
  intros.
  simpl.
  apply f_equal2; [apply f_equal2 |].
  - reflexivity.
  - induction l1; simpl; try rewrite IHl1; reflexivity.
  - induction l2; simpl; try rewrite IHl2; reflexivity.
Qed.
Global Opaque does_not_reference_instr.

Lemma next_measurement_preserves_structure : forall dim (l : com_list G.U dim) q l1 l1' l2' l2,
  next_measurement l q = Some (l1, l1', l2', l2) ->
  l = l1 ++ [Meas q l1' l2'] ++ l2.
Proof.
  intros.
  generalize dependent l1.
  induction l; intros.
  - inversion H.
  - simpl in H.
    destruct a.
    + destruct (does_not_reference g q); try discriminate.
      destruct (next_measurement l q); try discriminate.
      do 3 destruct p.
      inversion H; subst.
      rewrite IHl with (l1:=l4); reflexivity.
    + bdestruct (q =? n).
      inversion H; subst. reflexivity.
      destruct (does_not_reference_c l0 q && does_not_reference_c l3 q); try discriminate.
      destruct (next_measurement l q); try discriminate.
      do 3 destruct p.
      inversion H; subst.
      rewrite IHl with (l1:=l6); reflexivity.
Qed.

Lemma next_measurement_l1_does_not_reference : forall {dim} (l : com_list G.U dim) q l1 l1' l2' l2,
  next_measurement l q = Some (l1, l1', l2', l2) ->
  does_not_reference_c l1 q = true.
Proof.
  intros.
  generalize dependent l1.
  induction l; intros.
  - inversion H.
  - simpl in H.
    destruct a.
    + destruct (does_not_reference g q) eqn:dnr; try discriminate.
      destruct (next_measurement l q) eqn:nm; try discriminate.
      do 3 destruct p.
      inversion H; subst.
      simpl.
      apply andb_true_intro; split.
      assumption.
      rewrite IHl with (l1:=l4); reflexivity.
    + bdestruct (q =? n).
      inversion H; subst. reflexivity.
      destruct (does_not_reference_c l0 q) eqn:dnrl0.
      destruct (does_not_reference_c l3 q) eqn:dnrl3.
      all: simpl in H; try discriminate.
      destruct (next_measurement l q) eqn:Hnm; try discriminate.
      do 3 destruct p.
      inversion H; subst.
      simpl.
      rewrite does_not_reference_instr_Meas.
      repeat (try apply andb_true_intro; split).
      apply negb_true_iff; apply Nat.eqb_neq; assumption.
      all: try assumption.
      rewrite IHl with (l1:=l6); reflexivity.
Qed.

Lemma only_uses_commutes_pad1 : forall {dim} (u : base_ucom dim) q qs (A : Square 2),
  WF_Matrix A ->
  only_uses u qs ->
  not (In q qs) ->
  (@pad 1 q dim A) × uc_eval u = uc_eval u × (@pad 1 q dim A).
Proof.
  intros dim u q qs A WFA Hou Hin.
  induction Hou; simpl.
  - rewrite <- Mmult_assoc.
    rewrite IHHou2; auto.
    rewrite Mmult_assoc.
    rewrite IHHou1; auto.
    rewrite <- Mmult_assoc.
    reflexivity.
  - assert (H0: q <> q0).
    intro contra; subst; auto.
    clear - WFA H0.
    dependent destruction u.
    autorewrite with eval_db.
    gridify; trivial.
  - assert (H1: q <> q1).
    intro contra; subst; auto.
    assert (H2: q <> q2).
    intro contra; subst; auto.
    clear - WFA H1 H2.
    autorewrite with eval_db.
    gridify; trivial.
  - dependent destruction u.
Qed.

Lemma does_not_reference_c_commutes_app1 : forall {dim} (l : com_list G.U dim) u q,
  does_not_reference_c l q = true ->
  [UC [App1 u q]] ++ l =l= l ++ [UC [App1 u q]].
Proof.
  intros dim l u q H.
  induction l using (com_list_ind dim); try reflexivity.
  - simpl in H.
    apply andb_true_iff in H as [Hu0 Hl].
    rewrite <- (app_comm_cons _ _ (UC u0)).
    rewrite <- IHl; try assumption.
    rewrite (cons_to_app (UC u0)).
    rewrite (cons_to_app (UC u0) (_ ++ l)).
    repeat rewrite app_assoc.
    apply c_app_congruence; try reflexivity.
    rewrite does_not_reference_instr_UC in Hu0.
    repeat rewrite <- UC_append.
    apply uc_equiv_l_implies_c_equiv_l.
    apply does_not_reference_commutes_app1.
    assumption.
  - simpl in H.
    apply andb_true_iff in H as [Hmeas Hl3].
    rewrite <- (app_comm_cons _ _ (Meas n l1 l2)).
    rewrite <- IHl3; try assumption.
    rewrite (cons_to_app (Meas n l1 l2)).
    rewrite (cons_to_app (Meas n l1 l2) (_ ++ l3)).
    repeat rewrite app_assoc.
    apply c_app_congruence; try reflexivity.
    rewrite does_not_reference_instr_Meas in Hmeas.
    apply andb_true_iff in Hmeas as [Hmeas Hl2].
    apply andb_true_iff in Hmeas as [Hq Hl1].
    apply IHl1 in Hl1.
    apply IHl2 in Hl2.
    apply negb_true_iff in Hq.
    apply Nat.eqb_neq in Hq.
    clear - Hq Hl1 Hl2.
    unfold c_equiv_l in *.
    repeat rewrite list_to_com_append in Hl1, Hl2.
    simpl in *.
    rewrite instr_to_com_UC in *.
    rewrite instr_to_com_Meas in *.
    unfold c_equiv in *; simpl in *.
    intros Hdim ρ WFρ.
    unfold compose_super, Splus in *.
    rewrite denote_SKIP in *; try assumption.
    rewrite Mmult_1_l in *; try auto with wf_db.
    remember (uc_eval (G.to_base u [q] (one_elem_list q))) as U.
    remember (proj n dim true) as pad1.
    remember (proj n dim false) as pad0.
    replace (super pad1 (super U ρ)) with (super U (super pad1 ρ)).
    2: { subst; clear - Hq.
         unfold super.
         repeat rewrite Mmult_assoc.
         rewrite <- 2 Mmult_adjoint.
         repeat rewrite <- Mmult_assoc.
         unfold proj, pad_u.
         rewrite only_uses_commutes_pad1 with (qs:=[q]).
         reflexivity.
         auto with wf_db.
         apply G.to_base_only_uses_qs.
         intro contra.
         destruct_In; auto. }
    replace (super pad0 (super U ρ)) with (super U (super pad0 ρ)).
    2: { subst; clear - Hq.
         unfold super.
         repeat rewrite Mmult_assoc.
         rewrite <- 2 Mmult_adjoint.
         repeat rewrite <- Mmult_assoc.
         unfold proj, pad_u.
         rewrite only_uses_commutes_pad1 with (qs:=[q]).
         reflexivity.
         auto with wf_db.
         apply G.to_base_only_uses_qs.
         intro contra.
         destruct_In; auto. }
    rewrite Hl1, Hl2; auto.
    2, 3: subst; auto with wf_db.
    unfold super.
    rewrite <- Mmult_plus_distr_r.
    rewrite <- Mmult_plus_distr_l.
    reflexivity.
Qed.

End NUListProofs.


(**

This file describes tiling transformation relations as functions.

Author: Ramon Fernandez I Mir and Arthur Charguéraud.

License: MIT.

*)

Set Implicit Arguments.
Require Export Semantics LibSet LibMap TLCbuffer TrTiling.

(* ---------------------------------------------------------------------- *)
(** Explicit definitions *)

Fixpoint fun_tr_accesses (tt:tiling_tr) (π:accesses) : accesses :=
  let aux := fun_tr_accesses tt in
  match π with
  | nil => nil
  | ((access_array T i)::π') =>
      if isTrue(T = typ_var (tiling_tr_array_name tt)) then
        let K := tiling_tr_tile_size tt in
        let Tt := tiling_tr_tile_name tt in
        ((access_array T (i/K))::(access_array (typ_var Tt) (i mod K))::(aux π'))
      else
        ((access_array T i)::(aux π'))
  | ((access_field T f)::π') => ((access_field T f)::(aux π'))
  end.

Fixpoint fun_tr_val_depth (depth:nat) (tt:tiling_tr) (v:val) : val :=
  match depth with
    | O => v
    | S n =>
      let aux := fun_tr_val_depth n tt in
      match v with
      | val_error => val_error
      | val_uninitialized => val_uninitialized
      | val_unit => val_unit
      | val_bool b => val_bool b
      | val_int i => val_int i
      | val_double d => val_double d
      | val_abstract_ptr l π => val_abstract_ptr l (fun_tr_accesses tt π)
      | val_concrete_ptr l o => val_concrete_ptr l o (* TODO: This is not correct. *)
      | val_array T vs =>
          if isTrue(T = typ_var (tiling_tr_array_name tt)) then
            val_array T vs (* TODO: Critical case *)
          else
            (val_array T (LibList.map aux vs))
      | val_struct T s =>
          let m : monoid_op (map field val) := monoid_make (fun a b => a \u b) \{} in
          let g : field -> val -> map field val := fun f v => (\{})[f:=(aux v)] in
          val_struct T (fold m g s)
      | val_words lw => val_words lw (* TODO: Not correct either. *)
      end
   end.


From isla Require Import opsem.

Definition a80000 : isla_trace :=
  WriteReg "R0" [] (RegVal_Base (Val_Bits (BV 64%N 0xa0000%Z))) Mk_annot :t:
  Smt (DeclareConst 46%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 46%Z)) Mk_annot :t:
  Smt (DefineConst 47%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 46%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 47%Z)) Mk_annot :t:
  tnil
.


Require Import Coq.Lists.List.
Import ListNotations.

(** * What users need to know **)
(** ** Parameters *)

Inductive connective :=
| impp
| andp
| orp
| falsep
| truep
| negp
| iffp
| coq_prop
| sepcon
| wand
| emp
| multi_imp
| iter_andp
| iter_sepcon
| empty_context
| join
| is_unit.

Inductive judgement :=
| provable
| derivable
| derivable1
| logic_equiv
| corable.

Inductive type :=
| model
| expr
| context.

Inductive parameter :=
| CP (c: connective)
| JP (j: judgement)
| TP (t: type).

Coercion CP: connective >-> parameter.
Coercion JP: judgement >-> parameter.
Coercion TP: type >-> parameter.

Inductive how_connective :=
| primitive_connective (c: connective)
| ___predicate_over_states (mono: bool) (c: connective)
| FROM_andp_impp_TO_iffp
| FROM_falsep_impp_TO_negp
| FROM_falsep_impp_TO_truep
| FROM_impp_negp_TO_orp
| FROM_negp_falsep_TO_truep
| FROM_negp_truep_TO_falsep
| FROM_impp_TO_multi_imp
| FROM_andp_TO_iter_andp
| FROM_sepcon_TO_iter_sepcon
| FROM_empty_set_TO_empty_context
| FROM_join_TO_sepcon
| FROM_model_TO_impp
| FROM_model_TO_andp
| FROM_model_TO_orp
| FROM_model_TO_coq_prop
| FROM_unit_TO_emp
| FROM_model_TO_truep
.

Definition primitive_connectives := map primitive_connective.
Definition predicate_over_states := ___predicate_over_states false.
Definition mpredicate_over_states := ___predicate_over_states true.
Definition predicates_over_states := map predicate_over_states.
Definition mpredicates_over_states := map mpredicate_over_states.

Inductive how_judgement :=
| primitive_judgement (j: judgement)
| ___USE_valid_FOR_provable (mono: bool)
| ___USE_consequence_FOR_derivable (mono fin: bool)
| FROM_provable_TO_derivable
| FROM_derivable_TO_provable
| FROM_provable_TO_derivable1
| FROM_provable_TO_logic_equiv
| FROM_derivable1_TO_logic_equiv(*
| FROM_derivable1_TO_provable*)
| FROM_model_TO_provable.

Definition USE_valid_FOR_provable := ___USE_valid_FOR_provable false.
Definition USE_mono_valid_FOR_provable := ___USE_valid_FOR_provable true.
Definition USE_conseq_FOR_derivable :=
  ___USE_consequence_FOR_derivable false false.
Definition USE_mono_conseq_FOR_derivable :=
  ___USE_consequence_FOR_derivable true false.
Definition USE_fin_conseq_FOR_derivable :=
  ___USE_consequence_FOR_derivable false true.
Definition USE_mono_fin_conseq_FOR_derivable :=
  ___USE_consequence_FOR_derivable true true.

(* TODO: Add coq_prop for derivitive1 *)
Inductive rule_class :=
| provability_OF_impp
| provability_OF_andp
| provability_OF_orp
| provability_OF_falsep
| provability_OF_truep
| provability_OF_iffp
| provability_OF_negp
| provability_OF_iter_andp
| provability_OF_de_morgan
| provability_OF_godel_dummett
| provability_OF_classical_logic
| provability_OF_classical_logic_peirce
| provability_OF_classical_logic_by_contra
| provability_OF_classical_logic_double_negp
| provability_OF_classical_logic_canalysis
| provability_OF_classical_logic_EM
| provability_OF_classical_logic_impp_orp
| provability_OF_coq_prop
| provability_OF_coq_prop_impp
| provability_OF_sepcon_rule
| provability_OF_wand_rule
| provability_OF_emp_rule
| provability_OF_iter_sepcon
| provability_OF_sepcon_orp_rule
| provability_OF_sepcon_falsep_rule
| provability_OF_sepcon_coq_prop
| provability_OF_sepcon_rule_AS_weak
| provability_OF_sepcon_rule_AS_weak_iffp
| provability_OF_sepcon_rule_AS_mono
| provability_OF_emp_rule_AS_iffp
| provability_OF_garbage_collected_sl
| derivitive_OF_basic_setting
| derivitive_OF_finite_derivation
| derivitive_OF_impp
| derivitive_OF_andp
| derivitive_OF_orp
| derivitive_OF_falsep
| derivitive_OF_truep
| derivitive_OF_iffp
| derivitive_OF_negp
| derivitive_OF_de_morgan
| derivitive_OF_godel_dummett
| derivitive_OF_classical_logic
| derivitive1_OF_basic_setting
| derivitive1_OF_impp_andp_adjoint
| derivitive1_OF_andp
| derivitive1_OF_orp
| derivitive1_OF_falsep
| derivitive1_OF_truep
| derivitive1_OF_iffp
| derivitive1_OF_negp
| derivitive1_OF_impp_negp
| derivitive1_OF_sepcon
| derivitive1_OF_wand
| derivitive1_OF_emp
| derivitive1_OF_sepcon_orp_rule
| derivitive1_OF_sepcon_falsep_rule
| equivalence_OF_basic_setting
| equivalence_OF_impp
| corability_OF_basic_setting
| corability_OF_coq_prop
| GEN_iffp_FROM_andp_impp
| GEN_truep_FROM_falsep_impp
| GEN_negp_FROM_falsep_impp
| GEN_orp_FROM_impp_negp
| GEN_truep_FROM_impp_self
| GEN_truep_FROM_negp_falsep
| GEN_falsep_FROM_negp_truep
| GEN_iter_andp_FROM_fold_left_andp
| GEN_iter_andp_FROM_fold_right_andp
| GEN_iter_sepcon_FROM_fold_left_sepcon
| GEN_iter_sepcon_FROM_fold_right_sepcon
| GEN_derivable_FROM_provable
| GEN_provable_FROM_derivable
| GEN_derivable1_FROM_provable
| GEN_logic_equiv_FROM_provable
| GEN_logic_equiv_FROM_derivable1
| GEN_sepcon_FROM_join
| join_is_SA
| GEN_impp_FROM_model
| GEN_provable_FROM_model
| GEN_andp_FROM_model
| GEN_orp_FROM_model
| GEN_coq_prop_FROM_model
| GEN_emp_FROM_unit
| GEN_truep_FROM_model
.

(** * What users need not to know **)
(** ** Parameters *)

Inductive how_type :=
| primitive_type (t: type)
| FROM_predicate_over_states_TO_expr
| FROM_mpredicate_over_states_TO_expr
| FROM_ensemble_expr_TO_context
| FROM_model_TO_expr
.

Notation "'ht_restriction'" := (list how_type).

Inductive type_class :=
| Language
| Model
.

Inductive connective_class :=
| MinimumLanguage
| AndLanguage
| OrLanguage
| FalseLanguage
| TrueLanguage
| IffLanguage
| NegLanguage
| CoqPropLanguage
| SepconLanguage
| WandLanguage
| EmpLanguage
| IterAndLanguage
| IterSepconLanguage
| Join
| Unit
.

Inductive judgement_class :=
| Provable
| Derivable
| Derivable1
| LogicEquiv
| Corable
.

Inductive any_class :=
| TC (tc: type_class)
| CC (cc: connective_class)
| JC (jc: judgement_class)
| RC (rc: rule_class)
.

Definition how_instance: Type := nat.

Definition primary_rule: Type := nat.

Definition derived_rule: Type := nat.

(** ** Output *)

Module Output.
Record output: Type := {
  primitive_types: list type;
  transparent_types: list type;
  derived_types: list how_type;
  primitive_connectives: list connective;
  transparent_connectives: list connective;
  derived_connectives: list how_connective;
  primitive_judgements: list judgement;
  transparent_judgements: list judgement;
  derived_judgements: list how_judgement;
  primitive_classes: list any_class;
  refl_classes_for_derivation: list any_class;
  how_derive_classes: list how_instance;
  primary_rules: list primary_rule;
  derived_primary_rules: list primary_rule;
  derived_derived_rules: list derived_rule;
  derived_rules_as_instance: list derived_rule
}.
End Output.

(** ** Auxiliary functions *)

Definition force_val_list {T: Type} (ol: option (list T)): list T :=
  match ol with
  | Some l => l
  | None => nil
  end.

Definition is_Some {T: Type} (o: option T): bool :=
  match o with
  | Some _ => true
  | _ => false
  end.

Definition is_nil {T: Type} (l: list T): bool :=
  match l with
  | nil => true
  | _ => false
  end.

Fixpoint valid_sublist {T: Type} (ol: list (option T)): list T :=
  match ol with
  | nil => nil
  | (Some x) :: ol0 => x :: valid_sublist ol0
  | None :: ol0 => valid_sublist ol0
  end.

(* TODO Check Standard Library *)
Module Type DecTypeSig.

  Parameter Inline t: Type.

  Parameter eqb: t -> t -> bool.

  Axiom eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).

End DecTypeSig.

Module ListFunOverDecType (DTS: DecTypeSig).
Import DTS.

Definition shrink (l: list t): list t :=
  fold_right (fun x l => if (existsb (eqb x) l) then l else x :: l) [] l.

Definition set_minus (l1 l2: list t): list t :=
  filter (fun x => negb (existsb (eqb x) l2)) l1.

Definition set_minus1 (l: list t) (x: t): list t :=
  filter (fun x0 => negb (eqb x0 x)) l.

Definition test_element (x: t) (l: list t): bool :=
  existsb (eqb x) l.

Fixpoint test_no_dup (l: list t): bool :=
  match l with
  | nil => true
  | x :: l0 => negb (test_element x l0) && test_no_dup l0
  end.

Definition test_sublist (l1 l2: list t): bool :=
  forallb (fun x => test_element x l2) l1.

Fixpoint inv_with_hint {A: Type} (f: A -> t) (hint: list A) (x: t): option A :=
  match hint with
  | nil => None
  | a :: hint0 => if eqb x (f a) then Some a else inv_with_hint f hint0 x
  end.

Definition map_inv_with_hint {A: Type}
           (f: A -> t) (hint: list A) (l: list t): list A :=
  valid_sublist (map (inv_with_hint f hint) l).

Fixpoint inj_with_hint {A: Type} (l1: list t) (l2: list A) (x: t) :=
  match l1, l2 with
  | cons a l1', cons v l2' =>
    if eqb a x then Some v else inj_with_hint l1' l2' x
  | _, _ => None
  end.

Definition map_with_hint {A: Type} (l1: list t) (l2: list A) (l: list t) :=
  valid_sublist (map (inj_with_hint l1 l2) l).

Section topo_sort.

Fixpoint pick_one {A: Type} (cur: list (list t * t * A)): option (t * A) :=
  match cur with
  | nil => None
  | (nil, x, a) :: _ => Some (x, a)
  | _ :: cur0 => pick_one cur0
  end.

Definition reduce_one {A: Type}
           (cur: list (list t * t * A)) (x: t): list (list t * t * A) :=
  filter
    (fun d => negb (eqb x (snd (fst d))))
    (map (fun d => (set_minus1 (fst (fst d)) x, snd (fst d), snd d)) cur).

Fixpoint topo_sort_rec {A: Type}
         (cur: list (list t * t * A)) (res: list A) (n: nat): list A :=
  match n with
  | O => res
  | S n0 => let ox := pick_one cur in
            match ox with
            | None => res
            | Some (x, a) => let cur0 := reduce_one cur x in
                             topo_sort_rec cur0 (a :: res) n0
            end
  end.

Definition topo_sort {A: Type} (diag: list (list t * t * A)) :=
  let res := topo_sort_rec diag nil (length diag) in
  rev res.

End topo_sort.

End ListFunOverDecType.

Module CType <: DecTypeSig.

Definition t := type.

Definition eqb (t1 t2: type) :=
  match t1, t2 with
  | expr, expr => true
  | context, context => true
  | model, model => true
  | _, _ => false
  end.

Lemma eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros.
  destruct x, y; simpl;
    try constructor; try solve [auto | congruence].
Qed.

End CType.

Module CTypeList := ListFunOverDecType CType.

Module HowType <: DecTypeSig.

Definition t := how_type.

Definition eqb (ht1 ht2: how_type) :=
  match ht1, ht2 with
  | primitive_type t1, primitive_type t2 => CType.eqb t1 t2
  | FROM_predicate_over_states_TO_expr, FROM_predicate_over_states_TO_expr => true
  | FROM_mpredicate_over_states_TO_expr, FROM_mpredicate_over_states_TO_expr => true
  | FROM_ensemble_expr_TO_context, FROM_ensemble_expr_TO_context => true
  | FROM_model_TO_expr, FROM_model_TO_expr => true
  | _, _ => false
  end.

Lemma eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros.
  destruct x, y; simpl;
    try constructor; try solve [auto | congruence].
  pose proof CType.eqb_spec t0 t1.
  destruct (CType.eqb t0 t1).
  + inversion H; constructor.
    subst; auto.
  + inversion H; constructor.
    congruence.
Qed.

End HowType.

Module HowTypeList := ListFunOverDecType HowType.

Module Connective <: DecTypeSig.

Definition t := connective.

Definition eqb (c1 c2: connective) :=
match c1, c2 with
| impp, impp
| andp, andp
| orp, orp
| falsep, falsep
| truep, truep
| negp, negp
| iffp, iffp
| coq_prop, coq_prop
| sepcon, sepcon
| wand, wand
| emp, emp
| multi_imp, multi_imp
| iter_andp, iter_andp
| iter_sepcon, iter_sepcon
| empty_context, empty_context => true
| join, join => true
| is_unit, is_unit => true
| _, _ => false
end.

Lemma eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros.
  destruct x, y; simpl;
    try constructor; try solve [auto | congruence].
Qed.

End Connective.

Module ConnectiveList := ListFunOverDecType Connective.

Module Judgement <: DecTypeSig.

Definition t := judgement.

Definition eqb (j1 j2: judgement) :=
match j1, j2 with
| provable, provable
| derivable, derivable
| derivable1, derivable1
| logic_equiv, logic_equiv
| corable, corable => true
| _, _ => false
end.

Lemma eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros.
  destruct x, y; simpl;
    try constructor; try solve [auto | congruence].
Qed.

End Judgement.

Module JudgementList := ListFunOverDecType Judgement.

Module CTypeClass.

Definition t := type_class.

Definition eqb (tc1 tc2: type_class) :=
match tc1, tc2 with
| Language, Language => true
| Model, Model => true
| _, _ => false
end.

Lemma eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros.
  destruct x, y; simpl;
    try constructor; try solve [auto | congruence].
Qed.

End CTypeClass.

Module CTypeClassList := ListFunOverDecType CTypeClass.

Module ConnectiveClass.

Definition t := connective_class.

Definition eqb (cc1 cc2: connective_class) :=
match cc1, cc2 with
| MinimumLanguage, MinimumLanguage
| AndLanguage, AndLanguage
| OrLanguage, OrLanguage
| FalseLanguage, FalseLanguage
| TrueLanguage, TrueLanguage
| IffLanguage, IffLanguage
| NegLanguage, NegLanguage
| CoqPropLanguage, CoqPropLanguage
| SepconLanguage, SepconLanguage
| WandLanguage, WandLanguage
| EmpLanguage, EmpLanguage
| IterAndLanguage, IterAndLanguage
| IterSepconLanguage, IterSepconLanguage => true
| Join, Join => true
| Unit, Unit => true
| _, _ => false
end.

Lemma eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros.
  destruct x, y; simpl;
    try constructor; try solve [auto | congruence].
Qed.

End ConnectiveClass.

Module ConnectiveClassList := ListFunOverDecType ConnectiveClass.

Module JudgementClass.

Definition t := judgement_class.

Definition eqb (jc1 jc2: judgement_class) :=
match jc1, jc2 with
| Provable, Provable
| Derivable, Derivable
| Derivable1, Derivable1
| LogicEquiv, LogicEquiv
| Corable, Corable => true
| _, _ => false
end.

Lemma eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros.
  destruct x, y; simpl;
    try constructor; try solve [auto | congruence].
Qed.

End JudgementClass.

Module JudgementClassList := ListFunOverDecType JudgementClass.

Module RuleClass.

Definition t := rule_class.

Definition eqb (rc1 rc2: rule_class) :=
match rc1, rc2 with
| provability_OF_impp, provability_OF_impp
| provability_OF_andp, provability_OF_andp
| provability_OF_orp, provability_OF_orp
| provability_OF_falsep, provability_OF_falsep
| provability_OF_truep, provability_OF_truep
| provability_OF_iffp, provability_OF_iffp
| provability_OF_negp, provability_OF_negp
| provability_OF_iter_andp, provability_OF_iter_andp
| provability_OF_de_morgan, provability_OF_de_morgan
| provability_OF_godel_dummett, provability_OF_godel_dummett
| provability_OF_classical_logic, provability_OF_classical_logic
| provability_OF_classical_logic_peirce, provability_OF_classical_logic_peirce
| provability_OF_classical_logic_by_contra, provability_OF_classical_logic_by_contra
| provability_OF_classical_logic_double_negp, provability_OF_classical_logic_double_negp
| provability_OF_classical_logic_canalysis, provability_OF_classical_logic_canalysis
| provability_OF_classical_logic_EM, provability_OF_classical_logic_EM
| provability_OF_classical_logic_impp_orp, provability_OF_classical_logic_impp_orp
| provability_OF_coq_prop, provability_OF_coq_prop
| provability_OF_coq_prop_impp, provability_OF_coq_prop_impp
| provability_OF_sepcon_rule, provability_OF_sepcon_rule
| provability_OF_wand_rule, provability_OF_wand_rule
| provability_OF_emp_rule, provability_OF_emp_rule
| provability_OF_iter_sepcon, provability_OF_iter_sepcon => true
| provability_OF_sepcon_orp_rule, provability_OF_sepcon_orp_rule => true
| provability_OF_sepcon_falsep_rule, provability_OF_sepcon_falsep_rule => true
| provability_OF_sepcon_coq_prop, provability_OF_sepcon_coq_prop => true
| provability_OF_sepcon_rule_AS_weak, provability_OF_sepcon_rule_AS_weak => true
| provability_OF_sepcon_rule_AS_weak_iffp, provability_OF_sepcon_rule_AS_weak_iffp => true
| provability_OF_sepcon_rule_AS_mono, provability_OF_sepcon_rule_AS_mono => true
| provability_OF_emp_rule_AS_iffp, provability_OF_emp_rule_AS_iffp => true
| provability_OF_garbage_collected_sl, provability_OF_garbage_collected_sl => true
| derivitive_OF_basic_setting, derivitive_OF_basic_setting
| derivitive_OF_finite_derivation, derivitive_OF_finite_derivation
| derivitive_OF_impp, derivitive_OF_impp
| derivitive_OF_andp, derivitive_OF_andp
| derivitive_OF_orp, derivitive_OF_orp
| derivitive_OF_falsep, derivitive_OF_falsep
| derivitive_OF_truep, derivitive_OF_truep
| derivitive_OF_iffp, derivitive_OF_iffp
| derivitive_OF_negp, derivitive_OF_negp
| derivitive_OF_de_morgan, derivitive_OF_de_morgan
| derivitive_OF_godel_dummett, derivitive_OF_godel_dummett
| derivitive_OF_classical_logic, derivitive_OF_classical_logic
| derivitive1_OF_basic_setting, derivitive1_OF_basic_setting
| derivitive1_OF_impp_andp_adjoint, derivitive1_OF_impp_andp_adjoint
| derivitive1_OF_andp, derivitive1_OF_andp
| derivitive1_OF_orp, derivitive1_OF_orp
| derivitive1_OF_falsep, derivitive1_OF_falsep
| derivitive1_OF_truep, derivitive1_OF_truep
| derivitive1_OF_iffp, derivitive1_OF_iffp
| derivitive1_OF_negp, derivitive1_OF_negp
| derivitive1_OF_impp_negp, derivitive1_OF_impp_negp
| derivitive1_OF_sepcon, derivitive1_OF_sepcon
| derivitive1_OF_wand, derivitive1_OF_wand
| derivitive1_OF_emp, derivitive1_OF_emp
| derivitive1_OF_sepcon_orp_rule, derivitive1_OF_sepcon_orp_rule
| derivitive1_OF_sepcon_falsep_rule, derivitive1_OF_sepcon_falsep_rule
| equivalence_OF_basic_setting, equivalence_OF_basic_setting
| equivalence_OF_impp, equivalence_OF_impp
| corability_OF_basic_setting, corability_OF_basic_setting
| corability_OF_coq_prop, corability_OF_coq_prop
| GEN_iffp_FROM_andp_impp, GEN_iffp_FROM_andp_impp
| GEN_truep_FROM_falsep_impp, GEN_truep_FROM_falsep_impp
| GEN_negp_FROM_falsep_impp, GEN_negp_FROM_falsep_impp
| GEN_orp_FROM_impp_negp, GEN_orp_FROM_impp_negp
| GEN_truep_FROM_impp_self, GEN_truep_FROM_impp_self
| GEN_truep_FROM_negp_falsep, GEN_truep_FROM_negp_falsep
| GEN_falsep_FROM_negp_truep, GEN_falsep_FROM_negp_truep
| GEN_iter_andp_FROM_fold_left_andp, GEN_iter_andp_FROM_fold_left_andp
| GEN_iter_andp_FROM_fold_right_andp, GEN_iter_andp_FROM_fold_right_andp
| GEN_iter_sepcon_FROM_fold_left_sepcon, GEN_iter_sepcon_FROM_fold_left_sepcon
| GEN_iter_sepcon_FROM_fold_right_sepcon, GEN_iter_sepcon_FROM_fold_right_sepcon
| GEN_derivable_FROM_provable, GEN_derivable_FROM_provable
| GEN_provable_FROM_derivable, GEN_provable_FROM_derivable
| GEN_derivable1_FROM_provable, GEN_derivable1_FROM_provable
| GEN_logic_equiv_FROM_provable, GEN_logic_equiv_FROM_provable
| GEN_logic_equiv_FROM_derivable1, GEN_logic_equiv_FROM_derivable1 => true
| GEN_sepcon_FROM_join, GEN_sepcon_FROM_join => true
| GEN_impp_FROM_model, GEN_impp_FROM_model => true
| GEN_provable_FROM_model, GEN_provable_FROM_model => true
| join_is_SA, join_is_SA => true
| GEN_andp_FROM_model, GEN_andp_FROM_model => true
| GEN_orp_FROM_model, GEN_orp_FROM_model => true
| GEN_coq_prop_FROM_model, GEN_coq_prop_FROM_model => true
| GEN_emp_FROM_unit, GEN_emp_FROM_unit => true
| GEN_truep_FROM_model, GEN_truep_FROM_model => true
| _, _ => false
end.

Lemma eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros.
  destruct x, y; simpl;
    try constructor; try solve [auto | congruence].
Qed.

End RuleClass.

Module RuleClassList := ListFunOverDecType RuleClass.

Module AllClass.

Definition t := any_class.

Definition eqb (ac1 ac2: any_class) :=
match ac1, ac2 with
| TC tc1, TC tc2 => CTypeClass.eqb tc1 tc2
| CC cc1, CC cc2 => ConnectiveClass.eqb cc1 cc2
| JC jc1, JC jc2 => JudgementClass.eqb jc1 jc2
| RC rc1, RC rc2 => RuleClass.eqb rc1 rc2
| _, _ => false
end.

Lemma eqb_spec: forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros.
  destruct x, y; simpl;
    try constructor; try solve [auto | congruence].
  + pose proof CTypeClass.eqb_spec tc tc0.
    destruct (CTypeClass.eqb tc tc0); inversion H; constructor; congruence.
  + pose proof ConnectiveClass.eqb_spec cc cc0.
    destruct (ConnectiveClass.eqb cc cc0); inversion H; constructor; congruence.
  + pose proof JudgementClass.eqb_spec jc jc0.
    destruct (JudgementClass.eqb jc jc0); inversion H; constructor; congruence.
  + pose proof RuleClass.eqb_spec rc rc0.
    destruct (RuleClass.eqb rc rc0); inversion H; constructor; congruence.
Qed.

End AllClass.

Module AllClassList := ListFunOverDecType AllClass.

Module NatList := ListFunOverDecType PeanoNat.Nat.


(* generated by Ott 0.25, locally-nameless from: Full.ott *)
Require Import LibLN.
(** syntax *)
 (*r Variables *)

Inductive trm : Set :=  (*r Expression *)
 | trm_var_b (_:nat) (*r Variable *)
 | trm_var_f (x5:var) (*r Variable *)
 | trm_star : trm (*r Type of Types *)
 | trm_top : trm (*r Top Value *)
 | trm_app (e1:trm) (e2:trm) (*r Application *)
 | trm_abs (e1:trm) (A:trm) (e2:trm) (*r Abstraction *)
 | trm_prod (e:trm) (A:trm) (B:trm) (*r Product *)
 | trm_castup (A:trm) (e:trm) (*r Up Cast *)
 | trm_castdn (e:trm) (*r Down Cast *)
 | trm_anno (e:trm) (A:trm) (*r Annotation *).

Inductive binding : Set :=  (*r Binding *)
 | bind_sub (e:trm) (A:trm) (*r Subtyping *).

Definition env := LibEnv.env binding.

(* EXPERIMENTAL *)
(** auxiliary functions on the new list types *)
(** library functions *)
(** subrules *)
(** arities *)
(** opening up abstractions *)
Fixpoint open_trm_wrt_trm_rec (k:nat) (e_5:trm) (e__6:trm) {struct e__6}: trm :=
  match e__6 with
  | (trm_var_b nat) => If (k = nat) then e_5 else (trm_var_b nat)
  | (trm_var_f x5) => trm_var_f x5
  | trm_star => trm_star
  | trm_top => trm_top
  | (trm_app e1 e2) => trm_app (open_trm_wrt_trm_rec k e_5 e1) (open_trm_wrt_trm_rec k e_5 e2)
  | (trm_abs e1 A e2) => trm_abs (open_trm_wrt_trm_rec k e_5 e1) (open_trm_wrt_trm_rec k e_5 A) (open_trm_wrt_trm_rec (S k) e_5 e2)
  | (trm_prod e A B) => trm_prod (open_trm_wrt_trm_rec k e_5 e) (open_trm_wrt_trm_rec k e_5 A) (open_trm_wrt_trm_rec (S k) e_5 B)
  | (trm_castup A e) => trm_castup (open_trm_wrt_trm_rec k e_5 A) (open_trm_wrt_trm_rec k e_5 e)
  | (trm_castdn e) => trm_castdn (open_trm_wrt_trm_rec k e_5 e)
  | (trm_anno e A) => trm_anno (open_trm_wrt_trm_rec k e_5 e) (open_trm_wrt_trm_rec k e_5 A)
end.

Definition open_binding_wrt_trm_rec (k:nat) (e5:trm) (b5:binding) : binding :=
  match b5 with
  | (bind_sub e A) => bind_sub (open_trm_wrt_trm_rec k e5 e) (open_trm_wrt_trm_rec k e5 A)
end.

Definition open_binding_wrt_trm e5 b5 := open_binding_wrt_trm_rec 0 b5 e5.

Definition open_trm_wrt_trm e_5 e__6 := open_trm_wrt_trm_rec 0 e__6 e_5.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_trm *)
Inductive lc_trm : trm -> Prop :=    (* defn lc_trm *)
 | lc_trm_var_f : forall (x5:var),
     (lc_trm (trm_var_f x5))
 | lc_trm_star :
     (lc_trm trm_star)
 | lc_trm_top :
     (lc_trm trm_top)
 | lc_trm_app : forall (e1 e2:trm),
     (lc_trm e1) ->
     (lc_trm e2) ->
     (lc_trm (trm_app e1 e2))
 | lc_trm_abs : forall (L:vars) (e1 A e2:trm),
     (lc_trm e1) ->
     (lc_trm A) ->
      ( forall x5 , x5 \notin  L  -> lc_trm  ( open_trm_wrt_trm e2 (trm_var_f x5) )  )  ->
     (lc_trm (trm_abs e1 A e2))
 | lc_trm_prod : forall (L:vars) (e A B:trm),
     (lc_trm e) ->
     (lc_trm A) ->
      ( forall x5 , x5 \notin  L  -> lc_trm  ( open_trm_wrt_trm B (trm_var_f x5) )  )  ->
     (lc_trm (trm_prod e A B))
 | lc_trm_castup : forall (A e:trm),
     (lc_trm A) ->
     (lc_trm e) ->
     (lc_trm (trm_castup A e))
 | lc_trm_castdn : forall (e:trm),
     (lc_trm e) ->
     (lc_trm (trm_castdn e))
 | lc_trm_anno : forall (e A:trm),
     (lc_trm e) ->
     (lc_trm A) ->
     (lc_trm (trm_anno e A)).

(* defns LC_binding *)
Inductive lc_binding : binding -> Prop :=    (* defn lc_binding *)
 | lc_bind_sub : forall (e A:trm),
     (lc_trm e) ->
     (lc_trm A) ->
     (lc_binding (bind_sub e A)).
(** free variables *)
Fixpoint fv_trm (e_5:trm) : vars :=
  match e_5 with
  | (trm_var_b nat) => \{}
  | (trm_var_f x5) => \{x5}
  | trm_star => \{}
  | trm_top => \{}
  | (trm_app e1 e2) => (fv_trm e1) \u (fv_trm e2)
  | (trm_abs e1 A e2) => (fv_trm e1) \u (fv_trm A) \u (fv_trm e2)
  | (trm_prod e A B) => (fv_trm e) \u (fv_trm A) \u (fv_trm B)
  | (trm_castup A e) => (fv_trm A) \u (fv_trm e)
  | (trm_castdn e) => (fv_trm e)
  | (trm_anno e A) => (fv_trm e) \u (fv_trm A)
end.

Definition fv_binding (b5:binding) : vars :=
  match b5 with
  | (bind_sub e A) => (fv_trm e) \u (fv_trm A)
end.

(** substitutions *)
Fixpoint subst_trm (e_5:trm) (y5:var) (e__6:trm) {struct e__6} : trm :=
  match e__6 with
  | (trm_var_b nat) => trm_var_b nat
  | (trm_var_f x5) => (If x5 = y5 then e_5 else (trm_var_f x5))
  | trm_star => trm_star
  | trm_top => trm_top
  | (trm_app e1 e2) => trm_app (subst_trm e_5 y5 e1) (subst_trm e_5 y5 e2)
  | (trm_abs e1 A e2) => trm_abs (subst_trm e_5 y5 e1) (subst_trm e_5 y5 A) (subst_trm e_5 y5 e2)
  | (trm_prod e A B) => trm_prod (subst_trm e_5 y5 e) (subst_trm e_5 y5 A) (subst_trm e_5 y5 B)
  | (trm_castup A e) => trm_castup (subst_trm e_5 y5 A) (subst_trm e_5 y5 e)
  | (trm_castdn e) => trm_castdn (subst_trm e_5 y5 e)
  | (trm_anno e A) => trm_anno (subst_trm e_5 y5 e) (subst_trm e_5 y5 A)
end.

Definition subst_binding (e5:trm) (y5:var) (b5:binding) : binding :=
  match b5 with
  | (bind_sub e A) => bind_sub (subst_trm e5 y5 e) (subst_trm e5 y5 A)
end.

(** definitions *)

(* defns Jop *)
Inductive reduct : trm -> trm -> Prop :=    (* defn reduct *)
 | reduct_beta : forall (e3 A e1 e2:trm),
     lc_trm e3 ->
     lc_trm A ->
     lc_trm (trm_abs e3 A e1) ->
     lc_trm e2 ->
     reduct (trm_app  ( (trm_abs e3 A e1) )  e2)  (open_trm_wrt_trm  e1   e2 )
 | reduct_app : forall (e1 e2 e1':trm),
     lc_trm e2 ->
     reduct e1 e1' ->
     reduct (trm_app e1 e2) (trm_app e1' e2)
 | reduct_castdn : forall (e1 e1':trm),
     reduct e1 e1' ->
     reduct (trm_castdn e1) (trm_castdn e1')
 | reduct_castelim : forall (A e:trm),
     lc_trm A ->
     lc_trm e ->
     reduct (trm_castdn  ( (trm_castup A e) ) ) e.

(* defns Jsub *)
Inductive sub : env -> trm -> trm -> trm -> Prop :=    (* defn sub *)
 | sub_ax : forall (G:env),
     wf G ->
     sub G trm_star trm_star trm_star
 | sub_var_refl : forall (G:env) (x5:var) (A e:trm),
     wf G ->
      binds ( x5 ) ( (bind_sub e A) ) ( G )  ->
     sub G (trm_var_f x5) (trm_var_f x5) A
 | sub_var_trans : forall (G:env) (x5:var) (e2 A e1:trm),
      binds ( x5 ) ( (bind_sub e1 A) ) ( G )  ->
     sub G e1 e2 A ->
     sub G (trm_var_f x5) e2 A
 | sub_top : forall (G:env) (e A:trm),
      sub ( G ) ( e ) ( e ) ( A )  ->
     sub G e trm_top A
 | sub_top_refl : forall (G:env) (A:trm),
      sub ( G ) ( A ) ( A ) ( trm_star )  ->
     sub G trm_top trm_top A
 | sub_abs : forall (L:vars) (G:env) (e1 A e2 e2' B:trm),
      sub ( G ) ( e1 ) ( e1 ) ( A )  ->
      sub ( G ) ( A ) ( A ) ( trm_star )  ->
      ( forall x5 , x5 \notin  L  ->  sub  ( G  &  x5 ~ (bind_sub e1 A) )   ( open_trm_wrt_trm e2 (trm_var_f x5) )   ( open_trm_wrt_trm e2' (trm_var_f x5) )   ( open_trm_wrt_trm B (trm_var_f x5) )   )  ->
      ( forall x5 , x5 \notin  L  ->  sub (  ( G  &  x5 ~ (bind_sub e1 A) )  ) (  ( open_trm_wrt_trm B (trm_var_f x5) )  ) (  ( open_trm_wrt_trm B (trm_var_f x5) )  ) ( trm_star )  )  ->
     sub G  ( (trm_abs e1 A e2) )   ( (trm_abs e1 A e2') )  (trm_prod e1 A B)
 | sub_app : forall (G:env) (e1 A e2 C e3 B:trm),
     sub G e1 e2 (trm_prod e3 B C) ->
     sub G A e3 B ->
     sub G (trm_app e1 A) (trm_app e2 A)  (open_trm_wrt_trm  C   A )
 | sub_prod : forall (L:vars) (G:env) (e A B e' A' B':trm),
     sub G A' A trm_star ->
     sub G e' e A ->
      sub ( G ) ( A ) ( A ) ( trm_star )  ->
      ( forall x5 , x5 \notin  L  ->   sub (  ( G  &  x5 ~ (bind_sub e A) )  ) (  ( open_trm_wrt_trm B (trm_var_f x5) )  ) (  ( open_trm_wrt_trm B (trm_var_f x5) )  ) ( trm_star )   )  ->
      ( forall x5 , x5 \notin  L  -> sub  ( G  &  x5 ~ (bind_sub e' A') )   ( open_trm_wrt_trm B (trm_var_f x5) )   ( open_trm_wrt_trm B' (trm_var_f x5) )  trm_star )  ->
       sub ( G ) ( e ) ( e ) ( A )   ->
      sub ( G ) ( e' ) ( e' ) ( A' )  ->
     sub G  ( (trm_prod e A B) )   ( (trm_prod e' A' B') )  trm_star
 | sub_castup : forall (G:env) (B e1 e2 A:trm),
      sub ( G ) ( B ) ( B ) ( trm_star )  ->
     sub G e1 e2 A ->
     reduct B A ->
     sub G (trm_castup B e1) (trm_castup B e2) B
 | sub_castdn : forall (G:env) (e1 e2 B A:trm),
      sub ( G ) ( B ) ( B ) ( trm_star )  ->
     sub G e1 e2 A ->
     reduct A B ->
     sub G (trm_castdn e1) (trm_castdn e2) B
 | sub_sub : forall (G:env) (e1 e2 B A:trm),
     sub G e1 e2 A ->
     sub G A B trm_star ->
     sub G e1 e2 B
with wf : env -> Prop :=    (* defn wf *)
 | wf_nil :
     wf  empty
 | wf_cons : forall (G:env) (x5:var) (e A:trm),
      sub ( G ) ( e ) ( e ) ( A )  ->
      sub ( G ) ( A ) ( A ) ( trm_star )  ->
      ( x5  # ( G ))  ->
     wf  ( G  &  x5 ~ (bind_sub e A) ) .

(* defns Jivalue *)
Inductive ivalue : trm -> Prop :=    (* defn ivalue *)
 | ivalue_top :
     ivalue trm_top
 | ivalue_var : forall (x5:var),
     ivalue (trm_var_f x5)
 | ivalue_app : forall (e1 e2:trm),
     lc_trm e2 ->
     ivalue e1 ->
     ivalue (trm_app e1 e2)
 | ivalue_castdn : forall (e:trm),
     ivalue e ->
     ivalue (trm_castdn e).

(* defns Jvalue *)
Inductive value : trm -> Prop :=    (* defn value *)
 | value_star :
     value trm_star
 | value_ivalue : forall (e:trm),
     ivalue e ->
     value e
 | value_abs : forall (e1 A e2:trm),
     lc_trm e1 ->
     lc_trm A ->
     lc_trm (trm_abs e1 A e2) ->
     value (trm_abs e1 A e2)
 | value_prod : forall (e A B:trm),
     lc_trm e ->
     lc_trm A ->
     lc_trm (trm_prod e A B) ->
     value (trm_prod e A B)
 | value_castup : forall (A e:trm),
     lc_trm A ->
     lc_trm e ->
     value (trm_castup A e).

(** infrastructure *)
Hint Constructors reduct sub wf ivalue value lc_trm lc_binding.


(* This file contains the definitions of l-terms, s-terms, the
   leftmost erasure, and proofs of their basic properties *)

Require Import general.
Require Import list_facts.
Require Import iterms.

(***********************************************************************************)
(* l-terms *)

Inductive lterm :=
| itm : iterm -> lterm
| C1 : lterm
| C2 : lterm
| T1 : lterm
| F1 : lterm
| I1 : lterm
| K1 : lterm
| S1 : list nat -> lterm
| S2 : nat -> lterm
| lapp : lterm -> lterm -> lterm
| ltup : lterm -> lterm -> list lterm -> lterm.

Notation "X @l Y" := (lapp X Y) (at level 11, left associativity).

Definition is_iterm t := match t with itm _ => true | _ => false end.

Definition lterm_ind2 :=
  fun (P : lterm -> Prop) (Q : list lterm -> Prop)
      (f : forall i : iterm, P (itm i)) (f0 : P C1) (f1 : P C2)
      (f2 : P T1) (f3 : P F1) (fi : P I1) (f4 : P K1)
      (f5 : forall (l : list nat), P (S1 l))
      (f5' : forall (n : nat), P (S2 n))
      (f6 : forall l : lterm, P l -> forall l0 : lterm, P l0 -> P (l @l l0))
      (f7 : forall l : lterm, P l -> forall l0 : lterm, P l0 -> forall l1 : list lterm,
              Q l1 -> P (ltup l l0 l1))
      (f8 : Q nil)
      (f9 : forall x, P x -> forall l, Q l -> Q (x :: l))
=>
fix F (l : lterm) : P l :=
  match l as l0 return (P l0) with
  | itm i => f i
  | C1 => f0
  | C2 => f1
  | T1 => f2
  | F1 => f3
  | I1 => fi
  | K1 => f4
  | S1 l0 => f5 l0
  | S2 n => f5' n
  | l0 @l l1 => f6 l0 (F l0) l1 (F l1)
  | ltup l0 l1 l2 =>
    let p :=
        (fix l_ind (l : list lterm) : Q l :=
           match l with
           | nil => f8
           | h :: t => f9 h (F h) t (l_ind t)
           end) l2
    in
    f7 l0 (F l0) l1 (F l1) l2 p
  end.

Ltac lterm_induction z :=
  pattern z;
  match goal with
  | [ |- ?G z ] =>
    let t := constr:(fun l => forall z : lterm, In z l -> G z) in
    let t2 := eval simpl in t in
    induction z using lterm_ind2 with (Q := t2)
  end.

Fixpoint lsize (t : lterm) : nat :=
  match t with
  | itm _ => 0
  | C1 => 1
  | C2 => 1
  | T1 => 1
  | F1 => 1
  | I1 => 1
  | K1 => 1
  | S1 l => 1
  | S2 n => 1
  | lapp x y => lsize x + lsize y
  | ltup x y l =>
    let fix lst_lsize (l : list lterm) : nat :=
        match l with
        | nil => 0
        | h :: l' => lsize h + lst_lsize l'
        end
    in
    lsize x + lsize y + lst_lsize l
  end.

Inductive CtxClose_l (R : lterm -> lterm -> Prop) : lterm -> lterm -> Prop :=
| close_lbase : forall t1 t2 : lterm, R t1 t2 -> CtxClose_l R t1 t2
| close_lapp_l : forall x x' y : lterm, CtxClose_l R x x' ->
                                         CtxClose_l R (x @l y) (x' @l y)
| close_lapp_r : forall x y y' : lterm, CtxClose_l R y y' ->
                                         CtxClose_l R (x @l y) (x @l y')
| close_ltup_0 : forall x x' y l, CtxClose_l R x x' ->
                                  CtxClose_l R (ltup x y l) (ltup x' y l)
| close_ltup_1 : forall x y y' l, CtxClose_l R y y' ->
                                  CtxClose_l R (ltup x y l) (ltup x y' l)
| close_ltup_2 : forall x y l l' z z', CtxClose_l R z z' ->
                                       CtxClose_l R (ltup x y (l ++ (z :: l')))
                                                  (ltup x y (l ++ (z' :: l'))).

Ltac pose_ctx_l := pose close_lbase; pose close_lapp_l; pose close_lapp_r; pose close_ltup_0;
                   pose close_ltup_1; pose close_ltup_2.

Definition EqvClose_l (R : lterm -> lterm -> Prop) := clos_refl_sym_trans lterm (CtxClose_l R).

Definition tuple_of_lterm (t : lterm) : list lterm :=
  match t with
  | ltup x y l => x :: y :: l
  | _ => t :: nil
  end.

Definition lterm_of_tuple (l : list lterm) : lterm :=
  match l with
  | x :: y :: r => ltup x y r
  | x :: nil => x
  | nil => itm C (* impossible *)
  end.

Lemma lterm_tuple_cancel :
  forall t : lterm, lterm_of_tuple (tuple_of_lterm t) = t.
Proof.
  intros.
  ydestruct t; yelles 1.
Qed.

Definition is_ltup (x : lterm) : bool :=
  match x with
  | ltup _ _ _ => true
  | _ => false
  end.

Hint Unfold is_ltup : unfold_hints.

Lemma tuple_lterm_cancel_1 :
  forall l : list lterm, is_nonempty l ->
                         (forall x, In x l -> is_ltup x = false) ->
                         tuple_of_lterm (lterm_of_tuple l) = l.
Proof.
  unfold is_nonempty.
  intros.
  ydestruct l; isolve.
  simpl.
  ydestruct l0; isolve.
  ydestruct l; isolve.
  simpl.
  generalize (H0 (ltup l1 l2 l3)).
  intro.
  assert (In (ltup l1 l2 l3) (ltup l1 l2 l3 :: nil)).
  auto with datatypes.
  yauto 1.
Qed.

Lemma lem_tuple_lterm_cancel_2 :
  forall l : list lterm, length l > 1 ->
                         tuple_of_lterm (lterm_of_tuple l) = l.
Proof.
  destruct l; yisolve; destruct l0; ycrush.
Qed.

Lemma lem_tuple_len_nonzero : forall t, length (tuple_of_lterm t) > 0.
Proof.
  destruct t; yisolve.
  simpl; omega.
Qed.

Lemma lem_is_ltup_len : forall (l : list lterm), length l > 1 ->
                                                 is_ltup (lterm_of_tuple l) = true.
Proof.
  destruct l; yisolve.
  destruct l0; yisolve.
  simpl; omega.
Qed.

Inductive Sterm : lterm -> Prop :=
| sterm_c1 : Sterm C1
| sterm_c2 : Sterm C2
| sterm_t1 : Sterm T1
| sterm_f1 : Sterm F1
| sterm_i1 : Sterm I1
| sterm_k1 : Sterm K1
| sterm_s1 : forall l, Sterm (S1 l)
| sterm_s2 : forall n, Sterm (S2 n)
| sterm_lapp : forall x y, Sterm x -> Sterm (x @l y).

Ltac pose_sterm := pose sterm_c1; pose sterm_c2; pose sterm_t1; pose sterm_f1; pose sterm_k1;
                   pose sterm_s1; pose sterm_lapp.
Ltac sterm_tac n := pose_sterm; yauto n.

(* leftmost erasure *)
Fixpoint erase (t : lterm) : iterm :=
  match t with
  | itm x => x
  | C1 => C
  | C2 => C
  | T1 => T
  | F1 => F
  | I1 => I
  | K1 => K
  | S1 l => Si
  | S2 n => Si
  | lapp x y => app (erase x) (erase y)
  | ltup x y l => erase x
  end.

Definition ErasedEqv x y := Eqv_clc (erase x) (erase y).

Hint Unfold ErasedEqv : unfold_hints.

Fixpoint split_in_groups ns (l : list lterm) :=
  match ns with
  | nil => l :: nil
  | n :: ns' => firstn n l :: split_in_groups ns' (skipn n l)
  end.

Definition glue_iterms t1 t2 :=
  match t1, t2 with
  | itm x, itm y => itm (x @i y)
  | _, _ => t1 @l t2
  end.

Fixpoint build_ys ys zs :=
  match ys, zs with
  | y :: ys', tz :: zs' => (glue_iterms y (lterm_of_tuple tz)) :: build_ys ys' zs'
  | _, _ => nil
  end.

Definition build_s_result ns x l1 l2 :=
  let args := split_in_groups ns l2 in
  match args with
  | a1 :: a2 :: args' => x @l (lterm_of_tuple a1) @l lterm_of_tuple (build_ys l1 (a2 :: args'))
  | a1 :: nil => (lterm_of_tuple a1) (* impossible *)
  | _ => itm C (* impossible *)
  end.

Lemma lem_split_length :
  forall ns l, (lst_sum ns < length l) ->
               length (split_in_groups ns l) = length ns + 1.
Proof.
  induction ns; simpl.
  ycrush.
  intros.
  assert (lst_sum ns < length (skipn a l)).
  generalize (lem_skipn_length a l); omega.
  ycrush.
Qed.

Lemma lem_split_in_groups_skip :
  forall l l' ns, split_in_groups (length l :: ns) (l ++ l') = l :: split_in_groups ns l'.
Proof.
  induction l.
  ycrush.
  simpl; intros.
  rewrite lem_firstn_len.
  rewrite lem_skipn_len.
  ycrush.
Qed.

Lemma lem_split_nonempty :
  forall ns l, (forall n, In n ns -> n > 0) ->
               (lst_sum ns < length l) ->
               forall x, In x (split_in_groups ns l) -> is_nonempty x.
Proof.
  induction ns; simpl.
  ycrush.
  intros.
  ydestruct H1.
  subst.
  assert (exists k, a = S k).
  assert (a > 0) by ycrush.
  Reconstr.hobvious (@H1)
	            (@Coq.ZArith.Znat.inj_gt)
	            (@Coq.ZArith.BinIntDef.Z.of_nat, @Coq.Init.Nat.add, @Coq.ZArith.BinInt.Z.gt, @Coq.ZArith.BinIntDef.Z.compare).
  simp_hyps; subst; simpl in *.
  ydestruct l; ycrush.
  assert (lst_sum ns < length (skipn a l)).
  generalize (lem_skipn_length a l); omega.
  ycrush.
Qed.

Lemma lem_split_preserves_elements :
  forall ns l x y, In x y -> In y (split_in_groups ns l) -> In x l.
Proof.
  induction ns; simpl; yisolve.
  intros.
  ydestruct H0.
  generalize (lem_firstn_preserves_elements a l); ycrush.
  generalize (lem_skipn_preserves_elements a l); ycrush.
Qed.

Lemma lem_split_in_groups_preserves_elements_2 :
  forall x l, In x l -> forall ns, (forall n, In n ns -> n > 0) ->
                                   exists y, In x y /\ In y (split_in_groups ns l).
Proof.
  assert (forall x l, In x l ->
                      forall n ns, (forall n, In n ns -> n > 0) ->
                                   In x (firstn n l) \/
                                   exists y, In x y /\
                                             In y (split_in_groups ns (skipn n l))).
  induction l.
  ycrush.
  simpl.
  induction n.
  simpl.
  destruct ns.
  Reconstr.hsimple (@H)
	           (@Coq.Lists.List.not_in_cons, @Coq.Lists.List.in_cons)
		   Reconstr.Empty.
  simpl.
  ydestruct n.
  firstorder with arith.
  simpl.
  intros.
  destruct H.
  subst.
  right; exists (x :: firstn n l).
  simpl; firstorder with datatypes.
  assert (HH: In x (firstn n l) \/
              (exists y : list lterm, In x y /\ In y (split_in_groups ns (skipn n l)))).
  ycrush.
  destruct HH.
  assert (In x (a :: firstn n l)) by ycrush.
  ycrush.
  ycrush.
  simpl; firstorder.
  intros; yforwarding.
  generalize (H2 0); simpl; intro.
  firstorder.
Qed.

Lemma lem_split_result :
  forall n ns l, exists a b s, split_in_groups (n :: ns) l = a :: b :: s.
Proof.
  destruct ns; ycrush.
Qed.

Definition All_pairs {A : Type} (l : list A) (R : A -> A -> Prop) :=
  forall x y, In x l -> In y l -> R x y.

Hint Unfold All_pairs : yhints.

Definition RootContr_S (t1 t2 : lterm) : Prop :=
  match t1 with
  | S1 ns @l x @l ys @l zs =>
    (forall n, In n ns -> n > 0) /\
    is_ltup ys = true /\ is_ltup zs = true /\
    let l1 := tuple_of_lterm ys in
    let l2 := tuple_of_lterm zs in
    (forall x, In x l2 -> is_ltup x = false) /\
    length l1 = length ns /\
    lst_sum ns < length l2 /\
    All_pairs l1 ErasedEqv /\
    All_pairs l2 ErasedEqv /\
    t2 = build_s_result ns x l1 l2
  | S2 n @l x @l y @l zs =>
    is_ltup y = false /\ is_ltup zs = true /\
    let l := tuple_of_lterm zs in
    (forall x, In x l -> is_ltup x = false) /\
    n > 0 /\ n < length l /\
    All_pairs l ErasedEqv /\
    t2 = x @l (lterm_of_tuple (firstn n l)) @l glue_iterms y (lterm_of_tuple (skipn n l))
  | _ => False
  end.

Definition RootContr_clc_s_minus (t1 t2 : lterm) : Prop :=
  match t1 with
  | C1 @l T1 @l x @l y => t2 = x
  | C1 @l F1 @l x @l y => t2 = y
  | C2 @l z @l x @l y => t2 = x /\ ErasedEqv x y
  | I1 @l x => t2 = x
  | K1 @l x @l y => t2 = x
  | _ => RootContr_S t1 t2
  end.

Definition RootContr_clc_s (t1 t2 : lterm) : Prop :=
  match t1 with
  | C1 @l T1 @l x @l y => t2 = x
  | C1 @l F1 @l x @l y => t2 = y
  | C2 @l z @l x @l y => (t2 = x \/ t2 = y) /\ ErasedEqv x y
  | I1 @l x => t2 = x
  | K1 @l x @l y => t2 = x
  | _ => RootContr_S t1 t2
  end.

Definition Contr_clc_s := CtxClose_l RootContr_clc_s.
Definition Red_clc_s := clos_refl_trans lterm Contr_clc_s.

Inductive Contr_clc_s_minus : lterm -> lterm -> Prop :=
| s_minus_base : forall t1 t2 : lterm, RootContr_clc_s_minus t1 t2 -> Contr_clc_s_minus t1 t2
| s_minus_lapp_l : forall x x' y : lterm, Contr_clc_s_minus x x' ->
                                          Contr_clc_s_minus (x @l y) (x' @l y)
| s_minus_lapp_r : forall x y y' : lterm, Contr_clc_s_minus y y' ->
                                          Contr_clc_s_minus (x @l y) (x @l y').
Definition Red_clc_s_minus := clos_refl_trans lterm Contr_clc_s_minus.

Ltac pose_s_minus := pose s_minus_base; pose s_minus_lapp_l; pose s_minus_lapp_r.

Definition Redex_clc_s t :=
  match t with
  | C1 @l T1 @l x @l y => True
  | C1 @l F1 @l x @l y => True
  | C2 @l z @l x @l y => ErasedEqv x y
  | I1 @l x => True
  | K1 @l x @l y => True
  | S1 ns @l x @l ys @l zs =>
    (forall n, In n ns -> n > 0) /\
    is_ltup ys = true /\ is_ltup zs = true /\
    let l1 := tuple_of_lterm ys in
    let l2 := tuple_of_lterm zs in
    (forall x, In x l2 -> is_ltup x = false) /\
    length l1 = length ns /\
    lst_sum ns < length l2 /\
    All_pairs l1 ErasedEqv /\
    All_pairs l2 ErasedEqv
  | S2 n @l x @l y @l zs =>
    is_ltup y = false /\ is_ltup zs = true /\
    let l := tuple_of_lterm zs in
    (forall x, In x l -> is_ltup x = false) /\
    n > 0 /\ n < length l /\
    All_pairs l ErasedEqv
  | _ => False
  end.

Lemma rcontr_S_inversion :
  forall t1 t2, RootContr_S t1 t2 ->
                (exists ns x ys zs, t1 = S1 ns @l x @l ys @l zs /\
                                      (forall n, In n ns -> n > 0) /\
                                      is_ltup ys = true /\ is_ltup zs = true /\
                                      let l1 := tuple_of_lterm ys in
                                      let l2 := tuple_of_lterm zs in
                                      (forall x, In x l2 -> is_ltup x = false) /\
                                      length l1 = length ns /\
                                      lst_sum ns < length l2 /\
                                      All_pairs l1 ErasedEqv /\
                                      All_pairs l2 ErasedEqv /\
                                      t2 = build_s_result ns x l1 l2) \/
                (exists n x y zs, t1 = S2 n @l x @l y @l zs /\
                                  is_ltup y = false /\ is_ltup zs = true /\
                                  let l := tuple_of_lterm zs in
                                  (forall x, In x l -> is_ltup x = false) /\
                                  n > 0 /\ n < length l /\
                                  All_pairs l ErasedEqv /\
                                  t2 = (x @l (lterm_of_tuple (firstn n l)) @l
                                          glue_iterms y (lterm_of_tuple (skipn n l)))).
Proof.
  intros; ydestruct t1; simpl in *; yisolve.
Qed.

Ltac invert_rcontr_S :=
  repeat match goal with
         | [ H : (RootContr_S ?x ?y) |- _ ] =>
           generalize (rcontr_S_inversion x y H); yintro; clear H
         end.

Lemma rcontr_clc_s_inversion :
  forall t1 t2, RootContr_clc_s t1 t2 ->
                (exists x y, t1 = C1 @l T1 @l x @l y /\ t2 = x) \/
                (exists x y, t1 = C1 @l F1 @l x @l y /\ t2 = y) \/
                (exists x y z, t1 = C2 @l z @l x @l y /\ (t2 = x \/ t2 = y) /\ ErasedEqv x y) \/
                (exists x, t1 = I1 @l x /\ t2 = x) \/
                (exists x y, t1 = K1 @l x @l y /\ t2 = x) \/
                (exists ns x ys zs, t1 = S1 ns @l x @l ys @l zs /\
                                      (forall n, In n ns -> n > 0) /\
                                      is_ltup ys = true /\ is_ltup zs = true /\
                                      let l1 := tuple_of_lterm ys in
                                      let l2 := tuple_of_lterm zs in
                                      (forall x, In x l2 -> is_ltup x = false) /\
                                      length l1 = length ns /\
                                      lst_sum ns < length l2 /\
                                      All_pairs l1 ErasedEqv /\
                                      All_pairs l2 ErasedEqv /\
                                      t2 = build_s_result ns x l1 l2) \/
                (exists n x y zs, t1 = S2 n @l x @l y @l zs /\
                                  is_ltup y = false /\ is_ltup zs = true /\
                                  let l := tuple_of_lterm zs in
                                  (forall x, In x l -> is_ltup x = false) /\
                                  n > 0 /\ n < length l /\
                                  All_pairs l ErasedEqv /\
                                  t2 = (x @l (lterm_of_tuple (firstn n l)) @l
                                          glue_iterms y (lterm_of_tuple (skipn n l)))).
Proof.
  intros; ydestruct t1; simpl in *; yisolve.
Qed.

Ltac invert_rcontr_clc_s :=
  repeat match goal with
         | [ H : (RootContr_clc_s ?x ?y) |- ?G ] =>
           generalize (rcontr_clc_s_inversion x y H); yintro; clear H
         end.

Lemma invert_rcontr_c :
  forall z x y t, RootContr_clc_s (C1 @l z @l x @l y) t \/ RootContr_clc_s (C2 @l z @l x @l y) t ->
                  t = x \/ t = y.
Proof.
  intros; intuition; invert_rcontr_clc_s; yisolve.
Qed.

Lemma lem_rcontr_clc_s_implies_redex : forall x y, RootContr_clc_s x y -> Redex_clc_s x.
Proof.
  intros; invert_rcontr_clc_s; ydestruct x; ycrush.
Qed.

Lemma lem_redex_clc_s_implies_rcontr : forall x, Redex_clc_s x -> exists y, RootContr_clc_s x y.
Proof.
  intros; ydestruct x; simpl in *; yisolve.
Qed.

Lemma lem_sterm_glue_iterms : forall x y, Sterm (x @l y) -> glue_iterms x y = x @l y.
Proof.
  ycrush.
Qed.

Lemma lem_s2_discriminate_y : forall n x y z, y <> S2 n @l x @l y @l z.
Proof.
  autounfold; intros.
  assert (lsize y = lsize (S2 n @l x @l y @l z)) by ycrush.
  simpl in *; omega.
Qed.


Require Import CSet Le CMap CMapDomain CMapPartialOrder CMapJoinSemiLattice CMapTerminating.

Require Import Plus Util AllInRel CSet OptionR.
Require Import Val Var Envs IL Annotation Infra.Lattice DecSolve.
Require Import CMap WithTop.
Require Import MapNotations ListUpdateAt.
Require Import Terminating OptionR.

Set Implicit Arguments.

Open Scope map_scope.

Definition Dom D := Map [var, D].

Definition domupd D (d:Dom D) x (o:option D) : Dom D :=
  match o with
  | Some xv => (d [- x <- xv -])
  | None => remove x d
  end.

Fixpoint domjoin_list D `{JoinSemiLattice D} (m:Dom D) (A:list var) (B:list (option D)) :=
  match A, B with
  | x::A, y::B =>
    domupd (domjoin_list m A B) x (join (find x m) y)
  | _, _ => m
  end.

Definition domenv D (d:Dom D) (x:var) : option D :=
  find x d.

Lemma domupd_le D `{PartialOrder D} (a b: Dom D) v v' x
  : poLe a b
    -> poLe v v'
    -> poLe (domupd a x v) (domupd b x v').
Proof.
  unfold leMap, domupd; intros.
  inv H1.
  - repeat cases; clear_trivial_eqs; hnf; intros; mlud; eauto.
  - hnf; intros; mlud; eauto.
Qed.

Lemma domjoin_list_le D `{JoinSemiLattice D} (a b: Dom D) Z Y Y'
  : poLe a b
    -> poLe Y Y'
    -> poLe (domjoin_list a Z Y)
            (domjoin_list b Z Y').
Proof.
  general induction Z; simpl domjoin_list; eauto.
  inv H2; eauto.
  - eapply domupd_le.
    + eapply IHZ; eauto.
    + eapply ojoin_poLe; eauto.
Qed.

Lemma domupd_eq D `{PartialOrder D} (a b: Dom D) v v' x
  : poEq a b
    -> poEq v v'
    -> poEq (domupd a x v) (domupd b x v').
Proof.
  unfold eqMap, domupd; intros.
  inv H1.
  - eapply eqMap_remove; eauto.
  - repeat cases; clear_trivial_eqs.
    hnf; intros. mlud; eauto.
    econstructor. eauto.
Qed.

Lemma domjoin_list_eq  D `{JoinSemiLattice D} (a b: Dom D) Z Y Y'
  : poEq a b
    -> poEq Y Y'
    -> poEq (domjoin_list a Z Y)
            (domjoin_list b Z Y').
Proof.
  general induction Z; simpl domjoin_list; eauto.
  inv H2; eauto.
  - eapply domupd_eq
    + eapply IHZ; eauto.
    + eapply ojoin_poEq; eauto.
Qed.

Lemma domjoin_ne D (m:Dom D) x y a
  : x =/= y
    -> find x (domupd m y a) = find x m.
Proof.
  unfold domupd; cases; intros; mlud; eauto.
Qed.

Lemma domjoin_list_ne D `{JoinSemiLattice D} (m:Dom D) x Z Y
  : ~ InA eq x Z
    -> find x (domjoin_list m Z Y) === find x m.
Proof.
  intros NI.
  general induction Z; destruct Y; simpl; eauto.
  erewrite domjoin_ne; eauto.
  intro; eapply NI; econstructor. eapply H1.
Qed.

Lemma domupd_poLe D `{PartialOrder D} (m m' : Map [var, D]) a v
  : poLe (find a m) v
    -> poLe m m'
    -> poLe m (domupd m' a v).
Proof.
  intros. hnf; intros.
  unfold domupd; cases.
  - mlud; eauto. rewrite <- e. eauto.
  - mlud; eauto. rewrite <- e, <- H3. eauto.
Qed.

Lemma domjoin_list_exp  D `{JoinSemiLattice D} (m:Dom D) Z Y
  : poLe m (domjoin_list m Z Y).
Proof.
  general induction Z; destruct Y; simpl domjoin_list; eauto;
    try reflexivity.
  eapply domupd_poLe; eauto.
  eapply join_poLe.
Qed.

Lemma domain_join_sig X `{OrderedType X} Y `{JoinSemiLattice Y}  U
  (x y : {m : Map [X, Y] | domain m [<=] U})
  : domain (proj1_sig x ⊔ proj1_sig y) [<=] U.
Proof.
  destruct x,y; simpl.
  unfold join; simpl.
  unfold joinMap. rewrite domain_join. cset_tac.
Qed.

Definition joinsig X `{OrderedType X} Y `{JoinSemiLattice Y}  U
           (x y : {m : Map [X, Y] | domain m ⊆ U}) :=
  exist (fun m => domain m ⊆ U) (join (proj1_sig x) (proj1_sig y)) (domain_join_sig x y).

Definition joinsig_bound X `{OrderedType X} Y `{JoinSemiLattice Y}  U
  : forall a b: {m : Map [X, Y] | domain m [<=] U}, poLe a b -> poLe (joinsig a b) b.
Proof.
  - hnf; intros [a ?] [b ?]. simpl. eapply joinDom_bound.
Qed.

Definition joinsig_sym X `{OrderedType X} Y `{JoinSemiLattice Y}  U
  : forall a b : {m : Map [X, Y] | domain m [<=] U}, joinsig a b ≣ joinsig b a.
Proof.
  - hnf; intros [a ?] [b ?]. eapply joinDom_sym.
Qed.

Definition joinsig_assoc X `{OrderedType X} Y `{JoinSemiLattice Y}  U
  : forall a b c : {m : Map [X, Y] | domain m [<=] U}, joinsig (joinsig a b) c ≣ joinsig a (joinsig b c).
Proof.
  hnf; intros [a ?] [b ?] [c ?]. eapply joinDom_assoc.
Qed.

Definition joinsig_exp X `{OrderedType X} Y `{JoinSemiLattice Y}  U
  : forall a b : {m : Map [X, Y] | domain m [<=] U}, a ⊑ joinsig a b.
Proof.
  hnf; intros [a ?] [b ?]; simpl. eapply joinDom_exp.
Qed.

Instance map_sig_semilattice_bound X `{OrderedType X} Y `{JoinSemiLattice Y}  U
  : JoinSemiLattice ({ m : Map [X, Y] | domain m ⊆ U}) := {
  join x y := joinsig x y
}.
Proof.
  - eapply joinsig_bound.
  - eapply joinsig_sym.
  - eapply joinsig_assoc.
  - eapply joinsig_exp.
  - simpl. unfold Proper, respectful; intros.
    destruct x,y,x0,y0; unfold poEq in *; simpl in * |- *.
    rewrite H2, H3. reflexivity.
  - simpl. unfold Proper, respectful; intros.
    destruct x,y,x0,y0; unfold poLe in *; simpl in * |- *.
    rewrite H3, H2. reflexivity.
Defined.

Instance map_sig_lower_bounded X `{OrderedType X} Y `{JoinSemiLattice Y} U
  : LowerBounded { m : Map [X, Y] | domain m ⊆ U} :=
  {
    bottom := exist _ (@bottom (Map [X,Y]) _ _) (incl_empty _ _)
  }.
Proof.
  intros [a b]; simpl.
  eapply empty_bottom; eauto.
Defined.

Definition VDom U D := { m : Map [var, D] | domain m ⊆ U}.

Lemma domain_domupd_incl  D (m:Dom D) x v
  : domain (domupd m x v) ⊆ {x; domain m}.
Proof.
  unfold domupd; cases.
  - rewrite domain_add. reflexivity.
  - rewrite domain_remove. cset_tac.
Qed.

Lemma domain_domjoin_list_incl D `{JoinSemiLattice D} (m:Dom D) x v
  : domain (domjoin_list m x v) ⊆ of_list x ∪ domain m.
Proof.
  general induction x; destruct v; simpl.
  - cset_tac.
  - cset_tac.
  - cset_tac.
  - rewrite domain_domupd_incl.
    rewrite IHx; eauto. cset_tac.
Qed.

Lemma domupdd_dom D U (d:VDom U D) x v
  : x \In U -> domain (domupd (proj1_sig d) x v) [<=] U.
Proof.
  destruct d; simpl.
  rewrite domain_domupd_incl. intros. cset_tac.
Qed.

Lemma domjoin_list_dom D `{JoinSemiLattice D} U  (d:VDom U D) Z Y
  : of_list Z ⊆ U -> domain (domjoin_list (proj1_sig d) Z Y) [<=] U.
Proof.
  destruct d; simpl.
  rewrite domain_domjoin_list_incl. intros. cset_tac.
Qed.

Definition domupdd D U (d:VDom U D) x (v:option D) (IN:x ∈ U) : VDom U D :=
  (exist _ (domupd (proj1_sig d) x v) (domupdd_dom d v IN)).

Definition domjoin_listd D `{JoinSemiLattice D}
           U (d:VDom U D) Z Y (IN:of_list Z ⊆ U) : VDom U D :=
  (exist _ (domjoin_list (proj1_sig d) Z Y) (domjoin_list_dom d Z Y IN)).

Lemma option_R_inv x y
  : @OptionR.option_R (withTop Val.val) (withTop Val.val)
         (@poEq (withTop Val.val)
                (@withTop_PO Val.val Val.int_eq Val.Equivalence_eq_int' Val.int_eq_dec)) x y
    -> x = y.
Proof.
  intros. inv H; eauto.
  inv H0; eauto.
  do 2 f_equal. eauto.
Qed.

Lemma add_dead D (G:set var) (R:D->D->Prop) `{Reflexive _ R} (AE:Dom D) x v (NOTIN:x ∉ G)
  : agree_on (@OptionR.option_R _ _ R) G (domenv AE)
             (domenv (add x v AE)).
Proof.
  hnf; intros. unfold domenv.
  mlud. cset_tac. reflexivity.
Qed.

Lemma remove_dead D (G:set var) (R:D->D->Prop) `{Reflexive _ R} (AE:Dom D) x (NOTIN:x ∉ G)
  : agree_on (@OptionR.option_R _ _ R) G (domenv AE)
             (domenv (remove x AE)).
Proof.
  hnf; intros. unfold domenv.
  mlud. cset_tac. reflexivity.
Qed.

Lemma domupd_dead D (G:set var) (R:D->D->Prop) `{Reflexive _ R} x AE v (NOTIN:x ∉ G)
  : agree_on (OptionR.option_R R) G (domenv AE)
             (domenv (domupd AE x v)).
Proof.
  unfold domupd; cases.
  + eapply add_dead; eauto.
  + eapply remove_dead; eauto.
Qed.

Lemma bottom_join_left D `{JoinSemiLattice D} `{@LowerBounded D H} (x:D)
  : poEq (⊥ ⊔ x) x.
Proof.
  symmetry. rewrite join_commutative.
  eapply join_wellbehaved. eapply bottom_least.
Qed.

Lemma bottom_join_right D `{JoinSemiLattice D} `{@LowerBounded D H} (x:D)
  : poEq (x ⊔ ⊥) x.
Proof.
  symmetry.
  eapply join_wellbehaved. eapply bottom_least.
Qed.

Lemma agree_domenv_join_bot U D `{JoinSemiLattice D} (G:set var) (a b:VDom U D) c
      : a === bottom
        -> agree_on poEq G (domenv (proj1_sig b)) (domenv c)
        -> agree_on poEq G (domenv (proj1_sig (join a b))) (domenv c).
Proof.
  destruct a,b;
    unfold domenv, poEq at 1; simpl proj1_sig.
  intros A B.
  hnf; intros z IN.
  eapply poEq_sig_struct' in A.
  rewrite A. rewrite bottom_join_left.
  eapply B. eauto.
Qed.

Lemma agree_domenv_join_bot2 U D `{JoinSemiLattice D} (G:set var) (a b:VDom U D) c
      : agree_on poEq G (domenv (proj1_sig a)) (domenv c)
        -> b === bottom
        -> agree_on poEq G (domenv (proj1_sig (join a b))) (domenv c).
Proof.
  destruct a,b;
    unfold domenv, poEq at 2; simpl proj1_sig.
  intros A B.
  hnf; intros z IN.
  eapply poEq_sig_struct' in B.
  rewrite B. rewrite bottom_join_right.
  eapply A. eauto.
Qed.

Lemma domupd_var_eq D (m:Dom D) x y a
  : x === y
    -> find x (domupd m y a) = a.
Proof.
  unfold domupd; cases; intros; mlud; eauto.
  - exfalso; eauto.
  - exfalso; eauto.
Qed.

Lemma domupd_var_ne D (m:Dom D) x y a
  : x =/= y
    -> find x (domupd m y a) = find x m.
Proof.
  unfold domupd; cases; intros; mlud; eauto.
Qed.

Lemma domupd_list_ne D `{JoinSemiLattice D} (m:Dom D) x Z Y
  : ~ InA eq x Z
    -> find x (domjoin_list m Z Y) === find x m.
Proof.
  intros NI.
  general induction Z; destruct Y; simpl; eauto.
  rewrite domupd_var_ne; eauto.
  intro; eapply NI; econstructor. eapply H1.
Qed.

Lemma domupd_list_get D `{JoinSemiLattice D} (m:Dom D) Z Y x n y
  : NoDupA eq Z
    -> get Z n x
    -> get Y n y
    -> poLe y (find x (domjoin_list m Z Y)).
Proof.
  intros ND GetZ GetY.
  general induction n; simpl domjoin_list.
  - rewrite domupd_var_eq; eauto.
  - inv GetZ; inv GetY.
    simpl domjoin_list.
    rewrite domupd_var_ne; eauto.
    inv ND. intro. eapply H5.
    rewrite <- H1. eapply get_InA; eauto.
Qed.

Lemma domupd_list_agree D `{JoinSemiLattice D} (R:relation (option D)) `{Reflexive _ R} G (AE:Dom D) Z Y
  : agree_on R (G \ of_list Z)
             (domenv AE)
             (domenv (domjoin_list AE Z Y)).

Proof.
  general induction Z; destruct Y; simpl; try reflexivity.
  hnf; intros. cset_tac'.
  unfold domenv.
  rewrite domupd_var_ne; [|symmetry; eauto].
  exploit IHZ; eauto.
  exploit H4; eauto. cset_tac.
Qed.

Lemma poEq_domupd D `{PartialOrder D}
      (m:Dom D) x v
  : find x m === v
    -> poEq m (domupd m x v).
Proof.
  intros. hnf; intros; unfold domupd; cases; mlud; eauto;
  rewrite <- e; eauto.
Qed.

Lemma domenv_proper G
  : Proper (poEq ==> agree_on poEq G) (@domenv _).
Proof.
  unfold Proper, respectful, domenv, agree_on; intros.
  eauto.
Qed.

Lemma find_mapjoin_dist X `{OrderedType X} D `{JoinSemiLattice D} (m m':Map [X, D]) z
  : find z (m ⊔ m') === ((find z m) ⊔ (find z m')).
Proof.
  unfold join; simpl.
  unfold join at 1; simpl.
  unfold joinMap.
  rewrite MapFacts.map2_1bis; eauto.
Qed.

Lemma agree_domenv_join U D `{JoinSemiLattice D} (G:set var) (a b:VDom U D) c
      : agree_on poEq G (domenv (proj1_sig a)) (domenv c)
        -> agree_on poEq G (domenv (proj1_sig b)) (domenv c)
        -> agree_on poEq G (domenv (proj1_sig (join a b))) (domenv c).
Proof.
  destruct a,b;
    unfold domenv; simpl proj1_sig.
  intros A B.
  hnf; intros z IN.
  rewrite find_mapjoin_dist.
  specialize (A z IN).
  specialize (B z IN). cbv beta in *.
  rewrite A, B. rewrite join_idempotent. reflexivity.
Qed.

Lemma domupd_list_agree_poLe D `{JoinSemiLattice D} G (AE:Dom D) Z Y
  : agree_on poLe G
             (domenv AE)
             (domenv (domjoin_list AE Z Y)).

Proof.
  hnf; intros. decide (x ∈ of_list Z).
  - general induction Z; destruct Y; simpl; try reflexivity.
    simpl in *. decide (x = a); subst.
    + unfold domenv.
      rewrite domupd_var_eq; [|symmetry; eauto].
      unfold ojoin; repeat cases; try econstructor; eauto.
      eapply join_poLe.
    + unfold domenv.
      rewrite domupd_var_ne; [|intro; eauto].
      eapply IHZ; eauto. cset_tac.
  - eapply domupd_list_agree; eauto. cset_tac.
Qed.

Lemma domupd_list_get_first D `{JoinSemiLattice D} (m:Dom D) Z Y x n y
  : get Z n x
    -> get Y n y
    -> (forall (n' : nat) (z' : var),
          n' < n -> get Z n' z' -> z' =/= x)
    -> poLe y (find x (domjoin_list m Z Y)).
Proof.
  intros GetZ GetY LEAST.
  general induction n; simpl domjoin_list.
  - rewrite domupd_var_eq; eauto.
  - inv GetZ; inv GetY.
    simpl domjoin_list.
    rewrite domupd_var_ne; eauto using get.
    + eapply IHn; intros; eauto using get.
      eapply (LEAST (S n')); eauto using get. omega.
    + symmetry. eapply (LEAST 0); eauto using get. omega.
Qed.

Lemma poLe_domupdd D `{PartialOrder D} U d d' v v' x IN IN'
  : d ⊑ d'
    -> v ⊑ v'
    -> @domupdd D U d x v IN ⊑ @domupdd D U d' x v' IN'.
Proof.
  intros. eapply poLe_sig_struct.
  eapply domupd_le; eauto.
Qed.

Lemma poEq_domupdd D `{PartialOrder D} U d d' v v' x IN IN'
  : d ≣ d'
    -> v ≣ v'
    -> @domupdd D U d x v IN ≣ @domupdd D U d' x v' IN'.
Proof.
  intros. eapply poEq_sig_struct.
  eapply domupd_eq; eauto.
Qed.

Hint Resolve poLe_domupdd poEq_domupdd.

Lemma domupd_poLe_left D `{PartialOrder D} d d' x v
  : d ⊑ d'
    -> v ⊑ domenv d' x
    -> domupd d x v ⊑ d'.
Proof.
  intros.
  hnf; intros y.
  decide (y === x); eauto; subst.
  - invc e.
    rewrite domupd_var_eq; eauto.
  - rewrite domupd_var_ne; eauto.
Qed.

Lemma domjoin_list_poLe_left D `{JoinSemiLattice D} d d' Z Y
  : d ⊑ d'
    -> (forall n x y, get Z n x -> get Y n y -> y ⊑ domenv d' x)
    -> domjoin_list d Z Y ⊑ d'.
Proof.
  general induction Z; destruct Y; eauto.
  simpl. eapply domupd_poLe_left; eauto using get.
  exploit H2; eauto using get.
  eapply join_poLe_left; eauto.
Qed.

Lemma domjoin_list_notin D `{JoinSemiLattice D} x d Z Y
  : x ∉ of_list Z
    -> MapInterface.find x (domjoin_list d Z Y) = MapInterface.find x d.
Proof.
  intros. general induction Z; destruct Y; simpl in *; eauto.
  rewrite domupd_var_ne.
  rewrite IHZ; eauto. cset_tac. cset_tac.
Qed.

Lemma domjoin_list_get D `{JoinSemiLattice D} x (y y':option D) n d Z Y
  : get Z n x
    -> get Y n y'
    -> y ≣ y'
    -> NoDupA eq Z
    -> domenv (domjoin_list d Z Y) x ≣ ((domenv d x) ⊔ y).
Proof.
  intros. general induction n; simpl in *; eauto.
  - unfold domenv. rewrite domupd_var_eq; eauto.
    rewrite H3. reflexivity.
  - inv H1; inv H2. simpl.
    inv H4.
    eapply NoDupA_get_neq' in H4; [|eauto|eauto| instantiate (2:=0) |eauto using get| eauto using get];
      try omega.
    rewrite <- IHn; eauto using get.
    unfold domenv.
    rewrite domupd_var_ne; eauto. intro. eapply H4. invc H5; eauto.
Qed.

Arguments to_list : simpl never.

Instance poLe_find_proper D `{PartialOrder D}
  : Proper (_eq ==> @poLe (Dom D) _ ==> poLe) (@MapInterface.find var _ _ D).
Proof.
  unfold Proper, respectful; intros. invc H0.
  eapply H1.
Qed.

Instance poEq_find_proper D `{PartialOrder D}
  : Proper (_eq ==> @poEq (Dom D) _ ==> poEq) (@MapInterface.find var _ _ D).
Proof.
  unfold Proper, respectful; intros. invc H0.
  eapply H1.
Qed.

Instance poLe_domenv_proper D `{PartialOrder D}
  : Proper (@poLe (Dom D) _ ==> _eq ==> poLe) (@domenv D).
Proof.
  unfold Proper, respectful; intros. invc H1.
  eapply H0.
Qed.

Instance poEq_domenv_proper D `{PartialOrder D}
  : Proper (@poEq (Dom D) _ ==> _eq ==> poEq) (@domenv D).
Proof.
  unfold Proper, respectful; intros. invc H1.
  eapply H0.
Qed.


From Coq Require Import Ascii String Arith.
Require Import Coq.Strings.String.

Definition nat_to_ascii (n : nat) : ascii :=
  match n with
  | 0 => "0"
  | 1 => "1"
  | 2 => "2"
  | 3 => "3"
  | 4 => "4"
  | 5 => "5"
  | 6 => "6"
  | 7 => "7"
  | 8 => "8"
  | _ => "9"
  end.

Fixpoint nat_to_string' (time n : nat) (acc : string) : string :=
  let acc' := String (nat_to_ascii (n mod 10)) acc in
  match time with
  | 0 => acc'
  | S time' =>
    match n / 10 with
    | 0 => acc'
    | n' => nat_to_string' time' n' acc'
    end
  end.

Definition nat_to_string (n : nat) : string :=
    nat_to_string' n n "".


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

  The typing module.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.
Require Import Coq.Bool.Bool.
Require Import Coq.Structures.Equalities.

Require Export BoolEqualitySigDef.
Require Export TVarModuleDef.
Require Export KappaModuleDef.
Require Export PhiModuleDef.
Require Export CpdtTactics.
Require Export Case.
Require Export MoreTacticals.

Module TauModule <: BoolEqualitySig.

Module Types.
 Module TV  := TVarModule. (* So terms can expose it in language module. *)
 Module K := KappaModule.
 Include K.Types.
 Module P := PhiModule.
 Include P.Types.

Inductive Tau : Type :=
 | btvar  : nat -> Tau                               (* A bound type variable, a de Bruijn index. *)
 | ftvar  : TV.t -> Tau                              (* A free type variable. *)
 | cint   : Tau                                      (* Cyclone's Integers. *)
 | cross  : Tau -> Tau -> Tau                        (* Pairs. *)
 | arrow  : Tau -> Tau -> Tau                        (* Function    type. *)
 | ptype  : Tau -> Tau                               (* Pointer     type. *)
 | utype  : K.Kappa -> Tau -> Tau                    (* Universal   type. *)
 | etype  : P.Phi -> K.Kappa -> Tau -> Tau.          (* Existential type. *)

End Types.
Include Types.

(*
Fixpoint fv_tau (tau : Tau) {struct tau} : TVars :=
  match tau with
    | btvar i     => TVSM.empty
    | ftvar x     => TVSM.singleton x
    | arrow t0 t1 => TVSM.union (fv_tau t0) (fv_tau t1)
    | utype k t0   => (fv_tau t0)
end.
*)

Fixpoint open_rec_tau  (k : nat) (tau' : Tau) (tau : Tau)  {struct tau}  : Tau :=
 match tau with
   | btvar i       => if (beq_nat k i) then tau' else (btvar i)
   | ftvar i       => ftvar i
   | cint          => cint
   | cross t0 t1   => cross (open_rec_tau k tau' t0) (open_rec_tau k tau' t1)
   | arrow t0 t1   => arrow (open_rec_tau k tau' t0) (open_rec_tau k tau' t1)
   | ptype  t0     => ptype (open_rec_tau k tau' t0)
   | utype kp t0   => utype kp (open_rec_tau (S k) tau' t0)
   | etype p kp t0 => etype p kp (open_rec_tau (S k) tau' t0)
  end.

Inductive lc_tau : Tau -> Prop :=
 | lc_tau_ftvar : forall x, lc_tau (ftvar x)
 | lc_tau_arrow : forall t0 t1, lc_tau t0 -> lc_tau t1 -> lc_tau (arrow t0 t1)
 | lc_tau_utype : forall L' k t,
                  (forall alpha, (TVSM.mem alpha L') = false
                                 -> lc_tau (open_rec_tau 0 (ftvar alpha) t )) ->
                  lc_tau (utype k t).

Function eqb (t t' : Tau) : bool :=
 match t, t' with
 | tv_t alpha, tv_t beta => TV.eqb alpha beta
 | cint, cint => true
 | (cross t0 t1), (cross t0' t1') => andb (eqb t0 t0') (eqb t1 t1')
 | (arrow t0 t1), (arrow t0' t1') => andb (eqb t0 t0') (eqb t1 t1')
 | ptype t, ptype t' => (eqb t t')
(* No alpha conversion for the moment. *)
 | utype alpha kappa tau, utype alpha' kappa' tau' =>
   andb (andb (TV.eqb alpha alpha') (K.eqb kappa kappa'))
        (eqb tau tau')
 | etype p alpha kappa tau, etype p' alpha' kappa' tau' =>
   andb (andb (P.eqb p p')  (TV.eqb alpha alpha'))
        (andb (K.eqb kappa kappa') (eqb tau tau'))

 | _ , _ => false
end.
Hint Unfold eqb.
Hint Resolve eqb.

Fixpoint eq (a b : Tau) : Prop :=
    match eqb a b with
     | false => False
     | true => True
    end.

Ltac destruct_away :=
  repeat match goal with
    | [ |- ?X = true ] => destruct X; try solve[inversion H]; try reflexivity
         end.

Lemma eqb_eq : forall x y : Tau, eqb x y = true <-> eq x y.
Proof.
  destruct x; destruct y; crush; destruct_away.
Qed.

Lemma eqb_to_eq:
  forall t0 t1, eqb t0 t1 = true -> t0 = t1.
Proof.
  induction t0; induction t1; intros; try solve [inversion H].

  inversion H.
  apply TV.eqb_to_eq in H1.
  rewrite H1.
  reflexivity.

  reflexivity.

  unfold eqb in H.
  fold eqb in H.
  apply andb_true_iff in H.
  inversion H.
  apply IHt0_1 in H0.
  apply IHt0_2 in H1.
  subst.
  reflexivity.

  unfold eqb in H.
  fold eqb in H.
  apply andb_true_iff in H.
  inversion H.
  apply IHt0_1 in H0.
  apply IHt0_2 in H1.
  subst.
  reflexivity.

  unfold eqb in H.
  fold eqb in H.
  apply IHt0 in H.
  rewrite H.
  reflexivity.

  unfold eqb in H.
  fold eqb in H.
  apply andb_true_iff in H.
  inversion H.
  apply andb_true_iff in H0.
  inversion H0.
  apply IHt0 in H1.
  apply TV.eqb_to_eq in H2.
  apply K.eqb_to_eq in H3.
  subst.
  reflexivity.

  unfold eqb in H.
  fold eqb in H.
  apply andb_true_iff in H.
  inversion H.
  apply andb_true_iff in H0.
  inversion H0.
  apply andb_true_iff in H1.
  inversion H1.
  apply IHt0 in H5.
  apply P.eqb_to_eq in H2.
  apply TV.eqb_to_eq in H3.
  apply K.eqb_to_eq in H4.
  subst.
  reflexivity.
Qed.
Hint Resolve eqb_eq.

Lemma eqb_refl:
 forall (t : Tau),
   eqb t t = true.
Proof.
  intros.
  induction t; crush.
Qed.
Hint Resolve eqb_refl.

Lemma eq_refl:
 forall (a : Tau),
   eq a a.
Proof.
  intros.
  apply eqb_eq.
  apply eqb_refl.
Qed.

Ltac apply_beq_eqs :=
  repeat match goal with
    | [ I : eqb _ _ = true
        |- _ ] => apply eqb_to_eq in I; subst; try reflexivity
    | [ I : P.eqb _ _ = true
        |- _ ] => apply P.eqb_to_eq in I; subst; try reflexivity
    | [ I : K.eqb _ _ = true
        |- _ ] => apply K.eqb_to_eq in I; subst; try reflexivity
    | [ I : TV.eqb _ _ = true
        |- _ ] => apply TV.eqb_to_eq in I; subst; try reflexivity
end.

Lemma eqb_iff_eq:    forall a b, eqb a b = true <-> a = b.
Proof.
  destruct a; destruct b; try solve[crush];
  split;
  intros;
  unfold eqb in H;
  fold eqb in H;
  simplify_boolean_and_true;
  apply_beq_eqs;
  intros;
  inversion H;
  subst;
  apply eqb_refl.
Qed.
Hint Resolve eqb_iff_eq.

(* not quite sure why I have to change the proof structure here at all. *)
Lemma eqb_sym : forall x y, eqb x y = eqb y x.
Proof.
  induction x; induction y; auto.
  try solve [crush].
  try solve [crush].
  try solve [crush].
  try solve [crush].
  unfold eqb.
  fold eqb.
  rewrite TV.eqb_sym.
  rewrite K.eqb_sym.
  rewrite IHx.
  reflexivity.
  unfold eqb.
  fold eqb.
  rewrite TV.eqb_sym.
  rewrite P.eqb_sym.
  rewrite K.eqb_sym.
  rewrite IHx.
  reflexivity.
Qed.
Hint Immediate eqb_sym.

Lemma eq_sym : forall x y : Tau, eq x y -> eq y x.
Proof.
  intros.
  apply eqb_eq.
  apply eqb_eq in H.
  rewrite eqb_sym.
  assumption.
Qed.

Lemma eqb_to_neq:
  forall t0 t1, eqb t0 t1 = false -> t0 <> t1.
Proof.
  induction t0; induction t1; intros; try solve [inversion H]; try solve [discriminate].
  apply TV.eqb_to_neq in H.
  crush.

  unfold eqb in H.
  fold eqb in H.
  apply andb_false_iff in H.
  destruct H.
  apply IHt0_1 in H.
  crush.
  apply IHt0_2 in H.
  crush.

  unfold eqb in H.
  fold eqb in H.
  apply andb_false_iff in H.
  destruct H.
  apply IHt0_1 in H.
  crush.
  apply IHt0_2 in H.
  crush.

  unfold eqb in H.
  fold eqb in H.
  apply IHt0 in H.
  crush.

  unfold eqb in H.
  fold eqb in H.
  apply andb_false_iff in H.
  destruct H.
  apply andb_false_iff in H.
  destruct H.
  apply TV.eqb_to_neq in H.
  crush.
  apply K.eqb_to_neq in H.
  crush.
  apply IHt0 in H.
  crush.

  unfold eqb in H.
  fold eqb in H.
  apply andb_false_iff in H.
  destruct H.
  apply andb_false_iff in H.
  destruct H.
  apply P.eqb_to_neq in H.
  crush.
  apply TV.eqb_to_neq in H.
  crush.
  apply andb_false_iff in H.
  destruct H.
  apply K.eqb_to_neq in H.
  crush.
  apply IHt0 in H.
  crush.
Qed.
Hint Resolve eqb_to_neq.

Ltac fold_n_neq :=
  repeat match goal with
    | [ I : eqb ?x ?y = false |- ?x <> ?y  ] =>
      fold eqb in I; unfold eqb in I; simplify_boolean_and_false
    | [ I : eqb ?x _ = false,
        IH: forall _, eqb ?x _ = false <-> ?x <> _
       |- _ <> _  ] =>
       apply IH in I; congruence
    | [ H : TV.eqb _ _ = false |- _ ] =>
      apply TV.eqb_to_neq in H; try congruence
    | [ H : K.eqb _ _ = false |- _ ] =>
      apply K.eqb_to_neq in H; try congruence
    | [ H : P.eqb _ _ = false |- _ ] =>
      apply P.eqb_to_neq in H; try congruence
end.

Lemma eqb_iff_neq:   forall a b, eqb a b = false <-> a <> b.
Proof.
  induction a; induction b; try split; try intros;
  try solve[congruence];
  try solve[simpl; reflexivity];  try solve[simpl in H; inversion H];
  try solve [unfold eqb in H;
             fold eqb in H;
             simplify_boolean_and_false;
             try apply eqb_to_neq in H;
             try apply eqb_to_neq in H0;
             congruence];
  try solve[unfold eqb in H;
            fold eqb in H;
            simplify_boolean_and_false;
            fold_n_neq;
            congruence].
Admitted.
Hint Resolve eqb_iff_neq.

Lemma eqb_trans:
  forall x y z,
    eqb x y = true -> eqb y z = true -> eqb x z = true.
Proof.
  intros.
  pose proof H as H'.
  pose proof H0 as H0'.
  apply eqb_to_eq in H.
  apply eqb_to_eq in H0.
  subst.
  assumption.
Qed.
Hint Resolve eqb_trans.

Lemma eq_trans :
  forall x y z,
    eq x y -> eq y z -> eq x z.
Proof.
  intros.
  apply eqb_eq in H.
  apply eqb_eq in H0.
  apply eqb_eq.
  apply eqb_trans with (x:= x) (y:= y) (z:= z); try assumption.
Qed.

Function NotFreeInTau (beta : TV.Var) (tau : Tau) : Prop :=
  match tau with
    | tv_t alpha =>
      if TV.eqb beta alpha then False else True
    | cint        => True
    | cross t0 t1 =>
       (NotFreeInTau beta t0) /\ (NotFreeInTau beta t1)
    | arrow t0 t1 =>
        (NotFreeInTau beta t0) /\ (NotFreeInTau beta t1)
    | ptype t     => NotFreeInTau beta t
    | utype alpha _ t =>
      if TV.eqb beta alpha then True else NotFreeInTau beta t
    | etype _ alpha _ t =>
      if TV.eqb beta alpha then True else NotFreeInTau beta t
  end.

Instance eq_equiv : Equivalence eq.
Proof.
  split.
  exact eq_refl.
  exact eq_sym.
  exact eq_trans.
Defined.

Ltac destruct_evidence :=
  repeat match goal with
    | [ |- {(if ?X then True else False)} + { _ } ] =>
      destruct X; try solve[simpl; right; congruence];
      try solve[simpl; left; trivial]
 end.

Lemma eq_dec : forall x y : Tau, {eq x y} + {~ eq x y}.
Proof.
  intros.
  induction x; induction y; unfold eq; destruct_evidence.
Qed.

Definition t:= Tau.

End TauModule.


(** * Opposite Category *)
Require Import Category.Core Category.Objects.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope morphism_scope.
Local Open Scope category_scope.

(** ** Definition of [Cᵒᵖ] *)
Definition opposite (C : PreCategory) : PreCategory
  := @Build_PreCategory'
       C
       (fun s d => morphism C d s)
       (identity (C := C))
       (fun _ _ _ m1 m2 => m2 o m1)
       (fun _ _ _ _ _ _ _ => @associativity_sym _ _ _ _ _ _ _ _)
       (fun _ _ _ _ _ _ _ => @associativity _ _ _ _ _ _ _ _)
       (fun _ _ => @right_identity _ _ _)
       (fun _ _ => @left_identity _ _ _)
       (@identity_identity C)
       _.

Local Notation "C ^op" := (opposite C) : category_scope.

(** ** [ᵒᵖ] is judgmentally involutive *)
Definition opposite_involutive C : (C^op)^op = C := idpath.

(** ** Initial objects are opposite terminal objects, and vice versa *)
Section DualObjects.
  Variable C : PreCategory.

  Definition terminal_opposite_initial (x : C)
             `(H : IsTerminalObject C x)
  : IsInitialObject (C^op) x
    := fun x' => H x'.

  Definition initial_opposite_terminal (x : C)
             `(H : IsInitialObject C x)
  : IsTerminalObject (C^op) x
    := fun x' => H x'.
End DualObjects.

Module Export CategoryDualNotations.
  Notation "C ^op" := (opposite C) : category_scope.
End CategoryDualNotations.


Require Import XSetInterface.
Require Classes.RelationClasses.

Module Type DecidableReprType (E : DecidableType) <: DecidableType.

Definition t := E.t.
Parameter eq : t -> t -> Prop.
Parameter eq_equiv : Equivalence eq.
Parameter eq_dec : forall x y : t, {eq x y} + {~ eq x y}.

Parameter repr : t -> t.
Parameter repr_mod : forall x : t, E.eq x (repr x).
Parameter repr_eq : forall x y : t, E.eq x y <-> eq (repr x) (repr y).
Parameter eq_sub : forall x y : t, eq x y -> E.eq x y.

End DecidableReprType.

(** Module for [Logic.eq] (some obvious specifications are omitted) *)
Module Type DecidableReprEq (E : DecidableType).

Definition t := E.t.
Parameter eq_dec : forall x y : t, {x = y} + {x <> y}.
Parameter repr : t -> t.
Parameter repr_mod : forall x : t, E.eq x (repr x).
Parameter repr_eq : forall x y : t, E.eq x y <-> repr x = repr y.

End DecidableReprEq.

(** DecidableReprEq -> DecidableReprType *)
Module DecidableReprEq2Type (E : DecidableType) (D : DecidableReprEq E) <: DecidableReprType E.

Definition t := E.t.
Definition eq := @Logic.eq t.
Definition eq_equiv := @RelationClasses.eq_equivalence t.
Definition eq_dec := D.eq_dec.

Definition repr := D.repr.
Lemma repr_mod : forall x : t, E.eq x (repr x).
exact D.repr_mod. Qed.
Lemma repr_eq : forall x y : t, E.eq x y <-> repr x = repr y.
exact D.repr_eq. Qed.
Lemma eq_sub : forall x y : t, x = y -> E.eq x y.
intros; subst.
now apply E.eq_equiv.
Qed.

End DecidableReprEq2Type.

Module DRTspec (E : DecidableType) (X : DecidableReprType E).

Import X.
Lemma repr_involution : forall x : t, eq (repr x) (repr (repr x)).
intro x; apply repr_eq; apply repr_mod.
Qed.

Lemma repr_eq' : forall x y : t, eq x y -> eq (repr x) (repr y).
intros x y Heq.
apply repr_eq.
apply eq_sub.
now auto.
Qed.

Lemma repr_exists : forall x : t, (exists y : t, eq (repr y) x) -> eq x (repr x).
intros.
destruct H as [y H].
apply eq_equiv with (repr y).
apply eq_equiv; now auto.
apply eq_equiv with (repr (repr y)).
now apply repr_involution.
apply repr_eq.
apply eq_sub.
now auto.
Qed.

End DRTspec.

Module Type OrderedReprType (E : DecidableType) <: OrderedType.

Include DecidableReprType E.

Parameter lt : t -> t -> Prop.
Parameter lt_strorder : StrictOrder lt.
Parameter lt_compat : Proper (eq ==> eq ==> iff) lt.

Parameter compare : t -> t -> comparison.
Parameter compare_spec :
  forall x y : t, CompareSpec (eq x y) (lt x y) (lt y x) (compare x y).

End OrderedReprType.

Module OrderedRepr2Type (E : DecidableType) (E' : OrderedReprType E) <: OrderedType.

Include E.

Definition lt (x y : t) := E'.lt (E'.repr x) (E'.repr y).

Theorem lt_strorder : StrictOrder lt.
unfold lt; constructor.
 unfold Irreflexive.
  unfold complement, Reflexive.
   intro.
    now apply E'.lt_strorder.
 unfold Transitive.
  intros x y z.
   now apply E'.lt_strorder.
Qed.

Theorem lt_compat : Proper (eq ==> eq ==> iff) lt.
unfold Proper.
 compute.
  intros.
   apply E'.lt_compat; apply E'.repr_eq; now auto.
Qed.

Definition compare (x y : t) := E'.compare (E'.repr x) (E'.repr y).

Theorem compare_spec :
  forall x y : t, CompareSpec (eq x y) (lt x y) (lt y x) (compare x y).
intros x y; unfold lt, compare.
 destruct (E'.compare_spec (E'.repr x) (E'.repr y)).
  apply CompEq; apply E'.repr_eq; now auto.
  apply CompLt; now auto.
  apply CompGt; now auto.
Qed.

End OrderedRepr2Type.


Require Import Program.Basics Program.Tactics.
Require Import Equations.Prop.Equations.

Equations foo (n : nat) : nat :=
foo n := n + k 0
  where k (x : nat) : nat :=
  { k 0 := 0 ; k (S n') := n }.

Parameter f : nat -> (nat * nat).

Equations foo' (n : nat) : nat :=
foo' 0 := 0;
foo' (S n) := n + k (f 0) (0, 0)

  where k (x : nat * nat) (y : nat * nat) : nat :=
  { k (x, y) (x', y') := x }.

Parameter kont : ((nat * nat) -> nat) -> nat.

Equations foo'' (n : nat) : nat :=
foo'' 0 := 0;
foo'' (S n) := n + kont absw

  where absw : (nat * nat) -> nat :=
  absw (x, y) := x.

Equations foo3 (n : nat) : nat :=
foo3 0 := 0;
foo3 (S n) := n + kont (λ{ | (x, y) := x }).

Variant index : Set := i1 | i2.

Derive NoConfusion for index.

Inductive expr : index -> Set :=
| e1 : expr i1
| e2 {i} : expr i -> expr i2.

Derive Signature NoConfusion NoConfusionHom for expr.

Parameter kont' : forall x : index, (expr x -> nat) -> nat.

Equations foo4 {i} (n : expr i) : nat :=
foo4 e1 := 0;
foo4 (@e2 i e) := absw e

  where absw : forall {i}, expr i -> nat :=
  absw e1 := 0;
  absw (e2 _) := 0.

Equations foo5 {i} (n : expr i) : nat :=
foo5 e1 := 0;
foo5 (@e2 i e) := absw e

  where absw : expr i -> nat :=
  absw e1 := 0;
  absw (e2 e') := foo5 e'.

Equations foo6 : nat :=
  foo6 := 0.

Equations foo7 : nat -> nat :=
  foo7 x := if bla then 0 else 1 + bla' eq_refl

  where bla : bool :=
  { bla := true }

  where bla' : bla = bla -> nat :=
  { bla' H := 1 + if bla then 1 else 2 }.

Equations foo8 : nat -> nat :=
{ foo8 0 := 0;
  foo8 (S x) := if bla then 0 else 1 + bla' eq_refl + foo8 x

  where bla : bool :=
  { bla := true }

  where bla' : bla = bla -> nat :=
  { bla' H := 1 + if bla then 1 else 2 + foo8 x }

  where bla'' : nat :=
  { bla'' := 3 + bla' eq_refl + baz 4 } }

where baz : nat -> nat :=
baz 0 := 0;
baz (S n) := baz n.

Set Warnings "-notation-overridden".

Notation "{ x : A & y }" := (@sigma A (fun x : A => y)%type) (x at level 99) : type_scope.
Notation "{ x & y }" := (@sigma _ (fun x : _ => y)%type) (x at level 99) : type_scope.

Notation "&( x , .. , y , z )" :=
  (@sigmaI _ _ x .. (@sigmaI _ _ y z) ..)
    (right associativity, at level 4,
     format "&( x ,  .. ,  y  ,  z )").
#[local]
Obligation Tactic := idtac.

Equations foo9 : { x: nat & x = 0 } :=
foo9 := &(lhs, rhs)
   where lhs : nat :=
    { lhs := 0 }

   where rhs : lhs = 0 :=
   { rhs := eq_refl }.