(** * Tactics *)
(**  Some useful tactics dealing with permutations, lists and maps
 *)

Require Export Permutation.
Require Export Coq.Lists.List.
Require Export Coq.Arith.Arith.
Require Export Coq.Init.Nat.
Require Export MMLL.Misc.Permutations.
Require Export MMLL.Misc.Utils.
Require Import Lia.
Export ListNotations.

Set Implicit Arguments.

 Global Hint Extern 1 (Permutation ?S ?U) =>
  match goal with
  | H: Permutation S ?T |- _ => apply (Permutation_trans H)
  | H: Permutation ?T S  |- _ => symmetry in H; apply (Permutation_trans H)
  end : core.

Ltac clear_junk :=
repeat
 match goal with
 | [ H: ?a = ?a |- _ ] => clear H
 | [ H: (?a,?b) = (?a,?b) |- _ ] => clear H
 | [ H1: ?A, H2: ?A |- _ ] => clear H1

 | [ H: In ?F (?F :: _) |- _ ] => clear H
 | [ H: In ?F (_++[?F]) |- _ ] => clear H
 | [ H: In ?F (_++?F :: _)|- _ ] => clear H
 | [ H: Permutation ?A ?A |- _] => clear H
 end.

Ltac simplifier :=
repeat
  match goal with
 | [ H: map ?f ?B = [_] |- _ ] => apply map_eq_cons in H;simplifier
 | [ H: map ?f ?B = [ ] |- _ ] => apply map_eq_nil in H;subst
 | [ H: context[_++nil] |- _ ] => rewrite app_nil_r in H
 | [ H: context[nil++_] |- _ ] => rewrite app_nil_l in H
 | [  |- context[_++nil] ] => rewrite app_nil_r
 | [  |- context[nil++_] ] => rewrite app_nil_l

 | [ H: context[_ - 0] |- _ ] => rewrite Nat.sub_0_r in H
 | [ H: context[S _ - 1] |- _ ] => simpl in H;rewrite Nat.sub_0_r in H
 | [ H: context[fst (_, _)] |- _ ] => simpl in H
 | [ H: context[snd (_, _)] |- _ ] => simpl in H
 | [  |- context[_ - 0] ] => rewrite Nat.sub_0_r
 | [  |- context[S _ - 1] ] => simpl;rewrite Nat.sub_0_r
 | [  |- context[fst (_, _)] ] => simpl
 | [  |- context[snd (_, _)] ] => simpl

  | [ H1: ?f ?a = true, H2: context[?f ?a] |- _ ] => rewrite H1 in H2
  | [ H1: ?f ?a = false, H2: context[?f ?a] |- _ ] => rewrite H1 in H2

  | [ H: ?f ?a = true |- context[?f ?a]  ] => rewrite H
  | [ H: ?f ?a = false |- context[?f ?a]  ] => rewrite H

  | [ H1: ?f = [], H2: context[?f] |- _ ] => rewrite H1 in H2
  | [ H: ?f = [] |- context[?f]  ] => rewrite H

 | [H : exists (x : _), _ |- _ ] => destruct H
 | [H : _ /\ _ |- _ ] => decompose [and or] H;clear H
 | [H : _ \/ _ |- _ ] => decompose [and or] H;clear H
 | [ |- _ /\ _ ] => split
end;auto.

Ltac strivial :=
try
  match goal with
 | [H1: ?f ?a = true, H2: ?f ?a = false |- _] => rewrite H1 in H2; discriminate H2

 | [  |- ?a = ?a ] => reflexivity
 | [H: False |- _] => contradiction
 | [H1: ?F , H2 : ~ ?F |- _ ] => contradiction
 | [ |- In ?F (?F :: _)] => apply in_eq
 | [H: In ?F ?L  |- In ?F (_ :: ?L)] => apply in_cons;auto
 | [H: In ?F ?L  |- In ?F (?L ++ _)] => apply in_or_app;left;auto
 | [H: In ?F ?L  |- In ?F (_ ++ ?L)] => apply in_or_app;right;auto
 | [ |- In ?F (_++ ?F :: _)] => apply in_elt
 | [ H: In _ nil |- _ ] => inversion H
 | [ H: [_] = nil |- _ ] => inversion H
 | [ H: nil = [_] |- _ ] => inversion H

 | [ H: Permutation ?A ?B |- Permutation ?B ?A  ] => symmetry in H;auto
 | [ H: Permutation ?A ?B |- Permutation (?a::?A) (?a::?B)  ] => apply perm_skip;auto
 | [ |- Permutation (?x::?y::?A) (?y::?x::?A)  ] =>  rewrite perm_swap;auto
 | [H : ?A /\ ?B |- ?A ] => firstorder
 | [H : ?A /\ ?B |- ?B ] => firstorder
 | [H : ?A |- ?A \/ ?B ] => firstorder
 | [H : ?B |- ?A \/ ?B] => firstorder

 | [ H: ?a <> ?a |- _ ] => try solve [timeout 2 firstorder]

 | [ H1: forall x, ?P x -> ?L = ?R, H2: ?P ?X |- _ ] => rewrite (H1 X H2) in x
 | [ H1: ?P ?X -> ?P ?Y, H2: ?P ?X |- ?P ?Y ] => apply H1;auto
 | [ H1: _ ?P ?X -> _ ?P ?Y, H2: _ ?P ?X, H3: ?P ?F  |- _ ?P (?F::?Y) ] => simpl;apply H1;auto
 | [  |- _ <= _ ] => try solve[lia]
 | |- _ >= _ => try solve[lia]
 | |- _ < _ => try solve[lia]
 | |- _ > _ => try solve[lia]
 | [  |- Permutation _ _ ] => try solve[simpl;subst;perm]
 end;auto.

Ltac clean_goal :=
try
repeat
 match goal with
 | [ H: ?a = ?b |- _ ] => solve [inversion H]
 | [ H: [?a] = [?b] |- _ ] => inversion H;subst;clear H
 | [ H: (_,_) = (_,_) |- _ ] => inversion H;clear H

 (* About Permutations *)
 | [ H: Permutation nil ?L |- _] => apply Permutation_nil in H
 | [ H: Permutation ?L nil  |- _] => symmetry in H; apply Permutation_nil in H
 | [ H: Permutation [?a] ?L  |- _] => apply Permutation_length_1_inv in H
 | [ H: Permutation ?L [?a] |- _] => symmetry in H; apply Permutation_length_1_inv in H
 | [ H: Permutation [?a] [?b]  |- _] => apply Permutation_length_1 in H

 (* About Lists *)

(*  | [ H: In _ [_] |- _ ] =>
        let newH := fresh "H" in inversion H as [newH | newH];[subst| inversion newH]    *)
 | [ H: ?A ++ ?B = nil |- _ ] =>
        apply app_eq_nil in H; destruct H
 | [ H: nil =  ?A ++ ?B |- _ ] =>
      symmetry in H; apply app_eq_nil in H; destruct H
 | [ H: ?A ++ ?B = [_] |- _ ] =>
        apply app_eq_unit in H; decompose [and or] H;clear H
 | [ H: [_] = ?A ++ ?B |- _ ] =>
        symmetry in H; apply app_eq_unit in H; decompose [and or] H;clear H

end;subst.

Ltac sauto := subst; (* after an inversion *)
              simplifier; clean_goal;
              try solve [strivial];
              clear_junk; auto.

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

  (** ** Aditional results on Forall/map *)
Section ForAllMap.

Lemma ForallIn :  forall {A : Type} {F : A} {L : list A} (f : A -> Prop),
      Forall f L -> In F L -> f F.
  Proof.
    intros.
    generalize (Forall_forall f L );intro.
    destruct H1.
    apply H1 with (x:= F) in H ;auto.
  Qed.

End ForAllMap .

Ltac solveForall :=
try
  match goal with
   | [  |- Forall _ nil] => apply Forall_nil
   | [ H1 : Forall ?f ?M, H2 : Permutation ?M ?N |- Forall ?f ?N  ] => rewrite <- H2; auto
   | [ H1 : Forall ?f ?M, H2 : Permutation ?N ?M |- Forall ?f ?N  ] => rewrite H2; auto
   | [ H1 : Forall ?f ?M, H2 : Permutation ?M (?N++?L) |- Forall ?f ?N  ] => rewrite H2 in H1; simpl in H1; solveForall
   | [ H1 : Forall ?f ?M, H2 : Permutation (?N++?L) ?M |- Forall ?f ?N  ] => rewrite <- H2 in H1; simpl in H1; solveForall
   | [ H1 : Forall ?f ?M, H2 : Permutation ?M (?N++?L) |- Forall ?f ?L  ] => rewrite H2 in H1; solveForall
   | [ H1 : Forall ?f ?M, H2 : Permutation (?N++?L) ?M |- Forall ?f ?L  ] => rewrite <- H2 in H1; solveForall
   | [ H1 : Forall ?f ?M, H2 : Permutation ?M (?F::?L) |- ?f ?F  ] => rewrite H2 in H1; solveForall
   | [ H1 : Forall ?f ?M, H2 : Permutation (?F::?L) ?M |- ?f ?F  ] => rewrite <- H2 in H1; solveForall
   | [ H1 : Forall ?f ?M, H2 : Permutation ?M (?F::?L) |- Forall ?f ?L  ] => rewrite H2 in H1; solveForall
   | [ H1 : Forall ?f ?M, H2 : Permutation (?F::?L) ?M |- Forall ?f ?L  ] => rewrite <- H2 in H1; solveForall
   | [ H1 : Forall ?f ?M, H2 : Permutation ?M (?N++?F::?L) |- ?f ?F  ] => rewrite H2 in H1; solveForall
   | [ H1 : Forall ?f ?M, H2 : Permutation (?N++?F::?L) ?M |- ?f ?F  ] => rewrite <- H2 in H1; solveForall
   | [ H1 : Forall ?f ?M, H2 : Permutation ?M (?N++?F::?L) |- Forall ?f [?F]  ] => rewrite H2 in H1; solveForall
   | [ H1 : Forall ?f ?M, H2 : Permutation (?N++?F::?L) ?M |- Forall ?f [?F]  ] => rewrite <- H2 in H1; solveForall

   | [ H1 : Forall ?f ?M, H2 : Permutation ?M (?N++(_ ?F _)::?L) |- ?f ?F  ] => rewrite H2 in H1; solveForall
   | [ H1 : Forall ?f ?M, H2 : Permutation ?M (?N++(_ _ ?F)::?L) |- ?f ?F  ] => rewrite H2 in H1; solveForall

   | [ H1 : Forall ?f ?M, H2 : Permutation (?N++(_ ?F _)::?L) ?M |- ?f ?F  ] => rewrite <- H2 in H1; solveForall
   | [ H1 : Forall ?f ?M, H2 : Permutation (?N++(_ _ ?F)::?L) ?M |- ?f ?F  ] => rewrite <- H2 in H1; solveForall

   | [ H : Forall ?f (?F :: ?M) |- ?f ?F ] => eapply @Forall_inv with (l:=M) (a:=F);auto
   | [ H : Forall ?f ((_ ?F _) :: ?M) |- ?f ?F ] => eapply @Forall_inv with (l:=M) (a:=F);auto
   | [ H : Forall ?f ((_ _ ?F) :: ?M) |- ?f ?F ] => eapply @Forall_inv with (l:=M) (a:=F);auto

   | [ H : Forall ?f (?F :: ?M) |- Forall ?f ?M ] => apply Forall_inv_tail in H;auto
   | [ H1 : Forall ?f ?M, H2 : Forall ?f ?N |- Forall ?f (?M++?N) ] => apply Forall_app;split;auto
   | [ H: Forall ?f (?M++?N) |-  Forall ?f ?M  /\ Forall ?f ?N ] => apply Forall_app;auto
   | [ H: Forall ?f (?M++?N) |-  Forall ?f ?M ] => apply Forall_app in H; destruct H;auto
   | [ H: Forall ?f (?M++?N) |-  Forall ?f ?N ] => apply Forall_app in H; destruct H;auto
   | [ H: Forall ?f (?M++?N++?L) |-  Forall ?f ?L ] => rewrite app_assoc in H;solveForall
   | [ H: Forall ?f (?M++?N++?L) |-  Forall ?f ?N ] => rewrite Permutation_app_swap_app in H;solveForall
   | [ H: Forall ?f (?M++?F::?L) |-  ?f ?F ] => apply Forall_elt in H;auto
   | [ H: Forall ?f (?M++?F::?L) |-  Forall ?f [?F] ] => apply Forall_elt in H;auto
   | [ H: Forall ?f (?M++?F::?L) |-  Forall ?f ?L ] => rewrite Permutation_cons_append in H;solveForall

   | H: Forall ?f ?M  |- Forall ?f (_ :: ?M) => apply Forall_cons; auto
   | H: Forall ?f ?M  |- Forall ?f (?M++[_]) => apply Forall_app;split;auto
   | [ |- Forall ?f (?M++_) ] => apply Forall_app;split;solveForall
   |  |- Forall ?f (_ :: ?M) => apply Forall_cons; solveForall

    end;auto.

(* Definition plusT L := map (fun x => 2+x) L.

Lemma asas M N: plusT (M++N) = plusT M ++ plusT N.
rewrite map_app. *)

 Ltac solveFoldFALL1 isP :=
try
  match goal with
   | [  |- ?isPL nil] => autounfold
   | [H: ?isPL (?K1++?K2++_) |- ?isPL (?K1++?K2)] => autounfold; rewrite app_assoc in H;autounfold in H
   | [H: ?isPL (?K1++_++?K2) |- ?isPL (?K1++?K2)] => autounfold; autounfold in H;rewrite Permutation_app_rot in H

   | [ H : ?isPL (?F :: ?M) |- isP ?F ] => autounfold in H
   | [ H : ?isPL (?F :: ?M) |- ?isPL ?M ] => autounfold;autounfold in H
   | [ H1 : ?isPL ?M, H2 : ?isPL ?N |- ?isPL (?M++?N) ] => autounfold;autounfold in H1;autounfold in H2
   | [ H: ?isPL (?M++?N) |-  ?isPL ?M  /\ ?isPL ?N ] => autounfold;autounfold in H
   | [ H: ?isPL (?M++?N) |-  ?isPL ?M ] => autounfold;autounfold in H
   | [ H: ?isPL (?M++?N) |-  ?isPL ?N ] => autounfold;autounfold in H
   | [ H: ?isPL (?M++?N++?L) |-  ?isPL ?L ] => autounfold;autounfold in H
   | [ H: ?isPL (?M++?N++?L) |-  ?isPL ?N ] => autounfold;autounfold in H
   | [ H: ?isPL (?M++?F::?L) |-  isP ?F ] => autounfold in H
   | [ H: ?isPL (?M++?F::?L) |-  ?isPL [?F] ] => autounfold;autounfold in H
   | [ H: ?isPL (?M++?F::?L) |-  ?isPL ?L ] => autounfold;autounfold in H

   | H: ?isPL ?M  |- ?isPL (_ :: ?M) => autounfold;autounfold in H
   | H: ?isPL ?M  |- ?isPL (?M++_) => autounfold;autounfold in H
   | H: ?isPL ?M  |- ?isPL (_++?M) => autounfold;autounfold in H
   | [ H1 : ?isPL ?M, H2 : Permutation ?M ?N |- ?isPL ?N  ] => autounfold;autounfold in H1
   | [ H1 : ?isPL ?M, H2 : Permutation ?N ?M |- ?isPL ?N  ] => autounfold;autounfold in H1
   | [ H1 : ?isPL ?M, H2 : Permutation ?M (?N++?L) |- ?isPL ?N  ] => autounfold;autounfold in H1
   | [ H1 : ?isPL ?M, H2 : Permutation (?N++?L) ?M |- ?isPL ?N  ] => autounfold;autounfold in H1
   | [ H1 : ?isPL ?M, H2 : Permutation ?M (?N++?L) |- ?isPL ?L  ] => autounfold;autounfold in H1
   | [ H1 : ?isPL ?M, H2 : Permutation (?N++?L) ?M |- ?isPL ?L  ] => autounfold;autounfold in H1
   | [ H1 : ?isPL ?M, H2 : Permutation ?M (?F::?L) |- isP ?F  ] => autounfold in H1
   | [ H1 : ?isPL ?M, H2 : Permutation (?F::?L) ?M |- isP ?F  ] => autounfold in H1
   | [ H1 : ?isPL ?M, H2 : Permutation ?M (?F::?L) |- ?isPL ?L  ] => autounfold;autounfold in H1
   | [ H1 : ?isPL ?M, H2 : Permutation (?F::?L) ?M |- ?isPL ?L  ] => autounfold;autounfold in H1
   | [ H1 : ?isPL ?M, H2 : Permutation ?M (?N++?F::?L) |- isP ?F  ] => autounfold in H1
   | [ H1 : ?isPL ?M, H2 : Permutation (?N++?F::?L) ?M |- isP ?F  ] => autounfold in H1
   | [ H1 : ?isPL ?M, H2 : Permutation ?M (?N++?F::?L) |- ?isPL [?F]  ] => autounfold;autounfold in H1
   | [ H1 : ?isPL ?M, H2 : Permutation (?N++?F::?L) ?M |- ?isPL [?F]  ] => autounfold;autounfold in H1

   | [ |- ?isPL (?M++_) ] => autounfold
   |  |- ?isPL (_ :: ?M) => autounfold

    end;solveForall.

 (*   Variable f: nat -> Prop.
   Definition isNat M := Forall f M.
   Hint Unfold isNat.
   Lemma asas M L : isNat L -> isNat (M++L).
      intros. solveFoldForall isNat f.
  *)

 Ltac solveFoldFALL2 isP :=
try
  match goal with
   | [  |- ?isPL _ nil] => autounfold
    | [H: ?isPL _ (?K1++?K2++_) |- ?isPL _ (?K1++?K2)] => autounfold; rewrite app_assoc in H;autounfold in H
   | [H: ?isPL _ (?K1++_++?K2) |- ?isPL _ (?K1++?K2)] => autounfold; autounfold in H;rewrite Permutation_app_rot in H

   | [ H : ?isPL _ (?F :: ?M) |- isP ?F ] => autounfold in H
   | [ H : ?isPL _ (?F :: ?M) |- ?isPL _ ?M ] => autounfold;autounfold in H
   | [ H1 : ?isPL _ ?M, H2 : ?isPL _ ?N |- ?isPL _ (?M++?N) ] => autounfold;autounfold in H1;autounfold in H2
   | [ H: ?isPL _ (?M++?N) |-  ?isPL _ ?M  /\ ?isPL _ ?N ] => autounfold;autounfold in H
   | [ H: ?isPL _ (?M++?N) |-  ?isPL _ ?M ] => autounfold;autounfold in H
   | [ H: ?isPL _ (?M++?N) |-  ?isPL _ ?N ] => autounfold;autounfold in H
   | [ H: ?isPL _ (?M++?N++?L) |-  ?isPL _ ?L ] => autounfold;autounfold in H
   | [ H: ?isPL _ (?M++?N++?L) |-  ?isPL _ ?N ] => autounfold;autounfold in H
   | [ H: ?isPL _ (?M++?F::?L) |-  isP ?F ] => autounfold in H
     | [ H: ?isPL _ (?M++?F::?L) |-  ?isPL _ [?F] ] => autounfold;autounfold in H
 | [ H: ?isPL _ (?M++?F::?L) |-  ?isPL _ ?L ] => autounfold;autounfold in H

   | H: ?isPL _ ?M  |- ?isPL _ (_ :: ?M) => autounfold;autounfold in H
   | H: ?isPL _ ?M  |- ?isPL _ (?M++_) => autounfold;autounfold in H
   | H: ?isPL _ ?M  |- ?isPL _ (_++?M) => autounfold;autounfold in H

   | [ H1 : ?isPL _ ?M, H2 : Permutation ?M ?N |- ?isPL _ ?N  ] => autounfold;autounfold in H1
   | [ H1 : ?isPL _ ?M, H2 : Permutation ?N ?M |- ?isPL _ ?N  ] => autounfold;autounfold in H1
   | [ H1 : ?isPL _ ?M, H2 : Permutation ?M (?N++?L) |- ?isPL _ ?N  ] => autounfold;autounfold in H1
   | [ H1 : ?isPL _ ?M, H2 : Permutation (?N++?L) ?M |- ?isPL _ ?N  ] => autounfold;autounfold in H1
   | [ H1 : ?isPL _ ?M, H2 : Permutation ?M (?N++?L) |- ?isPL _ ?L  ] => autounfold;autounfold in H1
   | [ H1 : ?isPL _ ?M, H2 : Permutation (?N++?L) ?M |- ?isPL _ ?L  ] => autounfold;autounfold in H1
   | [ H1 : ?isPL _ ?M, H2 : Permutation ?M (?F::?L) |- isP ?F  ] => autounfold in H1
   | [ H1 : ?isPL _ ?M, H2 : Permutation (?F::?L) ?M |- isP ?F  ] => autounfold in H1
   | [ H1 : ?isPL _ ?M, H2 : Permutation ?M (?F::?L) |- ?isPL _ ?L  ] => autounfold;autounfold in H1
   | [ H1 : ?isPL _ ?M, H2 : Permutation (?F::?L) ?M |- ?isPL _ ?L  ] => autounfold;autounfold in H1
   | [ H1 : ?isPL _ ?M, H2 : Permutation ?M (?N++?F::?L) |- isP ?F  ] => autounfold in H1
   | [ H1 : ?isPL _ ?M, H2 : Permutation (?N++?F::?L) ?M |- isP ?F  ] => autounfold in H1
   | [ H1 : ?isPL _ ?M, H2 : Permutation ?M (?N++?F::?L) |- ?isPL _ [?F]  ] => autounfold;autounfold in H1
   | [ H1 : ?isPL _ ?M, H2 : Permutation (?N++?F::?L) ?M |- ?isPL _ [?F]  ] => autounfold;autounfold in H1

   | [ |- ?isPL _ (?M++_) ] => autounfold
   |  |- ?isPL _ (_ :: ?M) => autounfold

    end;solveForall.

Ltac checkPermutationCases H := simpl in H;
 let Hs := type of H in
  match Hs with
  | Permutation (?P1::?L1) (?P2::?L2) => apply PProp_perm_select in H;sauto
  | Permutation  (?L1++?L2) (?L3++?P::nil) => symmetry in H;apply PProp_perm_sel in H;sauto
  | Permutation (?L3++?P::nil) (?L1++?L2) => apply PProp_perm_sel in H;sauto
  | Permutation  (?L1++?L2) (?P::?L3) => apply PProp_perm_select' in H;sauto
  | Permutation (?P::?L3) (?L1++?L2) => symmetry in H;apply PProp_perm_select' in H;sauto
end.


From mathcomp.ssreflect Require Import ssreflect ssrnat seq eqtype ssrbool.
From mathcomp.algebra Require Import ssrint.
Require Import Common.

Fixpoint In {A:Type} (a:A) (l: seq A) : Prop :=
match l with
  | [::] => False
  | b :: m => b = a \/ In a m
end.

Inductive numeric := | S8 | U8 | S16 | U16 | S32 | U32 | S64 | U64 .
Scheme Equality for numeric.

Inductive ctype :=
| Int (_:numeric)
| Pointer : ctype -> ctype
| Struct: seq ctype -> ctype
| Bot | Unit | ErrorType.

Definition Int8 := Int S8.
Definition UInt8 := Int U8.
Definition Int16 := Int S16.
Definition UInt16 := Int U16.
Definition Int32 := Int S32.
Definition UInt32 := Int U32.
Definition Int64 := Int S64.
Definition UInt64 := Int U64.

Fixpoint SizeOf (t:ctype) :=
    match t with
    | Pointer _ => 8
    | Struct els => foldl (fun x y=>x + y) 0 (map SizeOf els)
    | Int S8 | Int U8 => 1
    | Int S16 | Int U16 => 2
    | Int S32 | Int U32 => 4
    | Int S64 | Int U64 => 8
    | _ => 0
    end.

Theorem ctype_better_ind (P: ctype -> Prop):
(forall nt, (P (Int nt)))->
(forall p: ctype, P p -> P (Pointer p) ) ->
(forall l, (forall e, In e l -> P e) -> P (Struct l)) -> P Unit ->
(P Bot) -> (P ErrorType) ->
(forall t:ctype, P t).
Proof.
  move=> Hnt Hptr Hstr Hunit Hbot Herr.
  fix 1.
  have StructProof: forall l : seq ctype, P (Struct l). {
    move=> l. apply Hstr. elim: l.
    - by move=> _ [].
    - move=> a l Hin e /= [].
      + by move=><-; exact (ctype_better_ind a).
      + apply Hin.
  }
  move=>[]; try by [clear ctype_better_ind].
  - elim; try by [ clear ctype_better_ind; try move=> c; apply Hptr].
Qed.

Fixpoint ctype_beq (x y: ctype) {struct x} : bool  :=
let fix process (xs ys: seq ctype) := match xs,ys with
                                        | nil, nil => true
                                        | x::xs, y::ys => ctype_beq x y && process xs ys
                                        | _, nil
                                        | nil, _ => false
                                      end in
match x, y with
  | Int x, Int y => numeric_beq x y
  | Bot, Bot
  | ErrorType, ErrorType => true
  | Pointer px, Pointer py => ctype_beq px py
  | Struct xs, Struct ys => process xs ys
  | Unit, Unit => true
  | _, _ => false
end.

Local Lemma Struct_cons: forall x xs y ys, Struct xs = Struct ys /\ x = y <-> Struct (x::xs) = Struct (y::ys).
Proof. by move=> x xs y ys; split; [move=> [[]] => -> -> | move=> [] -> ->]. Qed.

Theorem ctype_eqP: Equality.axiom ctype_beq.
Proof.
rewrite /Equality.axiom.
fix 1.
move=> x.
elim x; try do [ by case; constructor ].
(* Pointer *)
- move=>[];  move=> y; elim y; try do [try case; by constructor].
  move => z H2 //=.
  elim; try by constructor.
  move=> c H.
  move: (H2 c).
  move: (ctype_beq z c) => [] [].
    by move=> ->; constructor.
    by move=> *;  constructor; case.
    by move=> ->; constructor.
    by move=> *;  constructor; case.
(* Struct *)
- move =>l.
  elim ; try by constructor.

  clear x.
  elim: l.
  + case; by [apply ReflectT | move=> a l; apply ReflectF].
  + move=> a l H []; first by apply ReflectF.
    move=> b m.
    move: (H m) => Hm.
    inversion  Hm as [Hstructs Hstreq| Hstructs Hstreq].
    * destruct (ctype_beq (Struct (a :: l)) (Struct (b :: m))) eqn: Heq_str_big.
      ** apply ReflectT. apply Struct_cons.
      simpl in Heq_str_big.
      split; first by exact Hstructs.
      destruct (ctype_eqP a b) as [Hab|Hab]; [ by exact Hab| by exfalso].
    * apply ReflectF => H_str_big. move: (H m) => Hrefl_eqlm.
      move: (ctype_eqP a b) => Hrefl_ab.
      inversion Hrefl_ab as [Hab Heq_ab|Hab Heq_ab].
      simpl in Heq_str_big. rewrite <- Heq_ab in Heq_str_big.
      simpl in Heq_str_big. rewrite <-Hstreq in Heq_str_big.
        by inversion Heq_str_big.
    * inversion H_str_big. by exact (Hab H1).
      destruct  (ctype_beq (Struct (a :: l)) (Struct (b :: m))) eqn: Hsab; [apply ReflectT| apply ReflectF].
      ** simpl in Hsab.
      rewrite <-Hstreq in Hsab.
      rewrite Bool.andb_false_r in Hsab. by inversion Hsab.
      **  move=> Heq.
      inversion Heq.
      rewrite H2 in Hstructs. by exfalso.
Qed.

Canonical ctype_eqMixin := EqMixin ctype_eqP.
Canonical ctype_eqType := EqType ctype ctype_eqMixin.

Theorem numeric_eqP: Equality.axiom numeric_beq.
Proof. by case; case; constructor. Qed.

Canonical numeric_eqMixin := EqMixin numeric_eqP.
Canonical numeric_eqType := EqType numeric numeric_eqMixin.

(*Definition int_union (x y: numeric) : numeric := match x,y with *)

Definition ctype_eq_dec  := dec_from_reflect ctype_eqP.

(* Pointer value *)
Inductive ptr (t: ctype) := | Goodptr (at_block: nat) (offset: nat) | Nullptr.

Definition ptr_eq_dec t : eq_dec (ptr t).  by rewrite /eq_dec; repeat decide equality. Qed.

Definition ptr_eqP t := reflect_from_dec (ptr_eq_dec t).
Canonical ptr_eqMixin t := EqMixin (ptr_eqP t).
Canonical ptr_eqType t := EqType (ptr t) (ptr_eqMixin t).

(* Holders for different value types *)
Definition coq_type (t: ctype) : Set :=
  match t with
    | Int _ => int
    | Pointer t => ptr t
    | Struct ls => seq nat
    | Bot => unit
    | Unit => unit
    | Error => unit
  end.

Section EqValue.
  Inductive value (t: ctype) : Set := | Value (_t:ctype)  (_:_t = t) (v: coq_type _t) | Garbage | Deallocated | Error.

  Lemma value_inj T C p x y: @Value T C p x = @Value T C p y -> x = y.
    case.
    move => Hd.
    by depcomp Hd.
  Qed.

  Lemma value_surj T C p x y: x = y -> @Value T C p x = @Value T C p y. by move =>->. Qed.

  Lemma value_eq_dec {t} (x y: value t) : { x = y } + { ~ x = y }.
    destruct x, y, t; try by [right; intro H];try by left; subst.
    - subst. simpl in *.
      case: (int_eq_dec v v0). subst; try by [move => ->; left].
      right. by move /value_inj.
    - subst; simpl in *. case: (ptr_eq_dec _ v v0).
      move=> ->. by left.
      move=> *. right. by  move /value_inj.
    -  subst. simpl in *.
       case Heq: ( v == v0); move /eqP in Heq;
          by [ left; rewrite Heq | right; move /value_inj].
    -  subst; simpl in *.
       case: (unit_eq_dec v v0);by [move=> ->;left|move=> *; right; move /value_inj ].
    -  subst; simpl in *.
       case: (unit_eq_dec v v0);by [move=> ->;left|move=> *; right; move /value_inj].
    -  subst; simpl in *.
       case: (unit_eq_dec v v0);by [move=> ->;left|move=> *; right; move /value_inj].
  Defined.

  Definition value_eqP (t:ctype) := reflect_from_dec (@value_eq_dec t).

  Canonical value_eqMixin (t:ctype) := EqMixin (value_eqP t).
  Canonical value_eqType t := Eval hnf in  EqType (value t) (value_eqMixin t).
End  EqValue.

Definition eq_value_or_error_arith {A:Type} (tl tr: ctype) (v: ctype -> ctype -> A) (err: A):A :=
 match tl, tr  with
    |Int S8, Int S8
    |Int U8, Int U8
    |Int S16, Int S16
    |Int U16, Int U16
    |Int S32, Int S32
    |Int U32, Int U32
    |Int S64, Int S64
    |Int U64, Int U64 => v tl tr
    | _, _=> err
  end
.

Definition eq_value_or_error_proved {A:Type} (tl tr: ctype) (v: tl = tr-> ctype -> ctype -> A) (err: A):A.
  refine(
    match tl == tr as t return tl==tr=t -> A with
    | true => fun Ht =>  v _ tl tr
    | false => fun Ht => err
    end _).
  exact: eqP Ht.
  reflexivity.
Defined.

Definition eq_value_or_error_proved_arith {A:Type} (tl tr: ctype) (v: tl = tr-> ctype -> ctype -> A) (err: A):A.
refine( match tl as tl_, tr as tr_ return tl = tl_-> tr = tr_ -> A with
    |Int S8, Int S8
    |Int U8, Int U8
    |Int S16, Int S16
    |Int U16, Int U16
    |Int S32, Int S32
    |Int U32, Int U32
    |Int S64, Int S64
    |Int U64, Int U64 => fun Hl Hr =>  v _ tl tr
    | _, _=> fun _ _ => err
  end _ _)
; try by [rewrite Hl;rewrite Hr].
reflexivity.
reflexivity.
Defined.

Definition for_eq_carriers {R} (x y: ctype) (def:R)
            (fint: int->int->R)
            (fptr: forall T, ptr T -> ptr T -> R)
            (fstruct: seq nat -> seq nat -> R)
            (fbot: unit->R)
            (ferror: unit->R)
            (xv:coq_type x)
            (yv: coq_type y)
 : R. refine (
   match x as x' , y as y' return x = x' -> y = y' -> R with
     | Int S8 as x', Int S8 as y' =>
       fun Hx: x = x' => fun Hy: y = y' =>
                           fint (cast xv _) (cast yv _)
     | Int U8  as x', Int U8  as y' =>
       fun Hx: x = x' => fun Hy: y = y' =>
                           fint (cast xv _) (cast yv _)
     | Int S16 as x', Int S16 as y' =>
              fun Hx: x = x' => fun Hy: y = y' =>
                                  fint (cast xv _) (cast yv _)
     | Int U16 as x', Int U16 as y' =>
       fun Hx: x = x' => fun Hy: y = y' =>
                           fint (cast xv _) (cast yv _)
     | Int S32 as x', Int S32 as y' =>
       fun Hx: x = x' => fun Hy: y = y' =>
                           fint (cast xv _) (cast yv _)
     | Int U32 as x', Int U32 as y' =>
       fun Hx: x = x' => fun Hy: y = y' =>
                           fint (cast xv _) (cast yv _)
     | Int S64 as x', Int S64 as y' =>
       fun Hx: x = x' => fun Hy: y = y' =>
                           fint (cast xv _) (cast yv _)
     | Int U64 as x', Int U64 as y' =>
       fun Hx: x = x' => fun Hy: y = y' =>
                           fint (cast xv _) (cast yv _)
     | Pointer tx as x', Pointer ty as y'=>
       fun Hx: x = x' => fun Hy: y=y' =>
                           match tx == ty as r return r = (tx == ty) -> R with
                             | true => fun Heq : true = (tx == ty) => fptr tx (cast xv _) (cast yv _)
                             | false => fun Heq : false = (tx == ty) => def
                           end _
     | Bot, Bot => fun _ _ => fbot tt
     | ErrorType, ErrorType => fun _ _ => ferror tt
     | _, _=> fun _ _ => def
   end Logic.eq_refl Logic.eq_refl); try by subst.
      subst.
      by rewrite (eqP (Logic.eq_sym Heq)).
Defined.


From isla Require Import opsem.

Definition a6c : isla_trace :=
  Smt (DeclareConst 0%Z (Ty_BitVec 64%N)) Mk_annot :t:
  Assume (AExp_Binop (Eq) (AExp_Unop (Extract 1%N 1%N) (AExp_Val (AVal_Var "PC" []) Mk_annot) Mk_annot) (AExp_Val (AVal_Bits (BV 1%N 0x0%Z)) Mk_annot) Mk_annot) Mk_annot :t:
  ReadReg "PC" [] (RegVal_Base (Val_Symbolic 0%Z)) Mk_annot :t:
  Smt (DefineConst 1%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 0%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DeclareConst 13%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "x9" [] (RegVal_Base (Val_Symbolic 13%Z)) Mk_annot :t:
  Smt (DeclareConst 14%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "x21" [] (RegVal_Base (Val_Symbolic 14%Z)) Mk_annot :t:
  Smt (DefineConst 17%Z (Binop ((Bvcomp Bvslt)) (Unop (ZeroExtend 64%N) (Val (Val_Symbolic 13%Z) Mk_annot) Mk_annot) (Unop (ZeroExtend 64%N) (Val (Val_Symbolic 14%Z) Mk_annot) Mk_annot) Mk_annot)) Mk_annot :t:
  Smt (DefineConst 18%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 0%Z) Mk_annot; Val (Val_Bits (BV 64%N 0xffffffffffffffd8%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  tcases [
    Smt (Assert (Val (Val_Symbolic 17%Z) Mk_annot)) Mk_annot :t:
    Smt (DefineConst 19%Z (Unop (Extract 0%N 0%N) (Binop ((Bvarith Bvlshr)) (Val (Val_Symbolic 18%Z) Mk_annot) (Val (Val_Bits (BV 64%N 0x1%Z)) Mk_annot) Mk_annot) Mk_annot)) Mk_annot :t:
    BranchAddress (RegVal_Base (Val_Symbolic 18%Z)) Mk_annot :t:
    WriteReg "PC" [] (RegVal_Base (Val_Symbolic 18%Z)) Mk_annot :t:
    tnil;
    Smt (Assert (Unop (Not) (Val (Val_Symbolic 17%Z) Mk_annot) Mk_annot)) Mk_annot :t:
    WriteReg "PC" [] (RegVal_Base (Val_Symbolic 1%Z)) Mk_annot :t:
    tnil
  ]
.


Require Import IOTS.
Require Import LTS.
Require Import LTS_functions.
Require Import Bool BinPos BinNat PeanoNat Nnat.
Require Import Coq.Lists.List.
Require Import Coq.Lists.ListSet.
Import Coq.Lists.List.ListNotations.
Require Import String.
Require Import list_helper.

Inductive ind_out_one_state : state -> set s_label -> s_IOLTS -> Prop :=
  | out_one_state_r1 (s : state) (p : s_IOLTS) :
      In s p.(Ts) -> ind_out_one_state s [delta] p
  | out_one_state_r2 (s : state) (p : s_IOLTS) (so : set s_label) :
      ~ In s p.(Ts) ->
      ~ In delta so ->
      (forall (l : label),
        In (s_event l) so <->
        exists (s' : state),
          In l p.(iolts).(L_u) /\ ind_transition s (event l) s' p.(iolts).(sc_lts).(lts)) ->
      ind_out_one_state s so p.

Definition ind_out (Q : set state) (so : set s_label) (p : s_IOLTS) : Prop :=
  (forall (x : s_label),
    (In x so -> exists (s : state) (so' : set s_label),
                (In s Q /\ ind_out_one_state s so' p /\ In x so')))
    /\
    (forall (s : state), In s Q ->
      exists (so' : set s_label), ind_out_one_state s so' p /\
        forall (o : s_label), In o so' -> In o so).

Theorem s_label_dec : forall x y : s_label, {x = y} + {x <> y}.
Proof.
  decide equality.
  apply string_dec.
Defined.

Fixpoint f_out_one_state' (s : state) (lt: list transition) (Lu : set label)
    : set s_label :=
  match lt with
  | [] => []
  | (q1, e, q2) :: t =>
      if s =? q1
      then
        match e with
        | event e' =>
            if set_mem string_dec e' Lu
            then set_add s_label_dec (s_event e') (f_out_one_state' s t Lu)
            else f_out_one_state' s t Lu
        | tau => f_out_one_state' s t Lu
        end
     else f_out_one_state' s t Lu
  end.

Definition f_out_one_state (s : state) (p : s_IOLTS) : set s_label :=
  f_out_one_state' s p.(iolts).(sc_lts).(lts).(T) p.(iolts).(L_u).

Fixpoint f_out (ls : set state) (p : s_IOLTS) : set s_label :=
  match ls with
  | []     => []
  | h :: t =>
      if set_mem Nat.eq_dec h p.(Ts)
      then set_add s_label_dec delta (f_out t p)
      else set_union s_label_dec (f_out_one_state h p) (f_out t p)
  end.

Lemma f_out_one_state'_complete:
  forall (l : label) (Lu : set label) (s s': state) (T : list transition),
    In l Lu -> In (s, event l, s') T -> In (s_event l) (f_out_one_state' s T Lu).
Proof.
  intros l Lu s s' T H1 H2. induction T.
  - inversion H2.
  - destruct H2 as [H2 | H2]; simpl; destruct a, p.
    + destruct t; try inversion H2. subst. rewrite Nat.eqb_refl.
      eapply set_mem_correct2 in H1. rewrite H1. apply set_add_intro. left.
      reflexivity.
    + destruct (s =? s1); destruct t; try destruct (set_mem string_dec l0 Lu);
      try (apply set_add_intro; right); apply IHT; apply H2.
Qed.

Lemma f_out_one_state'_correct:
  forall (l : label) (Lu : set label) (s : state) (T : list transition),
    In (s_event l) (f_out_one_state' s T Lu) ->
    exists (s' : state), In l Lu /\ In (s, event l, s') T.
Proof.
  intros l Lu s T H. induction T.
  - inversion H.
  - simpl in H. destruct a, p. destruct (s =? s1) eqn:Eq_s; destruct t.
    + destruct (set_mem string_dec l0 Lu) eqn:H'.
       * apply set_add_iff in H. destruct H as [H|H].
         -- inversion H. apply set_mem_correct1 in H'. exists s0.
            split; try apply H'. left. apply Nat.eqb_eq in Eq_s. subst. reflexivity.
         -- apply IHT in H. destruct H as [s' H]. exists s'. destruct H. split; auto.
            right. auto.
       * apply IHT in H; destruct H as [s' H]; exists s'; destruct H; split; auto.
         right; auto.
    + apply IHT in H; destruct H as [s' H]; exists s'; destruct H; split; auto;
      right; auto.
    + apply IHT in H; destruct H as [s' H]; exists s'; destruct H; split; auto;
      right; auto.
    + apply IHT in H; destruct H as [s' H]; exists s'; destruct H; split; auto;
      right; auto.
Qed.

Lemma f_out_one_state'_no_delta:
  forall  (Lu : set label) (s : state) (T : list transition),
    ~ In delta (f_out_one_state' s T Lu).
Proof.
  intros Lu s T. induction T.
  - intros H. inversion H.
  - simpl. destruct a, p. destruct (s =? s1); destruct t; try apply IHT.
    destruct (set_mem string_dec l Lu); try apply IHT. intros H.
    apply set_add_iff in H. destruct H as [H | H]; try inversion H.
    apply IHT. apply H.
Qed.

Lemma ind_out_equiv_f_out:
  forall (Q : set state) (so : set s_label) (p : s_IOLTS),
    ind_out Q so p <-> so [=] f_out Q p.
Proof.
  intros.
  split.
  - intros H. unfold Equiv. intros x. split.
    + intros H'. unfold ind_out in H. destruct H as [H _].
      apply H in H'. destruct H' as [s [so' [H'_1 [H'_2 H'_3]]]].
      clear H. induction Q.
      * inversion H'_1.
      * destruct H'_1 as [H'_1 | H'_1]; subst.
        -- simpl. inversion H'_2; subst.
           ++ eapply set_mem_correct2 in H. rewrite H.
              destruct H'_3 as [H'_3 | H'_3]; inversion H'_3.
              apply set_add_intro. left. reflexivity.
           ++ eapply set_mem_complete2 in H. rewrite H. apply set_union_intro1.
              destruct x; [|apply H0 in H'_3; inversion H'_3 ].
              apply H1 in H'_3. unfold f_out_one_state.
              destruct H'_3 as [s' [H'_3_1 H'_3_2]]. inversion H'_3_2.
              apply f_out_one_state'_complete with (s' := s'); auto.
        -- simpl. destruct (set_mem Nat.eq_dec a (Ts p)).
           ++ apply set_add_intro. right. apply IHQ. apply H'_1.
           ++ apply set_union_intro2. apply IHQ. apply H'_1.
    + intros H'. unfold ind_out in H. destruct H as [_ H].
      induction Q; try inversion H'. simpl in H'.
      assert (H_aux : In a (a :: Q)). { left. reflexivity. } apply H in H_aux.
      destruct H_aux as [so' [H_1 H_2]].
      destruct (set_mem Nat.eq_dec a (Ts p)) eqn:H''.
      * apply set_add_iff in H'. destruct H' as [H' | H'].
        -- subst.
           apply set_mem_correct1 in H''. inversion H_1; subst.
           ++ apply H_2. left. reflexivity.
           ++ apply H0 in H''. inversion H''.
        -- apply IHQ.
           ++ intros s H'''. apply H. right. apply H'''.
           ++ apply H'.
      * apply set_union_iff in H'. destruct H' as [H' | H'].
        -- destruct x; [| apply f_out_one_state'_no_delta in H'; inversion H'].
           inversion H_1; subst.
           ++ apply set_mem_complete1 in H''. apply H'' in H0. inversion H0.
           ++ apply H_2. apply H2. apply f_out_one_state'_correct in H'.
              destruct H' as [s' H']. exists s'. destruct H' as [H'_1 H'_2].
              split; auto. apply transition_r1. apply H'_2.
        -- apply IHQ.
           ++ intros s H'''. apply H. right. apply H'''.
           ++ apply H'.
  - intros H. unfold ind_out. split.
    + intros x H'. apply H in H'. clear H. induction Q; [inversion H'|].
      simpl in H'. destruct (set_mem Nat.eq_dec a (Ts p)) eqn:H.
      * apply set_add_iff in H'. destruct H' as [H'|H'].
        -- subst. exists a, [delta]. repeat split; try (left; reflexivity).
           apply out_one_state_r1. apply set_mem_correct1 in H. apply H.
        -- apply IHQ in H'. destruct H' as [s [so' H']]. exists s, so'.
           destruct H' as [H'_1 [H'_2 H'_3]]. repeat split; auto. right. auto.
      * apply set_union_iff in H'. destruct H' as [H'|H'].
        -- exists a, (f_out_one_state a p).
           repeat split; try (left; reflexivity); auto.
           apply out_one_state_r2;
           [apply set_mem_complete1 in H; apply H |
            apply f_out_one_state'_no_delta |].
           intros l. split.
           ++ intros H''. apply f_out_one_state'_correct in H''.
              destruct H'' as [s' H'']. exists s'. destruct H'' as [H''_1 H''_2].
              split; auto. apply transition_r1. apply H''_2.
           ++ intros H''. destruct H'' as [s' [H''_1 H''_2]]. inversion H''_2.
              subst. eapply f_out_one_state'_complete; auto. apply H2.
        -- apply IHQ in H'. destruct H' as [s [so' H']]. exists s, so'.
           destruct H' as [H'_1 [H'_2 H'_3]]. repeat split; auto. right. auto.
    + intros s H'.
      assert (H'': forall x, In x (f_out Q p) -> In x so). { apply H. }
      clear H. induction Q; [inversion H'|]. destruct H' as [H'|H'].
      * subst. simpl in H''. destruct (set_mem Nat.eq_dec s (Ts p)) eqn:H.
        -- exists [delta]. split.
           ++ apply out_one_state_r1. apply set_mem_correct1 in H. apply H.
           ++ intros o H'. apply H''. destruct H' as [H'|H']; try inversion H'.
              apply set_add_iff. left. reflexivity.
        -- exists (f_out_one_state s p). split.
           ++ apply out_one_state_r2;
             [apply set_mem_complete1 in H; apply H | apply f_out_one_state'_no_delta |].
             intros l. split.
              ** intros H'. apply f_out_one_state'_correct in H'.  destruct H' as [s' H'].
              exists s'. destruct H' as [H'_1 H'_2]. split; auto.
              apply transition_r1. apply H'_2.
              ** intros H'. destruct H' as [s' [H'_1 H'_2]]. inversion H'_2.
                 subst. eapply f_out_one_state'_complete; auto. apply H2.
           ++ intros o H'. apply H''. apply set_union_iff. left. apply H'.
      * apply IHQ; auto. intros l H. apply H''. simpl.
        destruct (set_mem Nat.eq_dec a (Ts p)).
        -- apply set_add_iff. right. apply H.
        -- apply set_union_iff. right. apply H.
Qed.

Definition ind_s_after (s : state) (ll : list s_label) (ls : list state)
    (p : s_IOLTS) : Prop :=
  forall (a : state), ind_s_seq_reachability s ll a p <-> In a ls.

Definition ind_s_after_IOLTS (ll : list s_label) (ls : list state)
    (p : s_IOLTS) : Prop :=
  ind_s_after p.(iolts).(sc_lts).(lts).(q0) ll ls p.

Definition ind_ioco (i : IOTS) (s : IOLTS) : Prop :=
  forall (Qi Qs : set state) (t : list s_label) (out_i out_s : set s_label),
    ind_s_traces_LTS t (create_s_IOLTS s) ->
    ind_s_after_IOLTS t Qi (create_s_IOLTS i.(embedded_iolts)) ->
    ind_s_after_IOLTS t Qs (create_s_IOLTS s) ->
    ind_out Qi out_i (create_s_IOLTS i.(embedded_iolts)) ->
    ind_out Qs out_s (create_s_IOLTS s) ->
    incl out_i out_s.
Local Open Scope bool_scope.

Fixpoint f_after_one_s_label' (s : state) (l : s_label)
  (lt : list transition) (Ts : set state) : set state :=
  match l with
  | delta => if set_mem Nat.eq_dec s Ts
             then [s]
             else []
  | s_event e =>
      match lt with
      | []               =>  []
      | (a, l', b) :: t  =>  if (s =? a) && (b_transition_label_dec (event e) l')
                             then set_add Nat.eq_dec b (f_after_one_s_label' s l t Ts)
                             else f_after_one_s_label' s l t Ts
      end
  end.
Local Close Scope bool_scope.

Fixpoint f_after_one_s_label (ls : set state) (l : s_label)
    (lt : list transition) (Ts: set state): set state :=
  match ls with
  | []     => []
  | h :: t =>
      set_union
        Nat.eq_dec
        (f_after_one_s_label' h l lt Ts)
        (f_after_one_s_label t l lt Ts)
  end.

Fixpoint f_after_IOLTS' (ls : set state) (ll : list s_label) (p : s_IOLTS)
    : set state :=
  match ll with
  | []       => all_reachable_by_tau ls p.(iolts).(sc_lts).(lts)
  | h :: ll' =>
    let ls_tau := all_reachable_by_tau ls p.(iolts).(sc_lts).(lts) in
    let ls_after_one_step :=
      f_after_one_s_label ls_tau h p.(iolts).(sc_lts).(lts).(T) p.(Ts) in
      f_after_IOLTS' ls_after_one_step ll' p
  end.

Definition f_after_single_state_IOLTS (s : state) (ll : list s_label)
    (p : s_IOLTS) : set state :=
  f_after_IOLTS' [s] ll p.

Definition f_after_IOLTS (ll : list s_label) (p : s_IOLTS) : set state :=
  f_after_single_state_IOLTS p.(iolts).(sc_lts).(lts).(q0) ll p.

Lemma ind_after_IOLTS_equiv_f_after_IOLTS:
  forall (ll : list s_label) (ls : set state) (p : s_IOLTS),
    ind_s_after_IOLTS ll ls p <-> ls [=] f_after_IOLTS ll p.
Proof.
Admitted.

Definition f_ioco (i : IOTS) (s : IOLTS) : Prop :=
  forall (t : list s_label),
    ind_s_traces_LTS t (create_s_IOLTS s) ->
      incl (f_out
            (f_after_IOLTS t (create_s_IOLTS i.(embedded_iolts)))
            (create_s_IOLTS i.(embedded_iolts)))
           (f_out (f_after_IOLTS t (create_s_IOLTS s)) (create_s_IOLTS s)).


Require Import
        CertifiedExtraction.Core
        CertifiedExtraction.FacadeNotations
        CertifiedExtraction.PropertiesOfTelescopes
        CertifiedExtraction.ExtendedPropertiesOfTelescopes
        CertifiedExtraction.ExtendedLemmas.

Fixpoint TelAppend {av} (t1 t2: Telescope av) :=
  match t1 with
  | Nil => t2
  | Cons T key val tail => Cons (T := T) key val (fun v => TelAppend (tail v) t2)
  end.

Lemma TelAppend_Nil {av} :
  forall t: Telescope av,
    TelStrongEq (TelAppend t Nil) t.
Proof.
  induction t; simpl.
  + reflexivity.
  + econstructor; eauto with typeclass_instances.
Qed.

Lemma TelEq_TelAppend_Cons_Second {av A B}:
  forall {H : FacadeWrapper (Value av) B} (t1: Telescope av) t2 k (v : Comp A) ext,
    TelEq ext
          ([[ k ~~> v as vv]] :: TelAppend t1 (t2 vv))
          (TelAppend t1 ([[ k ~~> v as vv]] :: (t2 vv))).
Proof.
  intros.
  induction t1; simpl.
  + reflexivity.
  + rewrite TelEq_swap.
    setoid_rewrite H0.
    reflexivity.
Qed.

Add Parametric Morphism {av} : (@TelAppend av)
    with signature ((TelStrongEq) ==> (TelStrongEq) ==> (TelStrongEq))
      as TelAppend_TelStrongEq_morphism.
Proof.
  induction 1; simpl.
  + eauto with typeclass_instances.
  + intros.
    econstructor; eauto.
Qed.

Add Parametric Morphism {av} ext : (@TelAppend av)
    with signature (TelStrongEq ==> (TelEq ext) ==> (TelEq ext))
      as TelAppend_TelStrongEq_TelEq_morphism.
Proof.
  intros.
  rewrite H; clear H.
  induction y; simpl; intros.
  + assumption.
  + apply Cons_TelEq_pointwise_morphism; red; eauto.
Qed.

Add Parametric Morphism {av} ext : (@TelAppend av)
    with signature (TelEq ext ==> TelEq ext ==> (TelEq ext))
      as TelAppend_TelEq_morphism.
Proof.
  intros.
  rewrite H0; clear H0.
  induction y0.
  + rewrite !TelAppend_Nil; assumption.
  + setoid_rewrite <- TelEq_TelAppend_Cons_Second.
    setoid_rewrite H0.
    reflexivity.
Qed.

Ltac standalone_tail tail :=
  (* Recurse down the TAIL of telescope (of type (a: A) → Telescope) to find the
     first subtelescope that doesn't depend on ‘a’. *)
  lazymatch tail with (* This is a really cute piece of code *)
  | (fun a => Cons _ _ (fun _ => ?tail)) => constr:(tail)
  | (fun a => Cons _ _ (fun _ => @?tail a)) => standalone_tail tail
  end.

Ltac function_surrounding_standalone_tail tail :=
  (* Recurse down the TAIL of telescope (of type (a: A) → Telescope) to find the
     first subtelescope that doesn't depend on ‘a’, and construct a function
     plugging an arbitrary argument instead of that subtelescope. *)
  lazymatch tail with
  | (fun a: ?A => Cons ?k ?v (fun _ => ?tail)) =>
    let _t := constr:(tail) in (* Fails if ‘tail’ depends on a *)
    constr:(fun plug => fun a: A => (Cons k v (fun _ => plug)))
  | (fun a: ?A => Cons ?k ?v (fun _ => @?tail a)) =>
    let fn := function_surrounding_standalone_tail tail in
    eval cbv beta in (fun plug => fun a: A => (Cons k v (fun _ => fn plug a)))
  end.

Ltac split_tail_of_telescope tel :=
  (* Split the tail TEL (a function) into two parts, using ‘standalone_tail’ and
     ‘function_surrounding_standalone_tail’. *)
  match tel with
  | Cons ?k ?v ?tail =>
    let tl := standalone_tail tail in
    let tenvF := function_surrounding_standalone_tail tail in
    (* let tenvF := (eval cbv beta in (fun plug => Cons k v (tenvF plug))) in *)
    constr:(tenvF, tl)
  end.

Ltac make_TelAppend tel :=
  (** Change the tail of TEL into a ‘TelAppend’ of two parts: one depending on
      the head value of tail, and the other independent of it. *)
  match tel with
  | Cons ?k ?v ?tail =>
    let appTl := standalone_tail tail in
    let tenvF := function_surrounding_standalone_tail tail in
    let appHead := (eval cbv beta in (Cons k v (tenvF Nil))) in
    constr:(TelAppend appHead appTl)
  end.


Set Warnings "-notation-overridden,-parsing".
Add LoadPath "/Users/jikl/demos/coq/software-foundation-exercise/logic_foundation" as LF.
From LF Require Import Maps.
From PLF Require Import Types.
From PLF Require Import SmallStep.
From PLF Require Import Stlc.
From Coq Require Import Strings.String.

Module STLCExtended.

  Inductive ty : Type :=
  | Arrow : ty -> ty -> ty
  | Nat : ty
  | Sum : ty -> ty -> ty
  | List : ty -> ty
  | Unit : ty
  | Prod : ty -> ty -> ty.

  Inductive tm : Type :=
  (* pure STLC *)
  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> ty -> tm -> tm
  (* numbers *)
  | const : nat -> tm
  | scc : tm -> tm
  | prd : tm -> tm
  | mlt : tm -> tm -> tm
  | test0 : tm -> tm -> tm -> tm
  (* sums *)
  | tinl : ty -> tm -> tm
  | tinr : ty -> tm -> tm
  | tcase : tm -> string -> tm -> string -> tm -> tm
           (* i.e., case t0 of inl x1 => t1 | inr x2 => t2*)
  (* lists *)
  | tnil : ty -> tm
  | tcons : tm -> tm -> tm
  | tlcase : tm -> tm -> string -> string -> tm -> tm
           (* i.e., lcase t1 of | nil => t2 | x :: y => t3*)
  (* unit *)
  | unit : tm
  (* pairs *)
  | tpair : tm -> tm -> tm
  | tfst : tm -> tm
  | tsnd : tm -> tm
  (* let *)
  | tlet : string -> tm -> tm -> tm
          (* i.e., let x = t1 in t2*)
  (* fix *)
  | tfix : tm -> tm.

  (* Substitution *)
  Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
    match t with
    | var y =>
      if eqb_string x y then s else t
    | abs y T t1 =>
      abs y T (if eqb_string x y then t1 else (subst x s t1))
    | app t1 t2 =>
      app (subst x s t1) (subst x s t2)
    | const n =>
      const n
    | scc t1 =>
      scc (subst x s t1)
    | prd t1 =>
      prd (subst x s t1)
    | mlt t1 t2 =>
      mlt (subst x s t1) (subst x s t2)
    | test0 t1 t2 t3 =>
      test0 (subst x s t1) (subst x s t2) (subst x s t3)
    | tinl T t1 =>
      tinl T (subst x s t1)
    | tinr T t1 =>
      tinr T (subst x s t1)
    | tcase t0 y1 t1 y2 t2 =>
      tcase (subst x s t0)
            y1 (if eqb_string x y1 then t1 else (subst x s t1))
            y2 (if eqb_string x y2 then t2 else (subst x s t2))
    | tnil T =>
      tnil T
    | tcons t1 t2 =>
      tcons (subst x s t1) (subst x s t2)
    | tlcase t1 t2 y1 y2 t3 =>
      tlcase (subst x s t1) (subst x s t2) y1 y2
             (if eqb_string x y1 then
                t3
              else if eqb_string x y2 then t3
                   else (subst x s t3))
    | unit => unit
    | tpair t1 t2 =>
      tpair (subst x s t1) (subst x s t2)
    | tfst t1 =>
      tfst (subst x s t1)
    | tsnd t1 =>
      tsnd (subst x s t1)
    | tlet y t1 t2 =>
      if eqb_string x y then tlet y (subst x s t1) t2
      else tlet y (subst x s t1) (subst x s t2)
    | tfix tf =>
      tfix (subst x s tf)
    end.

  Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

  Inductive value : tm -> Prop :=
  (* In pure STLC, function abstractions are values: *)
  | v_abs : forall x T11 t12,
      value (abs x T11 t12)
  (* Numbers are values: *)
  | v_nat : forall n1,
      value (const n1)
  (* A tagged value is a value:  *)
  | v_inl : forall v T,
      value v ->
      value (tinl T v)
  | v_inr : forall v T,
      value v ->
      value (tinr T v)
  (* A list is a value iff its head and tail are values: *)
  | v_lnil : forall T, value (tnil T)
  | v_lcons : forall v1 vl,
      value v1 ->
      value vl ->
      value (tcons v1 vl)
  (* A unit is always a value *)
  | v_unit : value unit
  (* A pair is a value if both components are: *)
  | v_pair : forall v1 v2,
      value v1 ->
      value v2 ->
      value (tpair v1 v2).

  Hint Constructors value : db.

  Reserved Notation "t1 '-->' t2" (at level 40).

  Inductive step : tm -> tm -> Prop :=
  (* pure STLC *)
  | ST_AppAbs : forall x T11 t12 v2,
         value v2 ->
         (app (abs x T11 t12) v2) --> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         (app t1 t2) --> (app t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         (app v1 t2) --> (app v1 t2')
  (* numbers *)
  | ST_Succ1 : forall t1 t1',
       t1 --> t1' ->
       (scc t1) --> (scc t1')
  | ST_SuccNat : forall n1,
       (scc (const n1)) --> (const (S n1))
  | ST_Pred : forall t1 t1',
       t1 --> t1' ->
       (prd t1) --> (prd t1')
  | ST_PredNat : forall n1,
       (prd (const n1)) --> (const (pred n1))
  | ST_Mult1 : forall t1 t1' t2,
       t1 --> t1' ->
       (mlt t1 t2) --> (mlt t1' t2)
  | ST_Mult2 : forall v1 t2 t2',
       value v1 ->
       t2 --> t2' ->
       (mlt v1 t2) --> (mlt v1 t2')
  | ST_Mulconsts : forall n1 n2,
       (mlt (const n1) (const n2)) --> (const (mult n1 n2))
  | ST_Test01 : forall t1 t1' t2 t3,
       t1 --> t1' ->
       (test0 t1 t2 t3) --> (test0 t1' t2 t3)
  | ST_Test0Zero : forall t2 t3,
       (test0 (const 0) t2 t3) --> t2
  | ST_Test0Nonzero : forall n t2 t3,
       (test0 (const (S n)) t2 t3) --> t3
  (* sums *)
  | ST_Inl : forall t1 t1' T,
        t1 --> t1' ->
        (tinl T t1) --> (tinl T t1')
  | ST_Inr : forall t1 t1' T,
        t1 --> t1' ->
        (tinr T t1) --> (tinr T t1')
  | ST_Case : forall t0 t0' x1 t1 x2 t2,
        t0 --> t0' ->
        (tcase t0 x1 t1 x2 t2) --> (tcase t0' x1 t1 x2 t2)
  | ST_CaseInl : forall v0 x1 t1 x2 t2 T,
        value v0 ->
        (tcase (tinl T v0) x1 t1 x2 t2) --> [x1:=v0]t1
  | ST_CaseInr : forall v0 x1 t1 x2 t2 T,
        value v0 ->
        (tcase (tinr T v0) x1 t1 x2 t2) --> [x2:=v0]t2
  (* lists *)
  | ST_Cons1 : forall t1 t1' t2,
       t1 --> t1' ->
       (tcons t1 t2) --> (tcons t1' t2)
  | ST_Cons2 : forall v1 t2 t2',
       value v1 ->
       t2 --> t2' ->
       (tcons v1 t2) --> (tcons v1 t2')
  | ST_Lcase1 : forall t1 t1' t2 x1 x2 t3,
       t1 --> t1' ->
       (tlcase t1 t2 x1 x2 t3) --> (tlcase t1' t2 x1 x2 t3)
  | ST_LcaseNil : forall T t2 x1 x2 t3,
       (tlcase (tnil T) t2 x1 x2 t3) --> t2
  | ST_LcaseCons : forall v1 vl t2 x1 x2 t3,
       value v1 ->
       value vl ->
       (tlcase (tcons v1 vl) t2 x1 x2 t3)
         --> (subst x2 vl (subst x1 v1 t3))
  | ST_Pair1 : forall t1 t1' t2,
      t1 --> t1' ->
      (tpair t1 t2) --> (tpair t1' t2)
  | ST_Pair2 : forall v1 t2 t2',
      value v1 ->
      t2 --> t2' ->
      (tpair v1 t2) --> (tpair v1 t2')
  | ST_Fst : forall t1 t1',
      t1 --> t1' ->
      (tfst t1) --> (tfst t1')
  | ST_FstPair : forall v1 v2,
      value v1 ->
      value v2 ->
      (tfst (tpair v1 v2)) --> v1
  | ST_Snd : forall t1 t1',
      t1 --> t1' ->
      (tsnd t1) --> (tsnd t1')
  | ST_SndPair : forall v1 v2,
      value v1 ->
      value v2 ->
      (tsnd (tpair v1 v2)) --> v2
  | ST_Let1 : forall x t1 t1' t2,
      t1 --> t1' ->
      (tlet x t1 t2) --> (tlet x t1' t2)
  | ST_LetValue : forall x v1 t2,
      value v1 ->
      (tlet x v1 t2) --> [x := v1]t2
  | ST_Fix1 : forall t1 t1',
      t1 --> t1' ->
      tfix t1 --> tfix t1'
  | ST_FixAbs : forall xf T1 t2,
      tfix (abs xf T1 t2) --> [xf:=tfix (abs xf T1 t2)] t2
  where "t1 '-->' t2" := (step t1 t2).

  Notation multistep := (multi step).

  Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

  Hint Constructors step : db.

  Definition context := partial_map ty.

  Reserved Notation "Gamma '|-' t '?' T" (at level 40).

  Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- (var x) ? T
  | T_Abs : forall Gamma x T11 T12 t12,
      (x |-> T11; Gamma) |- t12 ? T12 ->
      Gamma |- (abs x T11 t12) ? (Arrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 ? (Arrow T1 T2) ->
      Gamma |- t2 ? T1 ->
      Gamma |- (app t1 t2) ? T2
  |T_Nat : forall Gamma n1,
      Gamma |- (const n1) ? Nat
  | T_Succ : forall Gamma t1,
      Gamma |- t1 ? Nat ->
      Gamma |- (scc t1) ? Nat
  | T_Pred : forall Gamma t1,
      Gamma |- t1 ? Nat ->
      Gamma |- (prd t1) ? Nat
  | T_Mult : forall Gamma t1 t2,
      Gamma |- t1 ? Nat ->
      Gamma |- t2 ? Nat ->
      Gamma |- (mlt t1 t2) ? Nat
  | T_Test0 : forall Gamma t1 t2 t3 T1,
      Gamma |- t1 ? Nat ->
      Gamma |- t2 ? T1 ->
      Gamma |- t3 ? T1 ->
      Gamma |- (test0 t1 t2 t3) ? T1
  | T_Inl : forall Gamma t1 T1 T2,
      Gamma |- t1 ? T1 ->
      Gamma |- (tinl T2 t1) ? (Sum T1 T2)
  | T_Inr : forall Gamma t2 T1 T2,
      Gamma |- t2 ? T2 ->
      Gamma |- (tinr T1 t2) ? (Sum T1 T2)
  | T_Case : forall Gamma t0 x1 T1 t1 x2 T2 t2 T,
      Gamma |- t0 ? (Sum T1 T2) ->
      (x1 |-> T1; Gamma) |- t1 ? T ->
      (x2 |-> T2; Gamma) |- t2 ? T ->
      Gamma |- (tcase t0 x1 t1 x2 t2) ? T
  | T_Nil : forall Gamma T,
      Gamma |- (tnil T) ? (List T)
  | T_Cons : forall Gamma t1 t2 T1,
      Gamma |- t1 ? T1 ->
      Gamma |- t2 ? (List T1) ->
      Gamma |- (tcons t1 t2) ? (List T1)
  | T_Lcase : forall Gamma t1 T1 t2 x1 x2 t3 T2,
      Gamma |- t1 ? (List T1) ->
      Gamma |- t2 ? T2 ->
      (x1 |-> T1; x2 |-> (List T1); Gamma) |- t3 ? T2 ->
      Gamma |- (tlcase t1 t2 x1 x2 t3) ? T2
  | T_Unit : forall Gamma,
      Gamma |- unit ? Unit
  | T_Pair : forall Gamma t1 T1 t2 T2,
      Gamma |- t1 ? T1 ->
      Gamma |- t2 ? T2 ->
      Gamma |- (tpair t1 t2) ? (Prod T1 T2)
  | T_Fst : forall Gamma t T1 T2,
      Gamma |- t ? (Prod T1 T2) ->
      Gamma |- (tfst t) ? T1
  | T_Snd : forall Gamma t T1 T2,
      Gamma |- t ? (Prod T1 T2) ->
      Gamma |- (tsnd t) ? T2
  | T_Let : forall Gamma x t1 T1 t2 T2,
      Gamma |- t1 ? T1 ->
      (x |-> T1; Gamma) |- t2 ? T2 ->
      Gamma |- tlet x t1 t2 ? T2
  | T_Fix : forall Gamma t1 T1,
      Gamma |- t1 ? (Arrow T1 T1) ->
      Gamma |- (tfix t1) ? T1
  where "Gamma '|-' t '?' T" := (has_type Gamma t T).

  Hint Constructors has_type : db.

  Module Examples.

    Open Scope string_scope.
    Notation x := "x".
    Notation y := "y".
    Notation a := "a".
    Notation f := "f".
    Notation g := "g".
    Notation l := "l".
    Notation k := "k".
    Notation i1 := "i1".
    Notation i2 := "i2".
    Notation processSum := "processSum".
    Notation n := "n".
    Notation eq := "eq".
    Notation m := "m".
    Notation evenodd := "evenodd".
    Notation even := "even".
    Notation odd := "odd".
    Notation eo := "eo".

    Hint Extern 2 (has_type _ (app _ _) _) => eapply T_App; auto : db.
    Hint Extern 2 (has_type _ (tlcase _ _ _ _) _) => eapply T_Lcase; auto : db.
    Hint Extern 2 (_ = _) => compute; reflexivity : db.

    Module Numtest.

      Definition test :=
        test0
          (prd
             (scc
                (prd
                   (mlt
                      (const 2)
                      (const 0)))))
          (const 5)
          (const 6).

      Example typechecks :
        empty |- test ? Nat.
      Proof.
        unfold test.
        auto 10 with db.
      Qed.

      Example numtest_reduces :
        test -->* const 5.
      Proof.
        unfold test.
        normalize.
      Qed.

    End Numtest.

    Module Prodtest.

      Definition test :=
        tsnd
          (tfst
             (tpair
                (tpair
                   (const 5)
                   (const 6))
                (const 7))).

      Example typechecks :
        empty |- test ? Nat.
      Proof.
        unfold test.
        eapply T_Snd.
        eapply T_Fst.
        apply T_Pair.
        - apply T_Pair.
          + apply T_Nat.
          + apply T_Nat.
        - apply T_Nat.
      Qed.

      Example reduces :
        test -->* const 6.
      Proof. unfold test. normalize. Qed.

    End Prodtest.

    Module LetTest.

      Definition test :=
        tlet
          x
          (prd (const 6))
          (scc (var x)).

      Example typechecks :
        empty |- test ? Nat.
      Proof.
        unfold test.
        eapply T_Let.
        - auto with db.
        - auto with db.
      Qed.

      Example reduces :
        test -->* const 6.
      Proof.
        unfold test.
        eapply multi_step.
        - apply ST_Let1. apply ST_PredNat.
        - simpl.
          eapply multi_step.
          + apply ST_LetValue. apply v_nat.
          + simpl. eapply multi_step.
            * apply ST_SuccNat.
            * apply multi_refl.
      Qed.

    End LetTest.

    Module Sumtest1.

      Definition test :=
        tcase (tinl Nat (const 5))
              x (var x)
              y (var y).

      Example typechecks :
        empty |- test ? Nat.
      Proof.
        unfold test.
        eapply T_Case.
        - apply T_Inl. apply T_Nat.
        - apply T_Var. rewrite update_eq. reflexivity.
        - apply T_Var. rewrite update_eq. reflexivity.
      Qed.

      Example reduces:
        test -->* (const 5).
      Proof.
        unfold test.
        eapply multi_step.
        - eapply ST_CaseInl. apply v_nat.
        - simpl. apply multi_refl.
      Qed.

    End Sumtest1.

    Module Sumtest2.

      Definition test :=
        tlet
          processSum
          (abs x (Sum Nat Nat)
               (tcase (var x)
                      n (var n)
                      n (test0 (var n) (const 1) (const 0))))
          (tpair
             (app (var processSum) (tinl Nat (const 5)))
             (app (var processSum) (tinr Nat (const 5)))).

      Example typechecks :
        empty |- test ? (Prod Nat Nat).
      Proof.
        unfold test.
        eapply T_Let.
        - apply T_Abs. eapply T_Case.
          + apply T_Var. rewrite update_eq. reflexivity.
          + apply T_Var. rewrite update_eq. reflexivity.
          + apply T_Test0.
            * apply T_Var. rewrite update_eq. reflexivity.
            * apply T_Nat.
            * apply T_Nat.
        - apply T_Pair.
          + eapply T_App.
            * apply T_Var. rewrite update_eq. reflexivity.
            * apply T_Inl. apply T_Nat.
          + eapply T_App.
            * apply T_Var. rewrite update_eq. reflexivity.
            * apply T_Inr. apply T_Nat.
      Qed.

      Example reduces :
        test -->* (tpair (const 5) (const 0)).
      Proof.
        unfold test. normalize.
      Qed.

    End Sumtest2.

    Module ListTest.

      Definition test :=
        tlet l
             (tcons (const 5) (tcons (const 6) (tnil Nat)))
             (tlcase (var l)
                     (const 0)
                     x y (mlt (var x) (var x))).

      Example typechecks :
        empty |- test ? Nat.
      Proof.
        unfold test.
        eapply T_Let.
        - apply T_Cons.
          + apply T_Nat.
          + apply T_Cons.
            * apply T_Nat.
            * apply T_Nil.
        - eapply T_Lcase.
          + apply T_Var. rewrite update_eq. reflexivity.
          + apply T_Nat.
          + apply T_Mult; apply T_Var; rewrite update_eq; reflexivity.
      Qed.

      Example reduces :
        test -->* (const 25).
      Proof.
        unfold test.
        eapply multi_step.
        - apply ST_LetValue. apply v_lcons.
          + apply v_nat.
          + apply v_lcons.
            * apply v_nat.
            * apply v_lnil.
        - simpl. eapply multi_step.
          + apply ST_LcaseCons.
            * apply v_nat.
            * apply v_lcons.
              { apply v_nat. }
              { apply v_lnil. }
          + simpl. eapply multi_step.
            * apply ST_Mulconsts.
            * simpl. apply multi_refl.
      Qed.

    End ListTest.

    Module FixTest1.

      Definition fact :=
        tfix
          (abs f (Arrow Nat Nat)
               (abs a Nat
                    (test0
                       (var a)
                       (const 1)
                       (mlt
                          (var a)
                          (app (var f) (prd (var a))))))).

      Example typechecks :
        empty |- fact ? (Arrow Nat Nat).
      Proof.
        unfold fact.
        apply T_Fix. apply T_Abs. apply T_Abs.
        apply T_Test0.
        - apply T_Var. rewrite update_eq. reflexivity.
        - apply T_Nat.
        - apply T_Mult.
          + apply T_Var. rewrite update_eq. reflexivity.
          + eapply T_App.
            * apply T_Var. rewrite update_neq.
              { rewrite update_eq. reflexivity. }
              { intro H. inversion H. }
            * apply T_Pred. apply T_Var. rewrite update_eq. reflexivity.
      Qed.

      Example reduces :
        (app fact (const 4)) -->* (const 24).
      Proof.
        unfold fact.
        eapply multi_step.
        - apply ST_App1. apply ST_FixAbs.
        - simpl. eapply multi_step.
          + apply ST_AppAbs. apply v_nat.
          + simpl. eapply multi_step.
            * apply ST_Test0Nonzero.
            * eapply multi_step.
              { apply ST_Mult2.
                { apply v_nat. }
                { apply ST_App1. apply ST_FixAbs. }
              }
              { simpl. eapply multi_step.
                { apply ST_Mult2.
                  { apply v_nat. }
                  { apply ST_App2.
                    { apply v_abs. }
                    { apply ST_PredNat. }
                  }
                }
                { eapply multi_step.
                  { apply ST_Mult2.
                    { apply v_nat. }
                    { simpl. apply ST_AppAbs. apply v_nat. }
                  }
                  { simpl. eapply multi_step.
                    { apply ST_Mult2.
                      { apply v_nat. }
                      { apply ST_Test0Nonzero. }
                    }
                    { eapply multi_step.
                      { apply ST_Mult2.
                        { apply v_nat. }
                        { apply ST_Mult2.
                          { apply v_nat. }
                          { apply ST_App1. apply ST_FixAbs. }
                        }
                      }
                      { eapply multi_step.
                        { simpl. apply ST_Mult2.
                          { apply v_nat. }
                          { apply ST_Mult2.
                            { apply v_nat. }
                            { apply ST_App2.
                              { apply v_abs. }
                              { apply ST_PredNat. }
                            }
                          }
                        }
                        { simpl. eapply multi_step.
                          { apply ST_Mult2.
                            { apply v_nat. }
                            { apply ST_Mult2.
                              { apply v_nat. }
                              { apply ST_AppAbs. apply v_nat. }
                            }
                          }
                          { simpl. eapply multi_step.
                            { apply ST_Mult2.
                              { apply v_nat. }
                              { apply ST_Mult2.
                                { apply v_nat. }
                                { apply ST_Test0Nonzero. }
                              }
                            }
                            { eapply multi_step.
                              { apply ST_Mult2.
                                { apply v_nat. }
                                { apply ST_Mult2.
                                  { apply v_nat. }
                                  { apply ST_Mult2.
                                    { apply v_nat. }
                                    { apply ST_App1. apply ST_FixAbs. }
                                  }
                                }
                              }
                              { eapply multi_step.
                                { apply ST_Mult2.
                                  { apply v_nat. }
                                  { apply ST_Mult2.
                                    { apply v_nat. }
                                    { apply ST_Mult2.
                                      { apply v_nat. }
                                      { simpl. apply ST_App2.
                                        { apply v_abs. }
                                        { apply ST_PredNat. }
                                      }
                                    }
                                  }
                                }
                                { eapply multi_step.
                                  { apply ST_Mult2.
                                    { apply v_nat. }
                                    { apply ST_Mult2.
                                      { apply v_nat. }
                                      { apply ST_Mult2.
                                        { apply v_nat. }
                                        { apply ST_AppAbs. simpl. apply v_nat. }
                                      }
                                    }
                                  }
                                  { simpl. eapply multi_step.
                                    { apply ST_Mult2.
                                      { apply v_nat. }
                                      { apply ST_Mult2.
                                        { apply v_nat. }
                                        { apply ST_Mult2.
                                          { apply v_nat. }
                                          { apply ST_Test0Nonzero. }
                                        }
                                      }
                                    }
                                    { eapply multi_step.
                                      { apply ST_Mult2.
                                        { apply v_nat. }
                                        { apply ST_Mult2.
                                          { apply v_nat. }
                                          { apply ST_Mult2.
                                            { apply v_nat. }
                                            { apply ST_Mult2.
                                              { apply v_nat. }
                                              { apply ST_App1. apply ST_FixAbs. }
                                            }
                                          }
                                        }
                                      }
                                      { simpl. eapply multi_step.
                                        { apply ST_Mult2.
                                          { apply v_nat. }
                                          { apply ST_Mult2.
                                            { apply v_nat. }
                                            { apply ST_Mult2.
                                              { apply v_nat. }
                                              { apply ST_Mult2.
                                                { apply v_nat. }
                                                { apply ST_App2.
                                                  { apply v_abs. }
                                                  { apply ST_PredNat. }
                                                }
                                              }
                                            }
                                          }
                                        }
                                        { eapply multi_step.
                                          { apply ST_Mult2.
                                            { apply v_nat. }
                                            { apply ST_Mult2.
                                              { apply v_nat. }
                                              { apply ST_Mult2.
                                                { apply v_nat. }
                                                { apply ST_Mult2.
                                                  { apply v_nat. }
                                                  { apply ST_AppAbs.  simpl. apply v_nat. }
                                                }
                                              }
                                            }
                                          }
                                          { simpl. eapply multi_step.
                                            { apply ST_Mult2.
                                              { apply v_nat. }
                                              { apply ST_Mult2.
                                                { apply v_nat. }
                                                { apply ST_Mult2.
                                                  { apply v_nat. }
                                                  { apply ST_Mult2.
                                                    { apply v_nat. }
                                                    { apply ST_Test0Zero. }
                                                  }
                                                }
                                              }
                                            }
                                            { eapply multi_step.
                                              { apply ST_Mult2.
                                                { apply v_nat. }
                                                { apply ST_Mult2.
                                                  { apply v_nat. }
                                                  { apply ST_Mult2.
                                                    { apply v_nat. }
                                                    { apply ST_Mulconsts. }
                                                  }
                                                }
                                              }
                                              { simpl. eapply multi_step.
                                                { eapply ST_Mult2.
                                                  { apply v_nat. }
                                                  { apply ST_Mult2.
                                                    { apply v_nat. }
                                                    { apply ST_Mulconsts.
                                                    }
                                                  }
                                                }
                                                { simpl. eapply multi_step.
                                                  { apply ST_Mult2.
                                                    { apply v_nat. }
                                                    { apply ST_Mulconsts. }
                                                  }
                                                  { simpl. eapply multi_step.
                                                    { apply ST_Mulconsts. }
                                                    { simpl. apply multi_refl. }
                                                  }
                                                }
                                              }
                                            }
                                          }
                                        }
                                      }
                                    }
                                  }
                                }
                              }
                            }
                          }
                        }
                      }
                    }
                  }
                }
              }
      Qed.

    End FixTest1.

    Module FixTest2.

      Definition map :=
        abs g (Arrow Nat Nat)
            (tfix
               (abs f (Arrow (List Nat) (List Nat))
                    (abs l (List Nat)
                         (tlcase (var l)
                                 (tnil Nat)
                                 a l (tcons (app (var g) (var a))
                                            (app (var f) (var l))))))).

      Example typechecks :
        empty |- map ? (Arrow (Arrow Nat Nat)
                              (Arrow (List Nat)
                                     (List Nat))).
      Proof.
        unfold map.
        apply T_Abs. apply T_Fix. apply T_Abs. apply T_Abs.
        eapply T_Lcase.
        - apply T_Var. rewrite update_eq. reflexivity.
        - apply T_Nil.
        - apply T_Cons.
          + eapply T_App.
            * apply T_Var. rewrite update_neq. rewrite update_neq.
              rewrite update_neq. rewrite update_neq. rewrite update_eq.
              reflexivity.
              intro H; inversion H.
              intro H; inversion H.
              intro H; inversion H.
              intro H; inversion H.
            * apply T_Var. rewrite update_eq. reflexivity.
          + eapply T_App.
            * apply T_Var. rewrite update_neq. rewrite update_neq.
              rewrite update_neq. rewrite update_eq.
              reflexivity.
              intro H; inversion H.
              intro H; inversion H.
              intro H; inversion H.
            * apply T_Var. rewrite update_neq. rewrite update_eq.
              reflexivity.
              intro H; inversion H.
      Qed.

      Example reduces :
        app (app map (abs a Nat (scc (var a))))
            (tcons (const 1) (tcons (const 2) (tnil Nat)))
            -->* (tcons (const 2) (tcons (const 3) (tnil Nat))).
      Proof.
        unfold map. normalize.
      Qed.

    End FixTest2.

    Module FixTest3.

      Definition equal :=
        tfix
          (abs eq (Arrow Nat (Arrow Nat Nat))
               (abs m Nat
                    (abs n Nat
                         (test0 (var m)
                                (test0 (var n) (const 1) (const 0))
                                (test0 (var n)
                                       (const 0)
                                       (app (app (var eq)
                                                 (prd (var m)))
                                            (prd (var n)))))))).
      Example typechecks :
        empty |- equal ? (Arrow Nat (Arrow Nat Nat)).
      Proof.
        unfold equal.
        apply T_Fix. apply T_Abs. apply T_Abs. apply T_Abs.
        apply T_Test0.
        - apply T_Var. rewrite update_neq. rewrite update_eq.
          reflexivity. intro H; inversion H.
        - apply T_Test0.
          + apply T_Var. rewrite update_eq. reflexivity.
          + apply T_Nat.
          + apply T_Nat.
        - apply T_Test0.
          + apply T_Var. rewrite update_eq. reflexivity.
          + apply T_Nat.
          + eapply T_App.
            * eapply T_App.
              { apply T_Var. rewrite update_neq. rewrite update_neq.
                rewrite update_eq. reflexivity. intro H; inversion H.
                intro H; inversion H.
              }
              { apply T_Pred. apply T_Var. rewrite update_neq.
                rewrite update_eq. reflexivity. intro H; inversion H.
              }
            * apply T_Pred. apply T_Var. rewrite update_eq. reflexivity.
      Qed.

      Example reduces :
        (app (app equal (const 4)) (const 4)) -->* (const 1).
        Proof.
          unfold equal. normalize.
        Qed.

        Example reduces2 :
          (app (app equal (const 4)) (const 5)) -->* (const 0).
        Proof.
          unfold equal. normalize.
        Qed.

    End FixTest3.

    Module FixTest4.

      Definition eotest :=
        tlet evenodd
             (tfix
                (abs eo (Prod (Arrow Nat Nat) (Arrow Nat Nat))
                     (tpair
                        (abs n Nat
                             (test0 (var n)
                                    (const 1)
                                    (app (tsnd (var eo)) (prd (var n)))))
                        (abs n Nat
                             (test0 (var n)
                                    (const 0)
                                    (app (tfst (var eo)) (prd (var n))))))))
             (tlet even (tfst (var evenodd))
                   (tlet odd (tsnd (var evenodd))
                         (tpair
                            (app (var even) (const 3))
                            (app (var even) (const 4))))).

      Example typechecks :
        empty |- eotest ? (Prod Nat Nat).
      Proof.
          unfold eotest.
          eapply T_Let.
          - apply T_Fix. apply T_Abs. apply T_Pair.
            + apply T_Abs. apply T_Test0.
              * apply T_Var. rewrite update_eq. reflexivity.
              * apply T_Nat.
              * eapply T_App.
                { eapply T_Snd. apply T_Var. rewrite update_neq.
                  rewrite update_eq. reflexivity.
                  intro H; inversion H.
                }
                { apply T_Pred. apply T_Var. rewrite update_eq. reflexivity. }
            + apply T_Abs. apply T_Test0.
              * apply T_Var. rewrite update_eq. reflexivity.
              * apply T_Nat.
              * eapply T_App.
                { eapply T_Fst. apply T_Var. rewrite update_neq.
                  rewrite update_eq. reflexivity.
                  intro H; inversion H.
                }
                { apply T_Pred. apply T_Var. rewrite update_eq. auto. }
          - eapply T_Let.
            + eapply T_Fst. apply T_Var. rewrite update_eq. auto.
            + eapply T_Let.
              * eapply T_Snd. apply T_Var. rewrite update_neq.
                rewrite update_eq. auto. intro H; inversion H.
              * apply T_Pair.
                { eapply T_App.
                  { apply T_Var. rewrite update_neq. rewrite update_eq.
                    auto. intro H; inversion H. }
                  { apply T_Nat. }
                }
                { eapply T_App.
                  { apply T_Var. rewrite update_neq. rewrite update_eq.
                    auto. intro H; inversion H.
                  }
                  { apply T_Nat. }
                }
        Qed.

      Example reduces :
        eotest -->* (tpair (const 0) (const 1)).
      Proof.
        unfold eotest. normalize.
      Qed.

    End FixTest4.
  End Examples.

  Theorem progress : forall t T,
      empty |- t ? T ->
      value t \/ exists t', t --> t'.
  Proof.
    intros t.
    induction t.
    - intros T H. inversion H.
      rewrite apply_empty in H2. inversion H2.
    - intros T H. inversion H. subst.
      apply IHt1 in H3. destruct H3.
      + apply IHt2 in H5. destruct H5.
        * right. inversion H0.
          { eexists. apply ST_AppAbs. apply H1. }
          { rewrite <- H2 in H. inversion H. inversion H6. }
          { rewrite <- H3 in H. inversion H. inversion H7. }
          { rewrite <- H3 in H. inversion H. inversion H7. }
          { rewrite <- H2 in H. inversion H. inversion H6. }
          { rewrite <- H4 in H. inversion H. inversion H8. }
          { rewrite <- H2 in H. inversion H. inversion H6. }
          { rewrite <- H4 in H. inversion H. inversion H8. }
        * right. destruct H1. eexists.
          apply (ST_App2 _ _ _ H0 H1).
      + destruct H0. right. eexists. apply (ST_App1 _ _ _ H0).
    - intros T H. left. apply v_abs.
    - intros T H. left. apply v_nat.
    - intros T H. right. inversion H; subst. apply IHt in H2.
      destruct H2.
      + inversion H. subst. inversion H0; subst; try inversion H3.
        eexists. apply ST_SuccNat.
      + destruct H0. exists (scc x). apply (ST_Succ1 _ _ H0).
    - intros T H. right. inversion H; subst. apply IHt in H2.
      destruct H2.
      + inversion H. subst. inversion H0; subst; try inversion H3.
        eexists. apply ST_PredNat.
      + destruct H0. exists (prd x). apply (ST_Pred _ _ H0).
    - intros T H. right. inversion H; subst. apply IHt1 in H3.
      apply IHt2 in H5. destruct H3.
      + destruct H5.
        * inversion H; subst.
          inversion H5; subst; try (inversion H0).
          inversion H6; subst; try (inversion H1).
          eexists. apply ST_Mulconsts.
        * destruct H1. eexists. apply ST_Mult2; eassumption.
      + destruct H0. eexists. apply ST_Mult1. apply H0.
    - intros T H. right. inversion H; subst.
      assert (H8: value t1 \/ (exists t' : tm, t1 --> t')).
      { apply (IHt1 Nat). apply H4. }
      destruct H8.
      + inversion H0; subst; try inversion H4.
        destruct n1; subst.
        * eexists. apply ST_Test0Zero.
        * eexists. apply ST_Test0Nonzero.
      + destruct H0. eexists. apply ST_Test01. apply H0.
    - intros T H. inversion H; subst.
      assert (H5 : value t0 \/ (exists t' : tm, t0 --> t')).
      { eapply IHt. apply H4. }
      destruct H5.
      + left. apply v_inl. apply H0.
      + right. destruct H0. eexists. apply ST_Inl. apply H0.
    - intros T H. inversion H; subst.
      assert (H5 : value t0 \/ (exists t' : tm, t0 --> t')).
      { eapply IHt. apply H4. }
      destruct H5.
      + left. apply v_inr. apply H0.
      + right. destruct H0. eexists. apply ST_Inr. apply H0.
    - intros T H. right. inversion H; subst.
      assert (H10: value t1 \/ (exists t' : tm, t1 --> t')).
      { apply (IHt1 (Sum T1 T2) H7). }
      inversion H7; subst.
      + inversion H0.
      + destruct H10.
        * inversion H2.
        * destruct H2. eexists. apply ST_Case. apply H2.
      + destruct H10.
        * inversion H3.
        * destruct H3. eexists. eapply ST_Case. apply H3.
      + destruct H10.
        * eexists. apply ST_CaseInl. inversion H0. apply H2.
        * destruct H0. eexists. apply ST_Case. apply H0.
      + destruct H10.
        * eexists. apply ST_CaseInr. inversion H0. apply H2.
        * destruct H0. eexists. apply ST_Case. apply H0.
      + destruct H10.
        * inversion H3.
        * destruct H3. eexists. eapply ST_Case. apply H3.
      + destruct H10.
        * inversion H3.
        * destruct H3. eexists. eapply ST_Case. apply H3.
      + destruct H10.
        * inversion H1.
        * destruct H1. eexists. eapply ST_Case. apply H1.
      + destruct H10.
        * inversion H1.
        * destruct H1. eexists. eapply ST_Case. apply H1.
      + destruct H10.
        * inversion H2.
        * destruct H2. eexists. eapply ST_Case. apply H2.
      + destruct H10.
        * inversion H1.
        * destruct H1. eexists. eapply ST_Case. apply H1.
    - intros T H. left. apply v_lnil.
    - intros T H. inversion H; subst.
      assert (H6 : value t1 \/ (exists t' : tm, t1 --> t')).
      { apply (IHt1 T1 H3). }
      assert (H7 : value t2 \/ (exists t' : tm, t2 --> t')).
      { apply (IHt2 (List T1) H5). }
      destruct H6.
      + destruct H7.
        * left. apply v_lcons; assumption.
        * right. destruct H1. eexists. apply ST_Cons2; eassumption.
      + right. destruct H0. eexists. apply ST_Cons1; eassumption.
    - intros T H. inversion H; subst.
      assert (H10 : value t1 \/ (exists t' : tm, t1 --> t')).
      { apply (IHt1 (List T1) H7). }
      destruct H10.
      + right. inversion H0; subst; try inversion H7.
        * subst. eexists. apply ST_LcaseNil.
        * subst. eexists. apply ST_LcaseCons; assumption.
      + right. destruct H0. eexists. apply ST_Lcase1. apply H0.
    - intros T H. left. apply v_unit.
    - intros T H. inversion H; subst.
      assert (H6 : value t1 \/ (exists t' : tm, t1 --> t')).
      { apply (IHt1 _ H3). }
      assert (H7 : value t2 \/ (exists t' : tm, t2 --> t')).
      { apply (IHt2 _ H5). }
      destruct H6.
      + destruct H7.
        * left. apply v_pair; assumption.
        * right. destruct H1. eexists. apply ST_Pair2; eassumption.
      + destruct H0. right. eexists. apply ST_Pair1. apply H0.
    - intros T H. inversion H; subst.
      assert (H3 : value t \/ (exists t' : tm, t --> t')).
      { apply (IHt _ H2). }
      destruct H3.
      + inversion H0; subst; inversion H2; subst. right.
        eexists. apply ST_FstPair; assumption.
      + destruct H0. right. eexists. apply ST_Fst. apply H0.
    - intros T H. inversion H; subst.
      assert (H3 : value t \/ (exists t' : tm, t --> t')).
      { apply (IHt _ H2). }
      destruct H3.
      + inversion H0; subst; inversion H2; subst. right.
        eexists. apply ST_SndPair; assumption.
      + destruct H0. right. eexists. apply ST_Snd. apply H0.
    - intros T H. inversion H; subst.
      assert (H7 : value t1 \/ (exists t' : tm, t1 --> t')).
      { apply (IHt1 _ H5). }
      destruct H7.
      + right. eexists. apply ST_LetValue. apply H0.
      + destruct H0. right. eexists. apply ST_Let1. apply H0.
    - intros T H. inversion H; subst.
      assert (H3 : value t \/ (exists t' : tm, t --> t')).
      { apply (IHt _ H2). }
      destruct H3.
      + inversion H0; subst; try inversion H2; subst.
        right. eexists. apply ST_FixAbs.
      + destruct H0. right. eexists. apply ST_Fix1. apply H0.
  Qed.

  Inductive appears_free_in : string -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (var x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (app t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (app t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x ->
        appears_free_in x t12 ->
        appears_free_in x (abs y T11 t12)
  (* numbers *)
  | afi_succ : forall x t,
     appears_free_in x t ->
     appears_free_in x (scc t)
  | afi_pred : forall x t,
     appears_free_in x t ->
     appears_free_in x (prd t)
  | afi_mult1 : forall x t1 t2,
     appears_free_in x t1 ->
     appears_free_in x (mlt t1 t2)
  | afi_mult2 : forall x t1 t2,
     appears_free_in x t2 ->
     appears_free_in x (mlt t1 t2)
  | afi_test01 : forall x t1 t2 t3,
     appears_free_in x t1 ->
     appears_free_in x (test0 t1 t2 t3)
  | afi_test02 : forall x t1 t2 t3,
     appears_free_in x t2 ->
     appears_free_in x (test0 t1 t2 t3)
  | afi_test03 : forall x t1 t2 t3,
     appears_free_in x t3 ->
     appears_free_in x (test0 t1 t2 t3)
  (* sums *)
  | afi_inl : forall x t T,
      appears_free_in x t ->
      appears_free_in x (tinl T t)
  | afi_inr : forall x t T,
      appears_free_in x t ->
      appears_free_in x (tinr T t)
  | afi_case0 : forall x t0 x1 t1 x2 t2,
      appears_free_in x t0 ->
      appears_free_in x (tcase t0 x1 t1 x2 t2)
  | afi_case1 : forall x t0 x1 t1 x2 t2,
      x1 <> x ->
      appears_free_in x t1 ->
      appears_free_in x (tcase t0 x1 t1 x2 t2)
  | afi_case2 : forall x t0 x1 t1 x2 t2,
      x2 <> x ->
      appears_free_in x t2 ->
      appears_free_in x (tcase t0 x1 t1 x2 t2)
  (* lists *)
  | afi_cons1 : forall x t1 t2,
     appears_free_in x t1 ->
     appears_free_in x (tcons t1 t2)
  | afi_cons2 : forall x t1 t2,
     appears_free_in x t2 ->
     appears_free_in x (tcons t1 t2)
  | afi_lcase1 : forall x t1 t2 y1 y2 t3,
     appears_free_in x t1 ->
     appears_free_in x (tlcase t1 t2 y1 y2 t3)
  | afi_lcase2 : forall x t1 t2 y1 y2 t3,
     appears_free_in x t2 ->
     appears_free_in x (tlcase t1 t2 y1 y2 t3)
  | afi_lcase3 : forall x t1 t2 y1 y2 t3,
     y1 <> x ->
     y2 <> x ->
     appears_free_in x t3 ->
     appears_free_in x (tlcase t1 t2 y1 y2 t3)
  (* pairs *)
  | afi_pairL : forall x t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (tpair t1 t2)
  | afi_pairR : forall x t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (tpair t1 t2)
  | afi_fst : forall x t,
      appears_free_in x t ->
      appears_free_in x (tfst t)
  | afi_snd : forall x t,
      appears_free_in x t ->
      appears_free_in x (tsnd t)
  (* let *)
  | afi_let1 : forall x y t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (tlet y t1 t2)
  | afi_let2 : forall x y t1 t2,
      y <> x ->
      appears_free_in x t2 ->
      appears_free_in x (tlet y t1 t2)
  (* fix *)
  | afi_fix1 : forall x xf,
      appears_free_in x xf ->
      appears_free_in x (tfix xf).
Hint Constructors appears_free_in : db.

Lemma context_invariance : forall Gamma Gamma' t S,
     Gamma |- t ? S ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     Gamma' |- t ? S.
Proof with eauto 30 with db.
  intros. generalize dependent Gamma'.
  induction H; intros Gamma' Heqv...
  - apply T_Var... rewrite <- Heqv...
  - apply T_Abs... apply IHhas_type. intros y Hafi.
    unfold update, t_update.
    destruct (eqb_stringP x y)...
  - eapply T_Case...
    + apply IHhas_type2. intros y Hafi.
      unfold update, t_update.
      destruct (eqb_stringP x1 y)...
    + apply IHhas_type3. intros y Hafi.
      unfold update, t_update.
      destruct (eqb_stringP x2 y)...
  - eapply T_Lcase... apply IHhas_type3. intros y Hafi.
    unfold update, t_update.
    destruct (eqb_stringP x1 y)...
    destruct (eqb_stringP x2 y)...
  - eapply T_Let...
    apply IHhas_type2.
    intros y Hafi. unfold update, t_update.
    destruct (eqb_stringP x y)...
Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t ? T ->
   exists T', Gamma x = Some T'.
Proof with eauto with db.
  intros x t T Gamma Hafi Htyp.
  induction Htyp; inversion Hafi; subst...
  - destruct IHHtyp as [T' Hctx]... exists T'.
    unfold update, t_update in Hctx.
    rewrite false_eqb_string in Hctx...
  - destruct IHHtyp2 as [T' Hctx]... exists T'.
    unfold update, t_update in Hctx.
    rewrite false_eqb_string in Hctx...
  - destruct IHHtyp3 as [T' Hctx]... exists T'.
    unfold update, t_update in Hctx.
    rewrite false_eqb_string in Hctx...
  - clear Htyp1 IHHtyp1 Htyp2 IHHtyp2.
    destruct IHHtyp3 as [T' Hctx]... exists T'.
    unfold update, t_update in Hctx.
    rewrite false_eqb_string in Hctx...
    rewrite false_eqb_string in Hctx...
  - destruct IHHtyp2 as [T' Hctx]... exists T'.
    unfold update, t_update in Hctx.
    rewrite false_eqb_string in Hctx...
Qed.

Lemma substitution_preserves_typing : forall Gamma x U v t S,
    (x |-> U; Gamma) |- t ? S ->
    empty |- v ? U ->
    Gamma |- ([x := v]t) ? S.
Proof with eauto with db.
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent Gamma. generalize dependent S.
  induction t; intros S Gamma Htypt; simpl; inversion Htypt; subst...
  - simpl. rename s into y.
    unfold update, t_update in H1.
    destruct (eqb_stringP x y).
    + subst. inversion H1; subst. clear H1.
      eapply context_invariance...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    + apply T_Var...
  - rename s into y. rename t into T11.
    apply T_Abs...
    destruct (eqb_stringP x y) as [Hxy | Hxy].
    + eapply context_invariance...
      subst.
      intros x Hafi. unfold update, t_update.
      destruct (eqb_string y x)...
    + apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (eqb_stringP y z) as [Hyz | Hyz]...
      subst.
      rewrite false_eqb_string...
  - rename s into x1. rename s0 into x2.
    eapply T_Case...
    + destruct (eqb_stringP x x1) as [Hxx1 | Hxx1].
      * eapply context_invariance...
        subst.
        intros z Hafi. unfold update, t_update.
        destruct (eqb_string x1 z)...
      * apply IHt2. eapply context_invariance...
        intros z Hafi. unfold update, t_update.
        destruct (eqb_stringP x1 z) as [Hx1z | Hx1z]...
        subst.
        rewrite false_eqb_string...
    + destruct (eqb_stringP x x2) as [Hxx2 |Hxx2].
      * eapply context_invariance...
        subst.
        intros z Hafi. unfold update, t_update.
        destruct (eqb_string x2 z)...
      * apply IHt3. eapply context_invariance...
        intros z Hafi. unfold update, t_update.
        destruct (eqb_stringP x2 z)...
        subst. rewrite false_eqb_string...
  - rename s into y1. rename s0 into y2.
    eapply T_Lcase...
    destruct (eqb_stringP x y1).
    + (* x = y1 *)
      simpl.
      eapply context_invariance...
      subst.
      intros z Hafi. unfold update, t_update.
      destruct (eqb_stringP y1 z)...
    + (* x <> y1 *)
      destruct (eqb_stringP x y2).
      * (* x = y2 *)
        eapply context_invariance...
        subst.
        intros z Hafi. unfold update, t_update.
        destruct (eqb_stringP y2 z)...
      * (* x <> y2 *)
        apply IHt3. eapply context_invariance...
        intros z Hafi. unfold update, t_update.
        destruct (eqb_stringP y1 z)...
        subst. rewrite false_eqb_string...
        destruct (eqb_stringP y2 z)...
        subst. rewrite false_eqb_string...
  - rename s into y.
    destruct (eqb_stringP x y)...
    + subst. rewrite update_shadow in H5.
      eapply T_Let...
    + rewrite update_permute in H5.
      * apply IHt2 in H5. eapply T_Let...
      * apply n.
Qed.

Theorem perservation : forall t t' T,
    empty |- t ? T ->
    t --> t' ->
    empty |- t' ? T.
Proof with eauto with db.
  intros t t' T HT. generalize dependent t'.
  remember empty as Gamma.
  induction HT; intros t' HE; subst; inversion HE; subst...
  - (* T_App *)
    apply substitution_preserves_typing with T1...
    inversion HT1...
  - inversion HT1; subst...
    eapply substitution_preserves_typing...
  - inversion HT1; subst...
    eapply substitution_preserves_typing...
  - inversion HT1; subst.
    apply substitution_preserves_typing with (List T1)...
    apply substitution_preserves_typing with T1...
  - inversion HT; subst. apply H5.
  - inversion HT; subst. apply H7.
  - eapply substitution_preserves_typing...
  - inversion HT; subst. eapply substitution_preserves_typing...
Qed.