Require Import General.
Require Export Relations.

Unset Standard Proposition Elimination Names.

Section SortsOfV6.

  (* Definition des composantes du calcul *)

  Inductive calc : Set :=
    | Pos : calc
    | Neg : calc.

  Inductive srt_v6 : Set :=
    | Sprop : calc -> srt_v6
    | Stype : nat -> srt_v6.

  Inductive axiom_v6 : srt_v6 -> srt_v6 -> Prop :=
    | ax_prop : forall (c : calc) (n : nat), axiom_v6 (Sprop c) (Stype n)
    | ax_type : forall n m : nat, n < m -> axiom_v6 (Stype n) (Stype m).

  Inductive rules_v6 : srt_v6 -> srt_v6 -> srt_v6 -> Prop :=
    | rule_prop_l : forall (c : calc) (s : srt_v6), rules_v6 (Sprop c) s s
    | rule_prop_r :
        forall (c : calc) (s : srt_v6), rules_v6 s (Sprop c) (Sprop c)
    | rule_type :
        forall n m p : nat,
        n <= p -> m <= p -> rules_v6 (Stype n) (Stype m) (Stype p).

  Inductive univ_v6 : srt_v6 -> srt_v6 -> Prop :=
    | univ_prop : forall (c : calc) (n : nat), univ_v6 (Sprop c) (Stype n)
    | univ_type : forall n m : nat, n <= m -> univ_v6 (Stype n) (Stype m).

  Definition univ : srt_v6 -> srt_v6 -> Prop := clos_refl_trans _ univ_v6.

  Hint Resolve ax_prop ax_type rule_prop_l rule_prop_r rule_type univ_prop
    univ_type: pts.
  Hint Unfold univ: pts.

  (* Inversion et Decidabilite de l'inclusion entre sortes *)

  Let univ_trans : forall x y z : srt_v6, univ x y -> univ y z -> univ x z.
Proof rt_trans srt_v6 univ_v6.

  Inductive inv_univ : srt_v6 -> srt_v6 -> Prop :=
    | iu_prop : forall c : calc, inv_univ (Sprop c) (Sprop c)
    | iu_pr_ty : forall (c : calc) (n : nat), inv_univ (Sprop c) (Stype n)
    | iu_type : forall n m : nat, n <= m -> inv_univ (Stype n) (Stype m).

  Hint Resolve iu_prop iu_pr_ty iu_type: pts.

  Lemma inv_univ_trans :
   forall x y z : srt_v6, inv_univ x y -> inv_univ y z -> inv_univ x z.
simple induction 1; intros; auto with arith pts.
inversion_clear H0; auto with arith pts.

inversion_clear H1.
apply iu_type.
apply le_trans with m; auto with arith pts.
Qed.

  Lemma univ_inv :
   forall s s' : srt_v6,
   univ s s' -> forall P : Prop, (inv_univ s s' -> P) -> P.
simple induction 1.
simple induction 1; auto with arith pts.

simple destruct x; auto with arith pts.

intros.
apply H4.
apply inv_univ_trans with y.
apply H1; auto with arith pts.

apply H3; auto with arith pts.
Qed.

  Lemma calc_dec : forall c c' : calc, decide (c = c').
simple destruct c; simple destruct c';
 (right; discriminate) || auto with arith pts.
Qed.

  Lemma v6_sort_dec : forall s s' : srt_v6, decide (s = s').
simple destruct s; simple destruct s'; intros; try (right; discriminate).
elim calc_dec with c c0; intros.
left; elim a; auto with arith pts.

right; red in |- *; intros H; apply b; injection H; auto with arith pts.

elim eq_nat_dec with n n0; intros.
left; elim a; auto with arith pts.

right; red in |- *; intros H; apply b; injection H; auto with arith pts.
Qed.

  Lemma univ_v6_dec : forall s s' : srt_v6, decide (univ s s').
refine
 (fun s s' : srt_v6 =>
  match s, s' return (decide (univ s s')) with
  | Sprop c, Sprop c' => _
  | Sprop _, Stype _ => left _ _
  | Stype n, Stype n' => _
  | Stype n, Sprop c => right _ _
  end).
case (calc_dec c c'); [ left | right ].
elim e; auto with arith pts.

red in |- *; intro; apply n.
apply univ_inv with (Sprop c) (Sprop c'); intros; auto with arith pts.
inversion_clear H0; auto with arith pts.

auto with pts.

red in |- *; intros.
apply univ_inv with (Stype n) (Sprop c); intros; auto with arith pts.
inversion_clear H0.

case (le_gt_dec n n'); [ left | right ].
auto with pts.

red in |- *; intros.
apply univ_inv with (Stype n) (Stype n'); intros; auto with arith pts.
inversion_clear H0.
absurd (n <= n'); auto with arith pts.
Qed.

  (* Inference des axiomes et regles *)

  Lemma v6_inf_axiom :
   forall s : srt_v6, {sp : srt_v6 | ppal (axiom_v6 s) univ sp}.
refine
 (fun s : srt_v6 =>
  match s return {sp : srt_v6 | ppal (axiom_v6 s) univ sp} with
  | Sprop c => exist _ (Stype 0) _
  | Stype n => exist _ (Stype (S n)) _
  end).
split; intros; auto with arith pts.
inversion_clear H; auto with arith pts.

split; intros; auto with arith pts.
inversion_clear H; auto with arith pts.
Qed.

  Lemma v6_inf_rule :
   forall x1 x2 : srt_v6,
   {x3 : srt_v6 | rules_v6 x1 x2 x3 &
   forall s1 s2 s3 : srt_v6,
   rules_v6 s1 s2 s3 -> univ x1 s1 -> univ x2 s2 -> univ x3 s3}.
refine
 (fun x1 x2 : srt_v6 =>
  match
    x1, x2
    return
      {x3 : srt_v6 | rules_v6 x1 x2 x3 &
      forall s1 s2 s3 : srt_v6,
      rules_v6 s1 s2 s3 -> univ x1 s1 -> univ x2 s2 -> univ x3 s3}
  with
  | Sprop c, _ => exist2 _ _ x2 _ _
  | Stype n, Sprop c' => exist2 _ _ (Sprop c') _ _
  | Stype n, Stype n' => exist2 _ _ (Stype (max_nat n n')) _ _
  end); auto with pts.
simple induction 1; intros; auto with arith pts.
apply univ_trans with (Stype m); auto with arith pts.

intros.
apply univ_inv with (Sprop c') s2; intros; auto with arith pts.
generalize H.
inversion_clear H2; intros.
inversion_clear H2; auto with arith pts.

apply univ_inv with (Sprop c') s2; intros; auto with arith pts.
generalize H.
inversion_clear H3; intros; auto with arith pts.
inversion_clear H3; auto with arith pts.

inversion_clear H3; auto with arith pts.

unfold max_nat in |- *.
elim (le_gt_dec n n'); auto with arith pts.

intros.
apply univ_inv with (Stype n) s1; intros; auto with arith pts.
apply univ_inv with (Stype n') s2; intros; auto with arith pts.
generalize H.
inversion_clear H2.
inversion_clear H3; intros.
inversion_clear H3.
cut (max_nat n n' <= p); auto with arith pts.
apply least_upper_bound_max_nat.
apply le_trans with m; auto with arith pts.

apply le_trans with m0; auto with arith pts.
Qed.

End SortsOfV6.

(* Uniform interface of sorts *)
Require Export GenericSort.

  Definition sort_of_gen (gs : gen_sort) : Exc srt_v6 :=
    match gs with
    | Gprop => value (Sprop Neg)
    | Gset => value (Sprop Pos)
    | Gtype n => value (Stype n)
    | _ => error
    end.

  Definition gen_of_sort (s : srt_v6) : gen_sort :=
    match s with
    | Sprop Neg => Gprop
    | Sprop Pos => Gset
    | Stype n => Gtype n
    end.


Require Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Basics.

Require Import Graph.
Require Import Homomorphism.

Open Scope program_scope.

(* An anti-homomorphism is a morphism preserving the graph structure of "+" and flipping the arguments of "*" *)
Class AntiHom {A B:Type} (f : Graph A -> Graph B) : Prop := {
  Anti_Empty :> f Empty = Empty;
  Anti_Overlay :> forall a b, f (Overlay a b) = Overlay (f a) (f b) ;
  Anti_Connect :> forall a b, f (Connect a b) = Connect (f b) (f a)
 }.

Lemma inline_antibind : forall A B (f_v : A -> Graph B),
  antibind f_v = foldg Empty f_v Overlay (flip Connect).
Proof. auto. Qed.

Lemma antibind_is_anti A B (f: A -> Graph B): AntiHom (antibind f).
Proof.
  intros.
  repeat split.
Qed.

Lemma transpose_is_anti (A:Type) : AntiHom (A:=A) transpose.
Proof.
  unfold transpose.
  apply antibind_is_anti.
Qed.

Lemma anti_is_antibind A B (hom: Graph A -> Graph B):
  AntiHom hom -> hom = antibind (hom ∘ Vertex).
Proof.
  intros H.
  apply FunctionalExtensionality.functional_extensionality.
  intro g.
  induction g.
  - compute. apply Anti_Empty.
  - auto.
  - rewrite Anti_Overlay.
    rewrite IHg1.
    rewrite IHg2.
    auto.
  - rewrite Anti_Connect.
    rewrite IHg1.
    rewrite IHg2.
    auto.
Qed.

Theorem equiv_antibind_anti A B (f : Graph A -> Graph B) :
  AntiHom f <-> f = antibind (f ∘ Vertex).
Proof.
  intros.
  split.
  - intro H.
    apply (anti_is_antibind A B f H).
  - intro H.
    rewrite H.
    apply antibind_is_anti.
Qed.

(* The composition of a foldg function and a graph homorphism is a foldg-function *)
Theorem foldg_antibind A B C (e : C) (v: B -> C) (o:C -> C -> C) (c:C -> C -> C) (f_v : A -> Graph B):
  foldg e v o c ∘ antibind f_v = foldg e (foldg e v o c ∘ f_v) o (flip c).
Proof.
  apply FunctionalExtensionality.functional_extensionality.
  intro g.
  unfold compose.
  induction g.
  - auto.
  - auto.
  - pose (H :=antibind_is_anti A B f_v).
    rewrite Anti_Overlay.
    repeat rewrite foldg_overlay.
    rewrite IHg1.
    rewrite IHg2.
    reflexivity.
  - pose (H :=antibind_is_anti A B f_v).
    rewrite Anti_Connect.
    repeat rewrite foldg_connect.
    rewrite IHg1.
    rewrite IHg2.
    reflexivity.
Qed.

Lemma flip_involutive A B C (x:A -> B -> C): flip (flip x) = x.
Proof. auto. Qed.

Theorem anti_compo_is_homo A B C (f : Graph A -> Graph B) (g : Graph B -> Graph C) :
  AntiHom f /\ AntiHom g -> Homomorphism (g ∘ f).
Proof.
  intros H. destruct H as (H1,H2).
  rewrite (anti_is_antibind A B f H1).
  rewrite (anti_is_antibind B C g H2).
  rewrite (inline_antibind B C).
  rewrite foldg_antibind.
  rewrite flip_involutive.
  apply bind_is_hom.
Qed.

Theorem anti_compo_homo_left A B C (f : Graph A -> Graph B) (g : Graph B -> Graph C) :
  Homomorphism f /\ AntiHom g -> AntiHom (g ∘ f).
Proof.
  intros H. destruct H as (H1,H2).
  rewrite (hom_is_bind H1).
  rewrite (anti_is_antibind B C g H2).
  rewrite (inline_antibind B C).
  rewrite foldg_bind.
  apply antibind_is_anti.
Qed.

Theorem anti_compo_homo_right A B C (f : Graph A -> Graph B) (g : Graph B -> Graph C) :
  AntiHom f /\ Homomorphism g -> AntiHom (g ∘ f).
Proof.
  intros H. destruct H as (H1,H2).
  rewrite (anti_is_antibind A B f H1).
  rewrite (hom_is_bind H2).
  rewrite (inline_bind B C).
  rewrite foldg_antibind.
  apply antibind_is_anti.
Qed.


Require Import Common Arith Peano.
Open Scope Z_scope.

Require Import Core Front.
(**

In this file, we define a hardware implementation of a small subset of
the Java Virtual Machine. We take the following conventions:

- the size of the code, the size of the stack, and the number of
  registers are the same.

- the state of the machine is defined by a program counter, that
  denotes the position in the code; a stack pointer, that denotes the
  first free element above the stack; and a set of registers.

*)

Definition Next {A} (f : A -> option A) (m : A ):=
  match f m with
    | None => m
    | Some m => m
  end.

Module Spec.
  (** * Specification of the stack machine

  This module corresponds to our specification of the stack
  machine: it uses natural numbers everywhere, and uses dynamic check
  to map undefined behaviors to the halting state *)

  Notation id := nat.
  Inductive cond := Ceq | Cne | Cle | Cgt.
  Inductive instruction: Type :=
  | Iconst(n: nat)
  | Ivar(x: id)
  | Isetvar(x: id)
  | Iadd
  | Isub
  | Ibranch_forward(ofs: nat)
  | Ibranch_backward(ofs: nat)
  | Ibranch_cond (c : cond) (ofs : nat)
  | Ihalt.

  Definition code := list instruction.

  Fixpoint code_at (C: code) (pc: nat) : option instruction :=
    match C, pc with
      | nil, _ => None
      | i :: C', O => Some i
      | i :: C', S pc' => code_at C' pc'
    end%list.

  Definition stack := list nat.

  Definition store := id -> nat.

  Require Import NPeano.

  Definition update (s:store) (x:id) (v : nat) :=
    fun y => if Nat.eqb x y then v else s y.

  Record machine := mk
    {
      c   : code;
      pc : nat;
      stk : stack;
      str : store
    }.

  Require Import List.

  Section t.
    (** We use a dynamic check to verify that the state we reach is
    valid, and some checks on, e.g., results of arithmetic operations,
    to ensure that we are not outside of the scope of validity of this
    definition. *)

    Variable bound : nat.
    Definition dyncheck  (s : machine) :=
      check (Nat.ltb (pc s) bound);
      check (Nat.ltb (List.length (stk s)) bound);
      Some s.

    (** * Next step relation for the stack machine *)
    Definition step (s : machine) : option machine :=
      do op <- code_at (c s) (pc s);
      match op with
        | Iconst n =>
          check (n <? bound);
          dyncheck (mk (c s) (pc s +1) (n :: stk s) (str s))
        | Ivar x =>
          check (x <? bound);
          dyncheck (mk (c s) (pc s +1) ((str s) x :: stk s) (str s))
        | Isetvar x =>
          check (x <? bound);
          match stk s with
            | nil => None
            | v :: stk =>
              dyncheck (mk (c s) (pc s +1) (stk) (update (str s) x v))
          end
        | Iadd =>
          match stk s with
            | nil => None
            | cons _ nil => None
            | n1 :: n2 :: stk =>
              check (n1 + n2 <? bound);
              dyncheck (mk (c s) (pc s +1) (n1 + n2 :: stk)  (str s) )
          end
        | Isub =>
          match stk s with
            | nil => None
            | cons _ nil => None
            | n2 :: n1 :: stk =>
              check (n2 <=? n1);
              dyncheck (mk (c s) (pc s +1) (n1 - n2 :: stk)  (str s) )
          end
        | Ibranch_forward ofs =>
          dyncheck (mk (c s) (pc s + 1 + ofs) (stk s) (str s))
        | Ibranch_backward ofs =>
          check (ofs <=? pc s + 1);
          dyncheck (mk (c s) (pc s + 1 - ofs) (stk s) (str s))
        | Ibranch_cond test ofs =>
          match stk s with
            | nil => None
            | cons _ nil => None
            | n2 :: n1 :: stk =>
              let t := match test with
                           | Ceq => NPeano.Nat.eqb n1 n2
                           | Cne => negb (NPeano.Nat.eqb n1 n2)
                           | Cle => (NPeano.Nat.leb n1 n2)%bool
                           | Cgt => negb ((NPeano.Nat.leb n1 n2 ))%bool
                       end
              in
              if t
              then
                dyncheck (mk (c s) (pc s +1 + ofs) stk  (str s) )
              else
                dyncheck (mk (c s) (pc s +1) stk  (str s) )

          end
        | _ => None
      end.
  End t.

(** We were heavily inspired by the following definition that comes from a course by X. Leroy

  Inductive transition (C: code): machine_state -> machine_state -> Prop :=
  | trans_const: forall pc stk s n,
                   code_at C pc = Some(Iconst n) ->
                   transition C (pc, stk, s) (pc + 1, n :: stk, s)
  | trans_var: forall pc stk s x,
                 code_at C pc = Some(Ivar x) ->
                 transition C (pc, stk, s) (pc + 1, s x :: stk, s)
  | trans_setvar: forall pc stk s x n,
                    code_at C pc = Some(Isetvar x) ->
                    transition C (pc, n :: stk, s) (pc + 1, stk, update s x n)
  | trans_add: forall pc stk s n1 n2,
                 code_at C pc = Some(Iadd) ->
                 transition C (pc, n2 :: n1 :: stk, s) (pc + 1, (n1 + n2) :: stk, s)
  | trans_sub: forall pc stk s n1 n2,
                 code_at C pc = Some(Isub) ->
      transition C (pc, n2 :: n1 :: stk, s) (pc + 1, (n1 - n2) :: stk, s)
  | trans_mul: forall pc stk s n1 n2,
                 code_at C pc = Some(Imul) ->
                 transition C (pc, n2 :: n1 :: stk, s) (pc + 1, (n1 * n2) :: stk, s)

  | trans_branch_forward: forall pc stk s ofs pc',
                            code_at C pc = Some(Ibranch_forward ofs) ->
                            pc' = pc + 1 + ofs ->
                            transition C (pc, stk, s) (pc', stk, s)
  | trans_branch_backward: forall pc stk s ofs pc',
                             code_at C pc = Some(Ibranch_backward ofs) ->
                             pc' = pc + 1 - ofs ->
                             transition C (pc, stk, s) (pc', stk, s)
  | trans_beq: forall pc stk s ofs n1 n2 pc',
                 code_at C pc = Some(Ibeq ofs) ->
                 pc' = (if beq_nat n1 n2 then pc + 1 + ofs else pc + 1) ->
                 transition C (pc, n2 :: n1 :: stk, s) (pc', stk, s)
  | trans_bne: forall pc stk s ofs n1 n2 pc',
                 code_at C pc = Some(Ibne ofs) ->
                 pc' = (if beq_nat n1 n2 then pc + 1 else pc + 1 + ofs) ->
                 transition C (pc, n2 :: n1 :: stk, s) (pc', stk, s)
  | trans_ble: forall pc stk s ofs n1 n2 pc',
                 code_at C pc = Some(Ible ofs) ->
                 pc' = (if Nat.leb n1 n2 then pc + 1 + ofs else pc + 1) ->
                 transition C (pc, n2 :: n1 :: stk, s) (pc', stk, s)
  | trans_bgt: forall pc stk s ofs n1 n2 pc',
                 code_at C pc = Some(Ibgt ofs) ->
                 pc' = (if Nat.leb n1 n2 then pc + 1 else pc + 1 + ofs) ->
                 transition C (pc, n2 :: n1 :: stk, s) (pc', stk, s).
*)

End Spec.

Module Circuit.
Section t.
  Variable size : nat.
  (** Fe-Si implementation of the Stack machine *)

  (** We use the following ocaml type as a reference, and give assign
  opcodes to instructions accordingly

  type instr =
  | Iconst of int 			(* push integer on stack *)
  | Ivar   of reg 			(* push register on stack *)
  | Isetvar of reg 			(* pop an integer into a register *)
  | Iadd 					(* pop n2, pop n1, push back n1 + n2 *)
  | Isub 					(* pop n2, pop n1, push back n1 - n2 *)
  | Ibranch_forward of int 		(* move pc to pc + 1 + ofs *)
  | Ibranch_backward of int 		(* move pc to pc + 1 - ofs *)
  | Ibeq of int 				(* pop n2, pop n1, skips ofs forward if n1 = n2 *)
  | Ibne of int 				(* pop n2, pop n1, skips ofs forward if n1 <> n2 *)
  | Ible of int 				(* pop n2, pop n1, skips ofs forward if n1 <= n2 *)
  | Ibgt of int 				(* pop n2, pop n1, skips ofs forward if n1 > n2 *)
  | Ihalt
   *)
  Variable n : nat.

  Notation OPCODE := (Tint 4).  (* We need 4 bits to encode the opcode *)
  Notation VAL := (Tint n).

  Open Scope list_scope.
  Definition INSTR := Ttuple (OPCODE :: VAL :: nil).
  Definition Phi : state :=
    [
      Tregfile n INSTR;       (* the code *)
      Treg VAL;                  (* the program counter *)
      Tregfile n VAL;         (* the stack *)
      Treg VAL;                 (* the stack pointer *)
      Tregfile n VAL         (* the registers *)
    ].

  Definition opcode {V} (I : expr V INSTR) : expr V OPCODE.
    eapply Enth. 2: apply I. apply var_0.
  Defined.

  Definition val {V} (I : expr V INSTR) : expr V VAL.
    eapply Enth. 2: apply I. apply var_S. apply var_0.
  Defined.

  Open Scope action_scope.
  Notation "x \oplus y" := (OrElse _ _ _ x y) (at level 51, right associativity).

  Section code.
    (** We parametrise the following code by the variable parameter of the PHOAS representation.   *)
    Variable V : type -> Type.

    Definition CODE  := (var_0) : var Phi (Tregfile n INSTR).
    Definition PC    := var_S (var_0) : var Phi (Treg VAL).
    Definition STACK := var_S (var_S (var_0)) : var Phi (Tregfile n VAL).
    Definition SP    := var_S (var_S (var_S (var_0))) : var Phi (Treg VAL).
    Definition REGS  := var_S (var_S (var_S (var_S (var_0)))) : var Phi (Tregfile n VAL).

    Definition push i : action Phi V Tunit :=
      (do sp <- ! SP;
       do _ <- write STACK [: sp <- i];
       do _ <- SP ::= sp + #i 1;
       ret (#Ctt))%action.

    Definition pop : action Phi V VAL :=
      do sp <- ! SP;
      do x <- read STACK [: sp - #i 1];
      do _ <- SP ::= sp - #i 1;
      ret x.

    Definition Iconst  (pc: expr V VAL) (i : expr V INSTR) : action Phi V Tunit :=(
      do _ <- push (val i);
      PC ::= pc + #i 1
    )%action.

    Definition Ivar (pc: expr V VAL) (i : expr V INSTR) : action Phi V Tunit :=
      (
        do r <- read REGS [: val i];
        do _ <- push r;
        PC ::= pc + #i 1
      )%action.

    Definition Isetvar (pc: expr V VAL) (i : expr V INSTR) : action Phi V Tunit :=
      (
        do v <- pop;
        do _ <- write REGS [: val i <- v];
        PC ::= pc + #i 1
      )%action.

      Definition Iadd(pc: expr V VAL) (i : expr V INSTR) : action Phi V Tunit :=
      (
        do sp <- ! SP;
        do n2 <- read STACK [: sp - #i 1];
        do n1 <- read STACK [: sp - #i 2];
        do _ <- write STACK [: sp - #i 2 <- n1 + n2];
        do _ <- SP ::= sp - #i 1;
        PC ::= pc + #i 1
      )%action.

      Definition Isub (pc: expr V VAL) (i : expr V INSTR) : action Phi V Tunit :=
      (
        do sp <- ! SP;
        do n2 <- read STACK [: sp - #i 1];
        do n1 <- read STACK [: sp - #i 2];
        do _ <- write STACK [: sp - #i 2 <- n1 - n2];
        do _ <- SP ::= sp - #i 1;
        PC ::= pc + #i 1
      )%action.

      Definition Ibranch_forward (pc: expr V VAL) (i : expr V INSTR) : action Phi V Tunit :=
      (
        PC ::= pc + #i 1 + (val i)
      )%action.

      Definition Ibranch_backward (pc: expr V VAL) (i : expr V INSTR) : action Phi V Tunit :=
      (
        PC ::= pc + #i 1 - (val i)
      )%action.

      Definition Ibranch_cond cond (pc: expr V VAL) (i : expr V INSTR) : action Phi V Tunit :=
        (
          do sp <- ! SP;
          do n2 <- read STACK [: sp - #i 1];
          do n1 <- read STACK [: sp - #i 2];
          do _ <- SP ::= sp - #i 2;
          ((when (cond n1 n2) do
            PC ::= pc + #i 1 + (val i))
             \oplus (PC ::= pc + #i 1))
      )%action.

      Definition Ibeq :=
        Ibranch_cond (fun n1 n2 => n1 = n2)%expr.

      Definition Ibne :=
        Ibranch_cond (fun n1 n2 => n1 <> n2)%expr.

      Definition Ible :=
        Ibranch_cond (fun n1 n2 => n1 <= n2)%expr.

      Definition Ibgt :=
        Ibranch_cond (fun n1 n2 => n2 < n1)%expr.

      Definition Ihalt (pc: expr V VAL) (i : expr V INSTR) : action Phi V B :=
        when (opcode i = (#i 11)) do
        ret #b true.

      Definition code_at {T} f : action Phi V T:=
        do pc <- ! PC;
        do i  <- read CODE [: pc];
        f pc i.

      Fixpoint case {S T} (x : expr V S) (l : list (expr V S * action Phi V T)) default :=
        match l with
          | nil => default
          | (c,a) :: q =>
            (when (x = c) do a)
              \oplus (when (x <> c) do case x q default)
        end.

      Require Import ZArith.
      Definition mk_val {n} v : expr V (Int n) := (#i (Z.of_nat v)).

      Definition code :=
        code_at (fun pc i =>
                   case (opcode i)
                        ([
                            (mk_val 0, Iconst pc i);
                            (mk_val 1, Ivar   pc i);
                            (mk_val 2, Isetvar pc i);
                            (mk_val 3, Iadd pc i);
                            (mk_val 4, Isub pc i);
                            (mk_val 5, Ibranch_forward pc i);
                            (mk_val 6, Ibranch_backward pc i);
                            (mk_val 7, Ibeq pc i);
                            (mk_val 8, Ibne pc i);
                            (mk_val 9, Ible pc i);
                            (mk_val 10, Ibgt pc i)
                        ])
                        ret (# Ctt )) .
  End code.
  Definition Code := fun V => code V.
  Definition Next m := Front.Next _ m (Code).
End t.
End Circuit.

Section t.
  Variable size : nat.
  Notation n := (Word.power2 size).

  Notation V := eval_type.

  Definition step  {Phi t} (A : action Phi eval_type t) st :
    option (eval_state Phi) :=
    match Sem.eval_action  A st (Diff.init Phi)  with
      | Some p => Some (Diff.apply Phi (snd p) st)
      | None => None
    end.
  Require Import ZArith DList.
  Definition mk_val v : eval_type (Int size) := Word.repr size (Z.of_nat v).

  Notation "x =%= y" := (mk_val x = y) (at level 80).

  Notation c  m2 := (DList.DList.get (Circuit.CODE size) m2).
  Notation pc m2 := (DList.DList.get (Circuit.PC size) m2).
  Notation stk m2 := (DList.DList.get (Circuit.STACK size) m2).
  Notation sp m2 := (DList.DList.get (Circuit.SP size) m2).
  Notation str m2 := (DList.DList.get (Circuit.REGS size) m2).
  (*
    Definition CODE  := (var_0) : var Phi (Tregfile n INSTR).
    Definition PC    := var_S (var_0) : var Phi (Treg VAL).
    Definition STACK := var_S (var_S (var_0)) : var Phi (Tregfile n VAL).
    Definition SP    := var_S (var_S (var_S (var_0))) : var Phi (Treg VAL).
    Definition REGS  := var_S (var_S (var_S (var_S (var_0)))) : var Phi (Tregfile n VAL).
   *)

  Require Import ZArith.

  Definition cast_instr op val : eval_type (Circuit.INSTR size) :=
    (Word.repr _ (Z.of_nat op), (Word.repr _ (Z.of_nat val) , tt)).

  Definition mk_instr (i : Spec.instruction) : eval_type (Circuit.INSTR size) :=
    match i with
      | Spec.Iconst x =>  cast_instr 0 x
      | Spec.Ivar x =>    cast_instr 1 x
      | Spec.Isetvar x => cast_instr 2 x
      | Spec.Iadd =>      cast_instr 3 0
      | Spec.Isub =>      cast_instr 4 0
      | Spec.Ibranch_forward ofs => cast_instr 5 ofs
      | Spec.Ibranch_backward ofs => cast_instr 6 ofs
      | Spec.Ibranch_cond Spec.Ceq ofs =>             cast_instr 7 ofs
      | Spec.Ibranch_cond Spec.Cne ofs =>             cast_instr 8 ofs
      | Spec.Ibranch_cond Spec.Cle ofs =>             cast_instr 9 ofs
      | Spec.Ibranch_cond Spec.Cgt ofs =>             cast_instr 10 ofs
      | Spec.Ihalt =>                cast_instr 11 0
    end.

  (** The property that states that the code on both machines are compatible  *)
  Definition R_code (m1 : Spec.machine) (m2 : eval_state (Circuit.Phi size)) :  Prop :=
    forall p, p < n ->
         match Spec.code_at (Spec.c m1) p with
           | None => False
           | Some i => mk_instr i = Regfile.get (c m2) (mk_val p)
         end.

  (** We define what it means for stacks to be compatible *)
  Definition R_stk l v :=
    forall i i', i < List.length l ->
         i =%= i' ->
         Regfile.get v i' = mk_val (List.nth i (List.rev l) 0).

  Definition R_str st v :=
    forall i i', i < n ->
            i =%= i' ->
            st i =%= Regfile.get v i'.

  (** The invariant that relates the execution of the machines  *)
  Record R (m1 : Spec.machine) (m2 : eval_state (Circuit.Phi size)) :  Prop :=
    {
      Rpc1 : Spec.pc m1 =%= pc m2;
      Rpc2 : Spec.pc m1 < n;
      (* properties about the stack *)
      Rstk : R_stk (Spec.stk m1) (stk m2);
      Rsp1 : List.length (Spec.stk m1) =%= sp m2;
      Rsp2 : List.length (Spec.stk m1) < n;
      Rsp3 : forall x, List.In x (Spec.stk m1) -> x < n;
      (* properties about the store *)
      Rstr1  : R_str (Spec.str m1) (str m2);
      Rstr2  : forall x, Spec.str m1 x < n
    }.

  Hint Resolve Rpc1 Rpc2 Rstk Rsp1 Rsp2 Rsp3 Rstr1 Rstr2.

  Notation "x == y" := (R x y) (at level 80).

  Lemma step_code_at {T} m1 m2 (f : expr V (Int size) -> expr V (Circuit.INSTR size) ->
                                  action (Circuit.Phi size) V T):
    R_code m1 m2 ->
    m1 == m2 ->
    step (Circuit.code_at _ _ f)%action m2
    = do i <- Spec.code_at (Spec.c m1) (Spec.pc m1);
    step (f (Evar (mk_val (Spec.pc m1)))%expr (Evar (mk_instr i))) m2.
  Proof.
    intros Hcode H.
    unfold Circuit.code_at.
    unfold step at 1. Opaque DList.DList.get. Opaque Diff.apply.
    simpl. unfold Sem.Dyn.Bind.
    rewrite (Rpc1 _ _ H).
    refine (let H := Hcode (Spec.pc m1) (Rpc2 _ _ H) in _).     rewrite (Rpc1 _ _ H) in H0.
    destruct (Spec.code_at (Spec.c m1) (Spec.pc m1)) eqn:?. simpl. rewrite H0. reflexivity.
    tauto.
  Qed.

  Add  Ring wring : (Word.ring size).

  Lemma repr_add m x y: Word.repr m (x + y) = Word.add (Word.repr m x) (Word.repr m y).
    apply Word.unsigned_inj. simpl.
    rewrite Zplus_mod. reflexivity.
  Qed.

  Lemma repr_sub m (x y : Z) : Word.repr m (x - y) = Word.sub (Word.repr m x) (Word.repr m y).
  Proof.
    apply Word.unsigned_inj; simpl.
    rewrite Zminus_mod. reflexivity.
  Qed.

  Lemma Rval_succ : forall x, x + 1 =%= Word.add (mk_val x) (Cword 1%Z).
  Proof.
    intros.
    unfold mk_val. rewrite plus_comm. rewrite Nat2Z.inj_succ.   rewrite <- Z.add_1_l. rewrite repr_add. unfold Cword. simpl. ring.
  Qed.

  Lemma Rval_add : forall x y, x + y =%= Word.add (mk_val x) (mk_val y).
  Proof.
    intros.
    unfold mk_val. rewrite Nat2Z.inj_add. rewrite repr_add. reflexivity.
  Qed.

  Lemma Rval_sub : forall x y, y <= x -> x - y =%= Word.sub (mk_val x) (mk_val y%Z).
  Proof.
    intros.
    unfold mk_val. rewrite Nat2Z.inj_sub by omega.
    apply repr_sub.
  Qed.

  Lemma Rval_add_morphism : forall x1 y1 x2 y2, x1 =%= x2 -> y1 =%= y2 -> x1 + y1 =%= Word.add x2 y2.
  Proof.
    intros. rewrite <- H, <- H0. apply Rval_add.
  Qed.

  Lemma Rval_sub_morphism : forall x1 y1 x2 y2, x1 =%= x2 -> y1 =%= y2 ->
                                                   y1 <= x1 -> x1 - y1 =%= Word.sub x2 y2.
  Proof.
    intros.
    rewrite <- H, <- H0.
    apply Rval_sub. omega.
  Qed.

  Lemma Rval_length_1 {A} (l: list A) hd tl x:
    l = hd :: tl ->
    List.length l  =%= x ->
    List.length tl =%= Word.sub x (Cword 1%Z).
  Proof.
    intros.
    replace (List.length tl) with (List.length l - 1) by (rewrite H; simpl; try omega).
    rewrite <- H0. apply Rval_sub_morphism; auto. rewrite H. simpl; omega.
  Qed.
  Lemma Rval_length_2 {A} (l: list A) hd1 hd2 tl x:
    l = hd1 :: hd2 :: tl ->
    List.length l  =%= x ->
    List.length tl =%= Word.sub x (Cword 2%Z).
  Proof.
    intros.
    replace (List.length tl) with (List.length l - 2) by (rewrite H; simpl; try omega).
    rewrite <- H0. apply Rval_sub_morphism; auto. rewrite H. simpl; omega.
  Qed.

  (** We use the [val] hint db for theorems that deal with the Rval relation *)
  Hint Resolve Rval_succ Rval_add Rval_sub Rval_add_morphism Rval_sub_morphism : val.
  Hint Resolve Rval_length_1 Rval_length_2 : val.

  Fixpoint case {A B} (eq : A -> A -> bool) e (l: list (A *B)) default :=
    match l with
      | nil => default
      | (t,v) :: q => if eq e t then v else case eq e q default
      end.

  Lemma step_case {S T k} (e: expr V S) l (default : action _ V T) d:
    step (Circuit.case k V e l default) d =
    step (case (fun x y => type_eq _ (eval_expr _ x) (eval_expr _ y)) e l default) d.
  Proof.
    induction l.
    - reflexivity.
    - simpl. destruct a.
      destruct (type_eq S (eval_expr S e) (eval_expr S e0)) eqn: He.
      destruct (step a d) eqn:Ha.
      +
      Lemma step_OrElse2 Phi t  A B d:
        step B d = None ->
        step (OrElse Phi V t A B) d = step A d.
      Proof.
        unfold step. simpl. intros H. unfold Sem.Dyn.OrElse.
        destruct (        Sem.eval_action A d (Diff.init Phi)) eqn: HA.
        f_equal.
        auto.
      Qed.
      rewrite step_OrElse2.
      Lemma step_when_true  Phi t A C d :
        eval_expr Tbool C = true ->
        step (when C do A) d = @step Phi t A d.
      Proof.
        unfold step. simpl. intros H. rewrite H. unfold Sem.Dyn.Bind.  simpl. reflexivity.
      Qed.

      rewrite step_when_true; simpl;  auto.
      Lemma step_when_false  Phi t A C d :
        eval_expr Tbool C = false ->
        @step Phi t (when C do A) d = None.
      Proof.
        unfold step. simpl. intros H. rewrite H. unfold Sem.Dyn.Bind.  simpl. reflexivity.
      Qed.
      rewrite step_when_false. auto. simpl. rewrite He. reflexivity.

      + rewrite step_OrElse2. rewrite step_when_true. auto.
        simpl; auto.
        rewrite step_when_false. auto. simpl; rewrite He; auto.
      +
        Lemma step_OrElse1 Phi t A B d:
          step A d = None ->
          step (OrElse Phi V t A B) d = step B d.
        Proof.
          unfold step. simpl. intros H.  unfold Sem.Dyn.OrElse.       destruct (        Sem.eval_action A d (Diff.init Phi)) eqn: HA. discriminate.  reflexivity.
        Qed.
        rewrite step_OrElse1.
        rewrite step_when_true. auto.
        simpl. rewrite Bool.negb_true_iff. auto.
        rewrite step_when_false. auto. auto.
  Qed.

  (** pushing elements on the stack preserves the stk part of the invariant *)
  Lemma push_correct_stk stk1 stk2 x1 x2 p: x1 =%= x2 ->
                                      R_stk stk1 stk2  ->
                                      mk_val (List.length stk1) = p ->
                                      List.length stk1 < n ->
                                      R_stk (x1 :: stk1) (Regfile.set (stk2) p x2).
  Proof.
    unfold R_stk; simpl. intros Hx H Hp Hstk i i' Hi  Hi' . rewrite <- Hi'. clear Hi'.
    assert (Hi' : i < List.length stk1 \/ i = (List.length stk1)) by omega; clear Hi.
    destruct Hi' as [Hi | Hi].
    * rewrite Regfile.gso. rewrite List.app_nth1 by (rewrite List.rev_length;auto).
      apply H;auto.
      simpl in *.
      clear - Hstk Hi Hp. rewrite <- Hp. clear Hp.
      apply (Word.not_eqb size); assumption.
    * rewrite List.app_nth2 by (rewrite List.rev_length;omega).
      rewrite Hi. rewrite List.rev_length. rewrite minus_diag. simpl.
      rewrite Regfile.gss.  auto.
      simpl in *.  rewrite Hp.

      Lemma Word'eqb_refl : forall n (x: Word.T n), Word.eqb x x = true.
      Proof.
        intros. rewrite Word.eqb_correct. reflexivity.
      Qed.
      apply Word'eqb_refl.
  Qed.

  Hint Extern 4  (_ < _) => rewrite <- NPeano.Nat.ltb_lt.
  (** pushing elements on the stack preserves the stack pointer part of the invariant  *)
  Lemma push_correct_sp m1 m2 :
    m1 == m2 ->
    S (Datatypes.length (Spec.stk m1)) =%=
      Word.add (DList.hd (DList.tl (DList.tl (DList.tl m2)))) (Cword 1%Z).
  Proof.
    destruct 1 as [_ _ _ H].
    Transparent DList.get. simpl in *. Opaque DList.get.
    rewrite <- H. rewrite <- NPeano.Nat.add_1_r. apply Rval_succ.
  Qed.
  Hint Resolve push_correct_sp.

  Lemma pop_correct_stk hd tl v : R_stk (hd :: tl) (v) ->
                                      R_stk (tl) (v).
  Proof.
    unfold R_stk; simpl. intros.
    rewrite (H i); auto.
    rewrite List.app_nth1 by (rewrite List.rev_length; omega). reflexivity.
  Qed.

  Lemma pop_correct_sp m1 m2 hd tl k : m1 == m2 ->
                                     Spec.stk m1 = hd :: tl ->
                                     k = Datatypes.length tl ->
                                     k =%= Word.sub (DList.hd (DList.tl (DList.tl (DList.tl m2)))) (Cword 1%Z).
  Proof.
    intros. unfold Cword.
    replace k with (List.length (Spec.stk m1) - 1). apply Rval_sub_morphism.
    destruct H; simpl in *; auto.
    reflexivity.
    rewrite H0; simpl; omega.
    rewrite H0. simpl. omega.
  Qed.

  Hint Resolve pop_correct_sp.

  Lemma pop2_correct_sp m1 m2 hd1 hd2 tl k : m1 == m2 ->
                                        Spec.stk m1 = hd1 :: hd2 :: tl ->
                                        k = Datatypes.length tl ->
                                        k =%= Word.sub (DList.hd (DList.tl (DList.tl (DList.tl m2)))) (Cword 2%Z).
  Proof.
    intros. unfold Cword.
    replace k with (List.length (Spec.stk m1) - 2). apply Rval_sub_morphism.
    destruct H; simpl in *; auto.
    reflexivity.
    rewrite H0; simpl; omega.
    rewrite H0. simpl. omega.
  Qed.

  Hint Resolve pop2_correct_sp.

  Definition branch_cond_eval cond n1 n2 :=
    match cond with
      | Spec.Ceq => NPeano.Nat.eqb n1 n2
      | Spec.Cne => negb (NPeano.Nat.eqb n1 n2)
      | Spec.Cle => NPeano.Nat.leb n1 n2
      | Spec.Cgt => negb (NPeano.Nat.leb n1 n2)
    end.

  Require Import Consider.

  Ltac list_length_tac :=
      repeat
        match goal with
            |- context [List.length (List.rev _)] => rewrite List.rev_length
          | |- context [List.length (List.app _ _)] => rewrite List.app_length
          | H : ?l = _ |- context [List.length ?l] => rewrite H
        end; simpl; omega.

  Hint Extern 4  (_ < _) => list_length_tac.
  Hint Extern 4  (_ <= _) => list_length_tac.
  Hint Extern 4  (_ > _) => list_length_tac.
  Hint Extern 4  (_ >= _) => list_length_tac.

  Hint Extern 4 (R_stk _ _) => match goal with
                                | H : _ == _ |- _ => clear - H; destruct H; simpl in *
                              end.
  Hint Extern 4 (_ =%= _) =>  match goal with
                               | H : _ == _ |- _ => clear - H; destruct H; simpl in * end.

  Lemma hint_length m1 m2 x y s: m1 == m2 ->
                           Spec.stk m1 = x :: y :: s ->
                           Datatypes.length s < n.
  Proof.
    intros. destruct H; simpl in *.  rewrite H0 in Rsp5.  simpl in *. omega.
  Qed.

  Hint Resolve hint_length.

  Lemma pop2_correct_stk m1 m2 x y s: m1 == m2 ->
                                      Spec.stk m1 = x :: y :: s ->
                                      R_stk s  (DList.hd (DList.tl (DList.tl m2))).
  Proof.
    intros.
    destruct H. simpl in *.
    apply (pop_correct_stk y).
    apply (pop_correct_stk x).
    rewrite <- H0. apply Rstk0.
  Qed.
  Hint Resolve pop2_correct_stk.

  Lemma stk_1 m1 m2 a1 s:
    m1 == m2 ->
    Spec.stk m1 = a1 :: s ->
    a1 =%= Regfile.get (stk m2) (Word.sub (sp m2) (Cword 1%Z)) .
  Proof.
    intros H Heq.
    destruct H as [Hpc1 Hpc2 Hstk Hsp].
    simpl in *.
    rewrite (Hstk ((List.length s))); auto.
    rewrite Heq. simpl.
    rewrite List.app_nth2. rewrite List.rev_length.  rewrite minus_diag. simpl. reflexivity.
    auto.
    change (Cword 1%Z) with (mk_val 1). rewrite <- Hsp.
    rewrite <- Rval_sub.
    rewrite Heq. simpl. rewrite <- minus_n_O. reflexivity. rewrite Heq. simpl. omega.
  Qed.

  Lemma stk_2 m1 m2 a1 a2 s:
    m1 == m2 ->
    Spec.stk m1 = a1 :: a2 :: s ->
    a2 =%= Regfile.get (stk m2) (Word.sub (sp m2) (Cword 2%Z)) .
  Proof.
    intros H Heq.
    destruct H as [Hpc1 Hpc2 Hstk Hsp].
    simpl in *.
    rewrite (Hstk ((List.length s))); auto.
    rewrite Heq. simpl.
    rewrite List.app_nth1; auto.
    rewrite List.app_nth2; auto.
    rewrite List.rev_length.  rewrite minus_diag. simpl. reflexivity.
    rewrite <- Hsp. replace ((List.length s)) with (List.length (Spec.stk m1) - 2).
    apply Rval_sub.
    auto.
    rewrite Heq.  simpl.  omega.
  Qed.

  Transparent Diff.apply. Transparent Diff.add. Transparent Diff.init.
  Transparent DList.get.

  Lemma Rsp3_pop2 m1 m2 x1 x2 s :
    m1 == m2 ->
    Spec.stk m1 = x1 :: x2 :: s ->
    (forall x, List.In x s -> x < n).
  Proof.
    intros. apply (Rsp3 _ _ H).  rewrite H0. simpl.  intuition.
  Qed.
  Hint Resolve Rsp3_pop2 : stack.

  Lemma Rsp3_pop1 m1 m2 x1 s :
    m1 == m2 ->
    Spec.stk m1 = x1 :: s ->
    (forall x, List.In x s -> x < n).
  Proof.
    intros. apply (Rsp3 _ _ H).  rewrite H0. simpl.  intuition.
  Qed.
  Hint Resolve Rsp3_pop1 : stack.

  Ltac t :=
    match goal with
        H : Spec.step ?n ?m = Some ?m',
            Hi : Spec.code_at _ _ = _
        |- _ =>
        unfold Spec.step in H;
          rewrite Hi in H;
          unfold Spec.dyncheck in H;
          simpl in H;
          repeat match type of H with
                   | context [match ?x with | [] => _ | _::_ => _ end] =>
              destruct (x) eqn:?
                 end;
          (repeat match goal with
                    | H : (check ?x ; _) = _ |- _ => consider x; intros
                  end);
          (try match goal with
                 | H : Some _ = Some _ |- _ => simpl in H; inject H
                                                       | H : Some _ =  None |- _ => discriminate
                                                       | H : None = Some _ |- _ => discriminate
               end)
    end.

  Lemma branch_cond_correct m1 m2 (Hcode : R_code m1 m2) (H : m1 == m2) m1'
        (Hm1: Spec.step n m1 = Some m1')
        test
        cond ofs
        (Hi : Spec.code_at (Spec.c m1) (Spec.pc m1) = Some (Spec.Ibranch_cond cond ofs))
        (Hcond : forall x1 y1 x2 y2,
                   x1 < n -> y1 < n ->
              x1 =%= x2 ->
              y1 =%= y2 ->
              eval_expr B (test (Evar x2) (Evar y2)) = branch_cond_eval cond x1 y1)
  :
    match step (Circuit.Ibranch_cond size V test (Evar (mk_val (Spec.pc m1))) (Evar (mk_instr (Spec.Ibranch_cond cond ofs)))) m2 with
      | None => False
      | Some m2' => m1' == m2'
    end.
  Proof.
    unfold Spec.step in Hm1; rewrite Hi in Hm1; simpl in Hm1.
    destruct (Spec.stk m1) as [ | n2 [| n1 s]] eqn: Hs; try discriminate.
    unfold step. simpl. unfold Sem.Dyn.Bind. unfold Sem.Dyn.OrElse.
    rewrite (Hcond n1 n2).

    destruct cond; simpl in *;
    match goal with
        |- context [if ?x then _ else _] => consider x; intros
    end;
    unfold Spec.dyncheck in *; simpl in *;
    repeat    match goal with
        H : context[(check ?x ; _ )] |- _ => consider x; intros
    end;
      try discriminate;
      try match goal with
          H : Some _ = Some _ |- _ => inject H
      end; simpl; constructor; auto with val; simpl; eauto using Rsp3_pop2; try apply H.

    - apply (Rsp3 _ _ H). rewrite Hs; intuition.
    - apply (Rsp3 _ _ H). rewrite Hs; intuition.

    - clear Hcond Hm1.
      destruct H. rewrite (Rstk0 (List.length (Spec.stk m1) - 2)); auto.
      rewrite Hs. simpl. rewrite List.app_nth1. rewrite List.app_nth2.
      rewrite List.rev_length.
      rewrite <- minus_n_O. rewrite minus_diag.  simpl. reflexivity.
      rewrite List.rev_length. omega.  simpl.
      auto.
      auto with val.
    - clear Hcond Hm1.
      destruct H. rewrite (Rstk0 (List.length (Spec.stk m1) - 1)); auto.
      rewrite Hs. simpl. rewrite List.app_nth2.
      rewrite List.app_length.
      rewrite List.rev_length. simpl List.length.  rewrite plus_comm. simpl plus. rewrite minus_diag. simpl. reflexivity.
      auto with val.
      auto with val.
  Qed.

  Lemma Word'eqb_faithful x1 y1:
    x1 < n -> y1 < n ->
    Word.eqb (mk_val x1) (mk_val y1) = NPeano.Nat.eqb x1 y1.
  Proof.
    intros.
    consider (NPeano.Nat.eqb x1 y1); intros.
    rewrite Word.eqb_correct.
    unfold mk_val. subst. reflexivity.
    destruct (Word.eqb (mk_val x1) (mk_val y1)) eqn:H'; intros; trivial.
    exfalso.
    rewrite Word.eqb_correct in H'.
    unfold mk_val, Word.repr in H'. injection H'. clear H'. intros H'.
    rewrite ? Zmod_small in H' by (clear H'; rewrite <- Word.Z'of_nat_power2; zify; omega).
    zify; omega.
  Qed.

  Lemma Word'leb_faithful x1 y1:
    x1 < n -> y1 < n ->
    (Word.le (mk_val x1) (mk_val y1))%bool = NPeano.Nat.leb x1 y1.
  Proof.
    intros.
    consider (NPeano.Nat.leb x1 y1); intros.
    rewrite Word.zify_le. simpl.
    rewrite ? Zmod_small by (rewrite <- Word.Z'of_nat_power2; zify; omega). zify; omega.
    assert (~ (Word.val (mk_val x1)) <= Word.val (mk_val y1))%Z. simpl.
    rewrite ? Zmod_small by (rewrite <- Word.Z'of_nat_power2; zify; omega). zify; omega.
    rewrite <- Word.zify_le in H2.
    destruct (Word.le (mk_val x1) (mk_val y1)); congruence.
  Qed.

  Lemma Rsp3_push  (y : nat)  s:
    y < n ->
    (forall x, List.In x s -> x < n) ->
    (forall x, y = x \/ List.In x s -> x < n).
  Proof.
    intros. destruct H; intuition.
  Qed.

                          (****************)
                          (* MAIN THEOREM *)
                          (****************)

  (** * Final theorem: simulation relation for the stack machine *)
  Theorem circuit_correct m1 m2 (Hcode : R_code m1 m2) :
           m1 == m2 ->
    forall m1',
    Spec.step n m1 = Some m1' ->
    match step (Circuit.Code size V) m2 with
      | None => False
      | Some m2' => m1' == m2'
    end.
  Proof.
    intros H m1' Hm1.
    unfold Next. unfold Circuit.Code, Circuit.code.
    erewrite step_code_at by eassumption.  Opaque Circuit.case.
    intro_do i Hi.
    rewrite step_case.

    2: (destruct H as [H1];
        refine (let H := Hcode (Spec.pc m1) _ in _);
        [ eauto |  rewrite Hi in H; tauto]).

    destruct i; unfold case, type_eq;
    repeat match goal with
             | |- context [Word.eqb ?x ?y] => replace (Word.eqb x y) with true by reflexivity
             |  |- context [Word.eqb ?x ?y] => replace (Word.eqb x y) with false by reflexivity
           end.
    - (** Iconst *)
      t.
      Hint Resolve push_correct_stk.
      constructor; simpl; auto with *; eauto.

      intros. destruct H3. subst.  omega.
      apply (Rsp3 _ _ H). auto.
      apply H.

    - (** Ivar *)
      t.

      {constructor; simpl; auto with *.
       + apply push_correct_stk; (try apply H; auto).
       + intros y [H' | H']. apply Rstr2 with (x := x) in H. omega. apply H; auto.
       + apply H.
       + apply H.
      }

    - (** Isetvar *)
      t.
      constructor;simpl; auto with *.
      + apply (pop_correct_stk n s) . rewrite <- Heqs. destruct H.  simpl in *; eauto.
      + eauto.
      + eauto with stack.
      + unfold R_str. simpl.
        intros.
        unfold Spec.update.
        consider (NPeano.Nat.eqb x i); intros; subst.
        * rewrite Regfile.gss.
          eapply stk_1; eauto.  rewrite Word.eqb_correct. reflexivity.
        * rewrite Regfile.gso. apply H; auto.
          change (Word.repr size (Z.of_nat x)) with (mk_val x). rewrite (Word'eqb_faithful x i); auto.
          consider (NPeano.Nat.eqb x i); congruence; auto.
      + unfold R_str. simpl.
        intros i.
        unfold Spec.update.
        consider (NPeano.Nat.eqb x i); intros; subst.
        * eapply Rsp3; eauto.  rewrite Heqs. simpl. intuition.
        * eapply Rstr2; eauto.

    - t.
      {
        constructor; simpl; auto with * ; try (solve [apply H]).
        + intros.
          eapply push_correct_stk.
          pose ( I := stk_1 m1 m2 n (n0::l) H Heqs). simpl in I. rewrite <- I. clear I.
          pose ( I := stk_2 m1 m2 n n0 l H Heqs). simpl in I. rewrite <- I. clear I.
          rewrite plus_comm. apply Rval_add.

          eauto.

          replace (List.length l) with (List.length (Spec.stk m1) - 2).
          simpl. rewrite (Rval_sub _ 2). f_equal. destruct H; simpl in *; eauto. rewrite Heqs. simpl. omega. rewrite Heqs. simpl. omega. omega.
        + eauto.
        + apply Rsp3_push; auto.   eauto with stack.

      }
    - (** Isub *)
      t.
      {
        constructor; simpl; auto with *.
        + intros.  eapply push_correct_stk.
          pose ( H' := stk_1 m1 m2 n (n0::l) H Heqs). simpl in H'. rewrite <- H'. clear H'.
          pose ( H' := stk_2 m1 m2 n n0 l H Heqs). simpl in H'. rewrite <- H'. clear H'.
          apply Rval_sub.
          auto.
          eauto.
          replace (List.length l) with (List.length (Spec.stk m1) - 2).
          simpl. rewrite (Rval_sub _ 2). f_equal. destruct H. simpl in *. eauto. rewrite Heqs. simpl. omega. rewrite Heqs. simpl. omega.  omega.
        + eauto.
        + eapply Rsp3_push; auto. assert (n0 < t.n). intuition. apply Rsp6. rewrite Heqs. simpl; intuition. omega.
          eauto with stack.
        + apply H.
        + apply H.
      }
    -  (** Branch_forward *)
      t.
        constructor; simpl; auto with *; eauto with *. apply H.
    -                           (* branch backward *)
      t. constructor; simpl; auto with *; eauto with *. apply H.
    - destruct c;
      repeat match goal with
             | |- context [Word.eqb ?x ?y] => replace (Word.eqb x y) with true by reflexivity
             |  |- context [Word.eqb ?x ?y] => replace (Word.eqb x y) with false by reflexivity
           end;
      apply branch_cond_correct; auto.
      + intros. simpl.

        rewrite <- H2, <- H3. apply Word'eqb_faithful; auto.
      + intros; simpl.
        f_equal. rewrite <- H2, <- H3. apply Word'eqb_faithful; auto.
      + intros; simpl.
        rewrite <- H2, <- H3.
         apply Word'leb_faithful; auto.
      + intros; simpl.
        rewrite <- H2, <- H3.
        replace (Word.lt (mk_val y1) (mk_val x1)) with (negb (Word.le (mk_val x1) (mk_val y1))).
        f_equal. apply Word'leb_faithful; auto.
        consider (Word.le (mk_val x1) (mk_val y1)); intros;simpl;
        consider (Word.lt (mk_val y1) (mk_val x1)); intros;simpl; try reflexivity.
        omega.
        omega.

    - simpl.
      unfold Spec.step in Hm1; rewrite Hi in Hm1; simpl in Hm1; unfold Spec.dyncheck in Hm1; simpl in Hm1. discriminate.
  Qed.

  (** Sanity check: we verify that the only axiom we depend on is
  functional extensionality (which comes from being used in the
  definition of Word) *)

  Print Assumptions circuit_correct.
End t.

Require Compiler.
Require Import FirstOrder RTL Core.

Definition t := (Compiler.Fesic _ _ (Circuit.Code 8)).


Require Import Reals.
Require Import Flocq.Core.Fcore.
Require Import Gappa_tactic.
Open Scope R_scope.

Definition floor := rounding_fixed rndDN 0.

Goal forall x y,
  floor x = floor y ->
  2 <= sqrt (4 + Rsqr (x - y)) <= 9/4.
Proof.
unfold floor, Rsqr.
gappa.
Qed.


Require Import Sequences.
Require Import FiniteOrderMeasure.
Require Import CPO.

Module Type ProductiveFuncMod (C1 C2 : FiniteOrderMeasureMod).

Module Export CPO1 :=CPOMod C1.
Module Export CPO2 :=CPOMod C2.

Parameter fc : C1.Cc -> C2.Cc.

Parameter fc_mono :
  forall x y,  C1.ordc x y -> C2.ordc (fc x) (fc y).

Lemma increasing_image :
  forall q,  increasing C1.ordc q ->
               increasing  C2.ordc (fun n =>  fc (q n)).
Proof.
intros q Hi n.
apply fc_mono, Hi.
Qed.

Parameter fc_prod : forall (q: Seq (A := C1.Cc))(Hi : increasing C1.ordc q),
    CPO1.is_cls(CPO1.lim (fun n => CPO1.elt (q n))
                         (CPO1.map_elt_increasing _ Hi)) ->
    CPO2.is_cls(CPO2.lim (fun n => CPO2.elt (fc (q n)))
               (CPO2.map_elt_increasing  _ (increasing_image _ Hi))).

End ProductiveFuncMod.

Module FuncDefMod(C1 C2: FiniteOrderMeasureMod)
       (PF : ProductiveFuncMod C1 C2).
Import PF.

Lemma fc_prod_asc : forall (q: Seq (A := C1.Cc)), ascending C1.ordc q ->
                            ascending C2.ordc (fun n => fc (q n)).
Proof.
intros q Hasc.
destruct Hasc as (Hi & Hns).
apply (CPO1.lim_ascending_is_cls _ Hi) in Hns.
apply fc_prod in Hns.
now apply CPO2.lim_is_cls_ascending  in Hns.
Qed.

Theorem indep_rep : forall (q1 q2 : Seq(A := C1.Cc)),
    ascending C1.ordc q1-> ascending C1.ordc q2 -> CPO1.SEM.ssim q1 q2 ->
    CPO2.SEM.ssim (fun n => fc (q1 n))  (fun n => fc (q2 n)).
Proof.
intros q1 q2 Ha1 Ha2 Hs.
apply CPO2.sovertaken_ssim.
*
  now apply fc_prod_asc.
*
  now apply fc_prod_asc.
*
  intro n.
  generalize Ha1; intros (Hi1  & _).
  remember (CPO1.lim (fun n => CPO1.elt (q1 n)) (CPO1.map_elt_increasing _ Hi1))
    as l1.
  generalize Ha2; intros (Hi2  & _).
  remember (CPO1.lim (fun n => CPO1.elt (q2 n)) (CPO1.map_elt_increasing _ Hi2))
    as l2.
  assert(Heq : l1 = l2).
  {
    rewrite Heql1, Heql2.
    erewrite (CPO1.eqv_same_lim) with (q2 := q2) (Hi2:= Hi2); auto.
    *
      now destruct Ha1 as ( _ & Hs1).
    *
      now destruct Ha2 as ( _ & Hs2).
  }
  assert (Hc : CPO1.is_cls l1).
  {
    rewrite Heql1.
    apply  CPO1.lim_ascending_is_cls.
     now destruct Ha1 as ( _ & Hs1).
  }
  assert (Hex: exists n0 : nat, C1.ordc (q1 n) (q2 n0)).
  {
    eapply CPO1.same_lim_overtakes.
    *
      now destruct Ha1 as (_ & Hn).
    *
      now destruct Ha2 as (_ & Hn).
    *
      now rewrite <- Heql1, <- Heql2.
  }
  destruct Hex as (m & Hord).
  exists m.
  now apply fc_mono.
Qed.

Definition f (x : CPO1.C) : CPO2.C :=
  match x with
    CPO1.elt e => CPO2.elt (fc e)
  | CPO1.cls c => let (q,Ha) := CPO1.EC.representative c in
                  (CPO2.cls (CPO2.EC.class_of
                               (exist  _
                                       (fun n => fc (q n))
                                (fc_prod_asc _ Ha))))
  end.
End FuncDefMod.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma lem : forall (x : lst) (y : natural), eq (rev (append x (Cons y Nil))) (Cons y (rev x)).
Proof.
induction x.
- intros. simpl. rewrite IHx. reflexivity.
- intros. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst) (z : natural), eq (rev (append x (append y (Cons z Nil)))) (Cons z (rev (append x y))).
Proof.
induction x.
- intros. simpl. rewrite IHx. reflexivity.
- intros. simpl. lfind. Admitted.


Inductive empty := .

Inductive typ : Type :=
| typ_arr : typ -> typ -> typ
| typ_nat : typ.

Notation "τ --> σ" := (typ_arr τ σ) (at level 8, right associativity).

(* Binders are represented in nested abstract syntax.

   In short, terms are parametrized by the type X of their free variables.
   Then, e.g. when we open a lambda, its body is a [tm (option X)]: [None] is
   the additional variable bound by the lambda, and [Some x] is an other free
   variable of type X.

   It can be seen as a well-typed De Bruijn representation.
*)

Notation "^ f" := (option_map f)  (at level 5, right associativity).
Notation "^ X" := (option X) : type_scope.

Inductive tm (X : Type) : Type :=
| tm_var : X -> tm X
| tm_app : tm X -> tm X -> tm X
| tm_lam : typ -> tm ^X -> tm X
| tm_zero : tm X
| tm_succ : tm X -> tm X
| tm_nrec : typ -> tm X -> tm ^^X -> tm X -> tm X.

Notation "# x" := (tm_var _ x) (at level 10).
Notation "t $ u" := (tm_app _ t u) (at level 10).
Notation "'λ' [ τ ] u" := (tm_lam _ τ u) (at level 10).
Notation Z := (tm_zero _).
Notation S := (tm_succ _).
Notation "'rec' [ τ ] ( e0 , e1 )" := (tm_nrec _ τ e0 e1) (at level 10).

Reserved Notation "% f" (at level 5, right associativity).

(* Renaming *)
Fixpoint tm_map {X Y : Type} (f : X -> Y) (t : tm X) : tm Y :=
  match t with
  | # x => # (f x)
  | u $ v => (%f u) $ (%f v)
  | λ [τ] u => λ [τ] (%^f u)
  | Z => Z
  | S u => S (%f u)
  | rec [τ] (e0, e1) e => rec [τ] (%f e0, %^^f e1) (%f e)
  end
where "% f" := (tm_map f).

Definition f_lift {X Y : Type} (f : X -> tm Y) : ^X -> tm ^Y :=
  fun o =>
    match o with
    | None => # None
    | Some t => %Some (f t)
    end.

(* Parallel substitution *)
Fixpoint tm_bind {X Y : Type} (t : tm X) (f : X -> tm Y) : tm Y :=
  match t with
  | # x => f x
  | u $ v => (tm_bind u f) $ (tm_bind v f)
  | λ [τ] u => λ [τ] (tm_bind u (f_lift f))
  | Z => Z
  | S u => S (tm_bind u f)
  | rec [τ] (e0, e1) e => rec [τ] (tm_bind e0 f, tm_bind e1 (f_lift (f_lift f))) (tm_bind e f)
  end.

Notation "'lift'" := %(@Some _) (at level 1).

(* Substitution of the "first" free variable *)
Definition tm_head_subst {X : Type} (t : tm ^X) (u : tm X) : tm X :=
  tm_bind t (fun x => match x with None => u | Some u => # u end).

Notation "t <- u" := (tm_head_subst t u) (at level 50).

(* Substitution of the two first free variables *)
Definition tm_head_subst2 {X : Type} (t : tm ^^X) (u : tm X) (v : tm X) : tm X :=
  tm_bind t (fun x => match x with None => u | Some None => v | Some (Some u) => # u end).

Notation "t <<- ( u , v )" := (tm_head_subst2 t u v) (at level 50).

(* Small-step operational semantics *)

(* This is a bit meh *)
Fixpoint is_value {X : Type} (t : tm X) : bool :=
  match t with
  | λ [_] _ | Z => true
  | S u => is_value u
  | _  => false
  end.

Definition value {X} (t : tm X) : Prop := is_true (is_value t).

Lemma value_succ {X : Type} : forall (t : tm X), value t <-> value (S t).
Proof.
  intros. split; unfold value, is_value, is_true in *; tauto.
Qed.

Ltac value := compute; reflexivity.
Ltac valueH H := compute in H; congruence.

Inductive step {X : Type} : tm X -> tm X -> Prop :=
| step_beta : forall (τ : typ) (v : tm X) (u : tm ^X),
    value v ->
    step ((λ [τ] u) $ v) (u <- v)
| step_app1 : forall (u1 u2 v : tm X),
    step u1 u2 ->
    step (u1 $ v) (u2 $ v)
| step_app2 : forall (u v1 v2 : tm X),
    value u ->
    step v1 v2 ->
    step (u $ v1) (u $ v2)
| step_succ : forall (u1 u2 : tm X),
    step u1 u2 ->
    step (S u1) (S u2)
| step_rec : forall τ (e0 : tm X) (e1 : tm ^^X) (e e' : tm X),
    step e e' ->
    step (rec [τ] (e0, e1) e) (rec [τ] (e0, e1) e')
| step_rec_zero : forall τ (e0 : tm X) (e1 : tm ^^X),
    step (rec [τ] (e0, e1) Z) e0
| step_rec_succ : forall τ (e0 : tm X) (e1 : tm ^^X) (e : tm X),
    value e ->
    step (rec [τ] (e0, e1) (S e)) (e1 <<- (rec [τ] (e0, e1) e, e)).

(* Type-system *)

(* A typing environment *)
Definition env X := X -> typ.

Definition env_empty : env empty := empty_rect _.

Definition env_cons {X : Type} (τ : typ) (Γ : env X) : env ^X :=
  fun x =>
    match x with
    | None => τ
    | Some y => Γ y
    end.

Notation "Γ & τ" := (env_cons τ Γ) (at level 1).

Reserved Notation "Γ |- t :~ τ" (at level 60).

Inductive typing {X : Type} (Γ : env X) : tm X -> typ -> Prop :=
| typing_var : forall x,
    Γ |- # x :~ Γ x
| typing_app : forall u v τ σ,
    Γ |- u :~ τ --> σ ->
    Γ |- v :~ τ ->
    Γ |- (u $ v) :~ σ
| typing_lam : forall u τ σ,
    (Γ & τ) |- u :~ σ ->
    Γ |- (λ [τ] u) :~ (τ --> σ)
| typing_zero :
    Γ |- Z :~ typ_nat
| typing_succ : forall u,
    Γ |- u :~ typ_nat ->
    Γ |- (S u) :~ typ_nat
| typing_rec : forall τ e0 e1 e,
    Γ |- e0 :~ τ ->
    (Γ & typ_nat & τ) |- e1 :~ τ ->
    Γ |- e :~ typ_nat ->
    Γ |- (rec [τ] (e0, e1) e) :~ τ
where "Γ |- t :~ τ" := (@typing _ Γ t τ).

(* Progress *)

Lemma typing_nat_value {X : Type} : forall (Γ : env X) e,
  value e ->
  Γ |- e :~ typ_nat ->
  e = Z \/ (exists e', value e' /\ e = S e').
Proof.
  intros ? ? Hv H.
  inversion H; subst; try (valueH Hv).
  - left. reflexivity.
  - right. eexists. split.
    { apply value_succ. eassumption. }
    { reflexivity. }
Qed.

Lemma progress : forall (t : tm empty) (τ : typ),
  env_empty |- t :~ τ ->
  value t \/ exists t', step t t'.
Proof.
  generalize env_empty. remember (empty : Type).
  induction 1; subst X; try tauto; try (left; value).
  { right.
    specialize (IHtyping1 eq_refl). specialize (IHtyping2 eq_refl).
    destruct u as [?|?|?|?|?| τ' e0 e1 e ].
    - inversion H. tauto.
    - destruct IHtyping1 as [ Hv | [t' Ht'] ]; [ valueH Hv |].
      eexists. apply step_app1. apply Ht'.
    - destruct IHtyping2 as [ ? | [t' Ht'] ].
      { eexists. apply step_beta. assumption. }
      { eexists. apply step_app2. value. eassumption. }
    - inversion H.
    - inversion H.
    - destruct IHtyping1 as [ Hv | [t' Ht'] ]; [ valueH Hv |].
      eexists. apply step_app1. eassumption. }
  { specialize (IHtyping eq_refl).
    destruct IHtyping as [ ? | [t' Ht'] ].
    - left. apply value_succ. assumption.
    - right. eexists. apply step_succ. eassumption. }
  { right.
    specialize (IHtyping1 eq_refl). specialize (IHtyping3 eq_refl). clear IHtyping2. (* humm *)
    destruct IHtyping3 as [ Hv | [t' Ht'] ].
    - { destruct (typing_nat_value _ _ Hv H1) as [ HeZ | [e' [Hve' HeS]] ].
        - rewrite HeZ in *. eexists. apply step_rec_zero.
        - rewrite HeS in *. eexists. apply step_rec_succ. assumption. }
    - eexists. apply step_rec. eassumption. }
Qed.

(* Substitution preserves typing *)

Lemma weakening :
  forall (X : Type) (Γ : env X) (t : tm X) (τ : typ),
  Γ |- t :~ τ ->
  forall Y (f : X -> Y) Γ', (forall x, Γ' (f x) = Γ x) ->
  Γ' |- %f t :~ τ.
Proof with auto.
  do 4 intro. intro H. induction H; simpl; intros ? ? ? W; try constructor...
  - rewrite <-W. constructor.
  - econstructor. apply IHtyping1... apply IHtyping2...
  - apply IHtyping. intros [|]; simpl...
  - apply IHtyping2. intros [[|]|]; simpl...
Qed.

Lemma weakening_one :
  forall (X : Type) (Γ : env X) (t : tm X) (τ σ : typ),
  Γ |- t :~ τ ->
  Γ & σ |- lift t :~ τ.
Proof.
  intros. apply weakening with Γ. assumption. reflexivity.
Qed.

Lemma substitution :
  forall (X : Type) (Γ : env X) (t : tm X) (τ : typ),
    Γ |- t :~ τ ->
    forall (Y : Type) (f : X -> tm Y) Γ',
      (forall x, Γ' |- f x :~ Γ x) ->
      Γ' |- (tm_bind t f) :~ τ.
Proof with auto.
  intros X Γ t τ H. induction H; intros ? ? ? Hf; simpl; try constructor...
  - apply typing_app with τ.
    + apply IHtyping1...
    + apply IHtyping2...
  - apply IHtyping. intros [|]; simpl; try constructor.
    apply weakening_one...
  - apply IHtyping2. intros [[|]|]; simpl; try constructor.
    do 2 apply weakening_one...
Qed.

(* Reduction preserves typing *)

Lemma preservation : forall (X : Type) (t t' : tm X) (Γ : env X) (τ : typ),
  Γ |- t :~ τ ->
  step t t' ->
  Γ |- t' :~ τ.
Proof with eauto.
  do 5 intro. intro H. revert t'. induction H; intros t' Hstep; try (solve [ inversion Hstep ]).
  { inversion Hstep; subst.
    - inversion H; subst. eapply substitution. apply H2.
      intros [|]. simpl. constructor. simpl. assumption.
    - econstructor...
    - econstructor... }
  { inversion Hstep; subst. constructor... }
  { inversion Hstep; subst.
    - constructor...
    - assumption.
    - eapply substitution. eassumption.
      inversion H1; subst.
      intros [[|]|]; simpl. constructor. assumption. constructor... }
Qed.


Require Import SfLib.
Require Import LibTactics.
Require Import Types.
Require Import Smallstep.
Require Import Stlc.
Require Import STLCWA.

Module STLCEXTENDED.

Inductive ty : Type :=
    | TNat : ty
    | TArrow : ty -> ty -> ty
    | TProd : ty -> ty -> ty
    | TSum : ty -> ty -> ty
    | TUnit : ty
    | TList : ty -> ty.

    Hint Constructors ty.

Inductive tm : Type :=
    | tvar : id -> tm
    | tabs : id -> ty -> tm -> tm
    | tapp : tm -> tm -> tm
    | tnat : nat -> tm
    | tsucc : tm -> tm
    | tpred : tm -> tm
    | tmult : tm -> tm -> tm
    | tif0 : tm -> tm -> tm -> tm
    | tlet : id -> tm -> tm -> tm
    | tpair : tm -> tm -> tm
    | tfst : tm -> tm
    | tsnd : tm -> tm
    | inl : ty -> tm -> tm
    | inr : ty -> tm -> tm
    | scase : tm -> id -> tm -> id -> tm -> tm
    | unit : tm
    | tnil : ty -> tm
    | tcons : tm -> tm -> tm
    | lcase : tm -> tm -> id -> id -> tm -> tm
    | tfix : tm -> tm.

    Hint Constructors tm.

Print update.

    Reserved Notation "Gamma '|=' t '\in' T" (at level 40).

Inductive has_type : Context -> tm -> ty -> Prop :=
    | tyVar :
        forall i T G,
            byContext G i = Some T ->
            G |= tvar i \in T
    | tyAbs :
        forall i x T G Gamma,
            update i T Gamma |= x \in G ->
            Gamma |= tabs i T x \in TArrow T G
    | tyApp :
        forall abs arg U V G,
            G |= abs \in TArrow U V ->
            G |= arg \in U ->
            G |= tapp abs arg \in V
    | tyNat :
        forall n G,
            G |= tnat n \in TNat
    | tySucc :
        forall x G,
            G |= x \in TNat ->
            G |= tsucc x \in TNat
    | tyPred :
        forall x G,
            G |= x \in TNat ->
            G |= tpred x \in TNat
    | tyMult :
        forall x y G,
            G |= x \in TNat ->
            G |= y \in TNat ->
            G |= tmult x y \in TNat
    | tyIf :
        forall t t0 t1 G T,
            G |= t0 \in T ->
            G |= t1 \in T ->
            G |= t \in TNat ->
            G |= tif0 t t0 t1 \in T
    | tyLet :
        forall i x g G T U,
            update i U G |= x \in T ->
            G |= g \in U ->
            G |= tlet i g x \in T
    | tyPair :
        forall x y U V G,
            G |= x \in U ->
            G |= y \in V ->
            G |= tpair x y \in TProd U V
    | tyFst :
        forall x G U V,
            G |= x \in TProd U V ->
            G |= tfst x \in U
    | tySnd :
            forall x G U V,
                G |= x \in TProd U V ->
                G |= tsnd x \in V
    | tySum0 :
        forall x U V G,
            G |= x \in U ->
            G |= inl V x \in TSum U V
    | tySum1 :
        forall y U V G,
            G |= y \in V ->
            G |= inr U y \in TSum U V
    | tySCase :
        forall i j matched U V lft rgt G T,
            update i U G |= lft \in T ->
            update j V G |= rgt \in T ->
            G |= matched \in TSum U V ->
            G |= scase matched i lft j rgt \in T
    | tyUnit :
        forall G,
            G |= unit \in TUnit
    | tyNil :
        forall G T,
            G |= tnil T \in TList T
    | tyCons :
        forall x y G T,
            G |= x \in T ->
            G |= y \in TList T ->
            G |= tcons x y \in TList T
    | tyLCase :
        forall casenil caselist matched i j T U  G,
            G |= casenil \in U ->
            i <> j ->
            update i T
                (update j (TList T) G) |= caselist \in U ->
            G |= matched \in TList T ->
            G |= lcase matched casenil i j caselist \in U
    | tyFix :
        forall x G T,
            G |= x \in TArrow T T ->
            G |= tfix x \in T
    where "Gamma '|=' t '\in' T " := (has_type Gamma t T).

    Hint Constructors has_type.

Inductive value : tm -> Prop :=
    | vnat : forall i,
        value (tnat i)
    | vabs : forall x T v,
        value (tabs x T v)
    | vprod : forall x y,
        value x ->
        value y ->
        value (tpair x y)
    | vsum0 : forall x T,
        value x ->
        value (inl T x)
    | vsum1 : forall x T,
        value x ->
        value (inr T x)
    | vunit :
        value unit
    | vnil :
        forall T,
        value (tnil T)
    | vcons :
        forall x y,
        value x ->
        value y ->
        value (tcons x y).

    Hint Constructors value.

    Print tm.

Reserved Notation "'[' x ':=' s ']' t" (at level 20).
Fixpoint subst (x : id) (s : tm) (org : tm) : tm :=
    match org with
        | tvar i => if (eq_id_dec x i) then s else org
        | tabs t T v => tabs t T (if(eq_id_dec t x) then v else ([x := s] v))
        | tapp a b => tapp ([x := s] a) ([x := s] b)
        | tsucc n => tsucc ([x := s] n)
        | tpred n => tpred ([x := s] n)
        | tmult a b => tmult ([x := s] a) ([x := s] b)
        | tif0 t t0 t1 => tif0 ([x := s] t) ([x := s] t0) ([x := s] t1)
        | tlet t u v => if(eq_id_dec t x) then tlet t ([x := s] u) v else tlet t ([x := s] u) ([x := s] v)
        | tpair a b => tpair ([ x:= s] a) ([x := s] b)
        | tfst t => tfst ([x := s] t)
        | tsnd t => tsnd ([x := s] t)
        | inl T v => inl T ([x := s] v)
        | inr T v => inr T ([x := s] v)
        | scase m ia lft ib rgt =>
            scase ([x := s] m) ia (if (eq_id_dec ia x) then lft else [x := s] lft)
                               ib (if (eq_id_dec ib x) then rgt else [x := s] rgt)
        | tcons a b => tcons ([x := s] a) ([x := s] b)
        | lcase m cn ihead itail cl =>
            lcase ([x := s] m) ([ x:= s] cn) ihead itail
                (if eq_id_dec ihead x then cl else
                    if eq_id_dec itail x then cl else [x:= s] cl)
        | tfix v => tfix ([x := s] v)
        | _ => org
        end
        where "'[' x ':=' s ']' t" := (subst x s t).

        Hint Constructors value.

Print tm.

Reserved Notation "t '==>' t'" (at level 40).

Inductive step : tm -> tm -> Prop :=
    | stApp1 :
        forall x y x',
            x ==> x' ->
            tapp x y ==> tapp x' y
    | stApp2 :
        forall x y y',
            value x ->
            y ==> y' ->
            tapp x y ==> tapp x y'
    | stApp :
        forall i x y T,
            value y ->
            tapp (tabs i T x) y ==> ([i := y] x)
    | stSucc0 :
        forall x x',
            x ==> x' ->
            tsucc x ==> tsucc x'
    | stSucc1 :
        forall x,
            tsucc (tnat x) ==> tnat (S x)
    | stPred0 :
        forall x x',
            x ==> x' ->
            tpred x ==> tpred x'
    | stPred1 :
        forall x,
            tpred (tnat x) ==> tnat (pred x)
    | stMult0 :
        forall x x' y,
            x ==> x' ->
            tmult x y ==> tmult x' y
    | stMult1 :
        forall x y y',
            value x ->
            y ==> y' ->
            tmult x y ==> tmult x y'
    | stMult2 :
        forall a b,
            tmult (tnat a) (tnat b) ==> tnat (a * b)
    | stIf:
        forall t t' t1 t2,
            t ==> t' ->
            tif0 t t1 t2 ==> tif0 t' t1 t2
    | stIf0 :
        forall t1 t2,
            tif0 (tnat 0) t1 t2 ==> t1
    | stIf1 :
        forall i t1 t2,
            i <> 0 ->
            tif0 (tnat i) t1 t2 ==> t2
    | stlet0 :
        forall i t t' v,
            t ==> t' ->
            tlet i t v ==> tlet i t' v
    | stlet1 :
        forall i t v,
            value t ->
            tlet i t v ==> [i := t] v
    | stpair0 :
        forall a a' b,
            a ==> a' ->
            tpair a b ==> tpair a' b
    | stpair1 :
        forall a b b',
            value a ->
            b ==> b' ->
            tpair a b ==> tpair a b'
    | stFst0 :
        forall x x',
            x ==> x' ->
            tfst x ==> tfst x'
    | stFst1 :
        forall x y,
            value (tpair x y) ->
            tfst (tpair x y) ==> x
    | stSnd0 :
        forall x x',
            x ==> x' ->
            tsnd x ==> tsnd x'
    | stSnd1 :
        forall x y,
            value (tpair x y) ->
            tsnd (tpair x y) ==> y
    | stinl :
        forall v v' T,
            v ==> v' ->
            inl T v ==> inl T v'
    | stinr :
        forall v v' T,
            v ==> v' ->
            inr T v ==> inr T v'
    | stscase0 :
        forall x x' i lft j rgt,
            x ==> x' ->
            scase x i lft j rgt ==> scase x' i lft j rgt
    | stscasel :
        forall i j v lft rgt T,
            value (inl T v) ->
            scase (inl T v) i lft j rgt ==> [i := v] lft
    | stscaser :
        forall i j v lft rgt T,
            value (inr T v) ->
            scase (inr T v) i lft j rgt ==> [j := v] rgt
    | stcons0 :
        forall x y x',
            x ==> x'->
            tcons x y ==> tcons x' y
    | stcons1 :
        forall x y y',
            value x ->
            y ==> y' ->
            tcons x y ==> tcons x y'

    | stlcase0 :
        forall x x' casenil head tail caselist,
            x ==> x' ->
            lcase x casenil head tail caselist ==>
                lcase x' casenil head tail caselist
    | stlcasen :
        forall head tail casenil caselist T,
            lcase (tnil T) casenil head tail caselist ==>
                casenil
    | stlcasel :
        forall head tail casenil caselist h t,
            value h ->
            value t ->
            lcase (tcons h t) casenil head tail caselist ==>
                ([head := h] ([tail := t] caselist))
    | stlfix0 :
        forall x x',
            x ==> x' ->
            tfix x ==> tfix x'
    | stlfix1 :
        forall x T v,
            tfix (tabs x T v) ==> [x := tfix (tabs x T v)] v
    where "t '==>' t'" := (step t t').

    Hint Constructors step.

Lemma value_cant_step :
    forall u v,
        value u ->
        u ==> v ->
        False.
    intros u v h.
    generalize dependent v.
    induction h; intros; try inversion H; subst; eauto.

Qed.

Ltac value_stepping_false :=
    match goal with
        | [H1: ?X1 ==> ?X2 |- _]
            => assert (value X1) as HHH; eauto;
                destruct (value_cant_step _ _ HHH H1); fail
        end.
Ltac clear_value_stepping :=
    repeat value_stepping_false.

Theorem stlcex_deterministic:
    deterministic step.

    unfold deterministic.
    intros x; induction x;
    try (intros y1 y2 h1 h2;
    inversion h1; inversion h2; subst;
    match goal with
    | [H1 : ?X ==> ?Y, H2 : ?X ==> ?Z |- _] =>
        assert (Y = Z); eauto; subst; eauto
        end);
    try value_stepping_false;
    try (inversion H3; subst; eauto; fail);
    try (inversion H2; subst; eauto; fail).

    inversion H4; subst; eauto.
    inversion H3; inversion H4; subst; eauto.
    inversion H; subst; destruct (H7 eq_refl).
    inversion H5; subst; destruct (H3 eq_refl).
    inversion H6; subst; eauto.
    inversion  H6. inversion H6.
    inversion H6; subst; eauto.
    inversion H. inversion H8.
    inversion H7; subst; eauto.
Qed.

Lemma canonical_form_bools:
    forall t,
        empty |= t \in TNat ->
        value t ->
        exists n, t = tnat n.

    intros t h1 h2; inversion h2; subst; inversion h1; subst; eauto.
Qed.

Lemma canonical_form_fun:
    forall t T U,
        empty |= t \in TArrow T U ->
        value t ->
        exists x v, t = tabs x T v.

    intros t T U h1 h2; inversion h2; subst; inversion h1; subst; eauto.
Qed.

Print value.
Lemma canonical_form_pair:
    forall t U V,
        empty |= t \in TProd U V ->
        value t ->
        exists a b,
            value a /\ value b /\ t = tpair a b.

            intros t U V h1 h2; inversion h2; subst; inversion h1; subst; eauto; tauto.
Qed.

Lemma canonical_form_sum:
    forall t U V,
        empty |= t \in TSum U V ->
        value t ->
        exists x,
            value x /\ (t = inr U x \/ t = inl V x).

        intros t U V h1 h2; inversion h2; subst; inversion h1; subst; eauto; tauto.
Qed.

Lemma canonical_form_unit:
    forall t,
        empty |= t \in TUnit ->
        value t ->
        t = unit.

        intros t h1 h2; inversion h2; subst; inversion h1; subst; eauto.
Qed.

Lemma canonical_form_list:
    forall t T,
        empty |= t \in TList T ->
        value t ->
        t = tnil T \/ (exists head tail,
                        value head /\ value tail /\ t = tcons head tail).

    intros t T h1 h2; inversion h2; subst; inversion h1; subst;  try tauto.
    right; eauto; tauto.

Qed.

Theorem progress:
    forall t T,
        empty |= t \in T ->
        value t \/ (exists t', t ==> t').

    intros t; induction t; intros;
    inversion H; subst; eauto;
    try (repeat match goal with
    | [H1 : _ -> _ -> value ?X \/ ?H |- _]
        => assert (value X \/ H) as HHH; eauto;
            destruct HHH; generalize H1; clear H1
    end ; intros); try
    (match goal with
        | [ |- value (?X) \/ _ ]
            => assert (value X); eauto; try (tauto; eauto); fail
            end); right;

    repeat (match goal with
        | [H1 : value ?T, H2 : _ |= ?T \in TNat |- _] =>
            inversion H1; subst;inversion H2; subst;
            generalize H1; generalize H2; clear H1; clear H2
        | [H1 : value ?T, H2 : _ |= ?T \in TArrow _ _ |- _] =>
        inversion H1; subst;inversion H2; subst;
        generalize H1; generalize H2; clear H1; clear H2
        | [H1 : value ?T, H2 : _ |= ?T \in TProd _ _ |- _] =>
        inversion H1; subst;inversion H2; subst;
        generalize H1; generalize H2; clear H1; clear H2
        | [H1 : value ?T, H2 : _ |= ?T \in TSum _ _ |- _] =>
        inversion H1; subst;inversion H2; subst;
        generalize H1; generalize H2; clear H1; clear H2
            end); intros; try (esplit; eauto; fail)
    ;
    try (
    repeat (match goal with
    | [ H1 : exists _, _ |- _] => destruct H1
    end); esplit; eauto; fail
    ).

    inversion H; subst. inversion H2.
    destruct i; subst. exists t2; eauto.
    assert (S i <> 0); eauto.
    destruct i; subst. exists t2; eauto.
    assert (S i <> 0); eauto.
    destruct i; subst. exists t2; eauto.
    assert (S i <> 0); eauto.
    destruct i; subst. exists t2; eauto.
    assert (S i <> 0); eauto.

    inversion H1; subst; inversion H10; subst; eauto.
    inversion H1; subst; inversion H10; subst; eauto.
Qed.

(* We need the 'occurs_free' tool again. *)
Print tm.

Inductive occurs_free : id -> tm -> Prop :=
    | occurs_free_var :
        forall i,
            occurs_free i (tvar i)
    | occurs_free_abs :
        forall i j v T,
            i <> j ->
            occurs_free i v ->
            occurs_free i (tabs j T v)
    | occurs_free_app0 :
        forall i a b,
            occurs_free i a ->
            occurs_free i (tapp a b)
    | occurs_free_app1 :
            forall i a b,
                occurs_free i b ->
                occurs_free i (tapp a b)
    | occurs_free_succ :
        forall i x,
            occurs_free i x ->
            occurs_free i (tsucc x)
    | occurs_free_pred :
        forall i x,
            occurs_free i x ->
            occurs_free i (tpred x)
    | occurs_free_mult0:
        forall i a b,
            occurs_free i a ->
            occurs_free i (tmult a b)
    | occurs_free_mult1:
            forall i a b,
                occurs_free i b ->
                occurs_free i (tmult a b)
    | occurs_free_if0 :
        forall i t t0 t1,
            occurs_free i t ->
            occurs_free i (tif0 t t0 t1)
    | occurs_free_if1 :
            forall i t t0 t1,
                occurs_free i t0 ->
                occurs_free i (tif0 t t0 t1)
    | occurs_free_if2 :
            forall i t t0 t1,
                occurs_free i t1 ->
                occurs_free i (tif0 t t0 t1)
    | occurs_free_let0 :
        forall i j x v,
            occurs_free i v ->
            i <> j ->
            occurs_free i (tlet j x v)
    | occurs_free_let1 :
        forall i j x v,
            occurs_free i x ->
            occurs_free i (tlet j x v)
    | occurs_free_pair0:
        forall i a b,
            occurs_free i a ->
            occurs_free i (tpair a b)
    | occurs_free_pair1:
            forall i a b,
                occurs_free i b ->
                occurs_free i (tpair a b)
    | occurs_free_fst:
        forall i x,
            occurs_free i x ->
            occurs_free i (tfst x)
    | occurs_free_snd :
        forall i x,
            occurs_free i x ->
            occurs_free i (tsnd x)
    | occurs_free_inl :
        forall i x T,
            occurs_free i x ->
            occurs_free i (inl T x)
    | occurs_free_inr :
        forall i x T,
            occurs_free i x ->
            occurs_free i (inr T x)
    | occurs_free_scase:
        forall i x u v lft rgt,
            occurs_free i x ->
            occurs_free i (scase x u lft v rgt)
    | occurs_free_scase0:
        forall i x u v lft rgt,
            i <> u ->
            occurs_free i lft ->
            occurs_free i (scase x u lft v rgt)
    | occurs_free_scase1:
        forall i x u v lft rgt,
            i <> v ->
            occurs_free i rgt ->
            occurs_free i (scase x u lft v rgt)
    | occurs_free_cons0:
        forall i h t,
            occurs_free i h ->
            occurs_free i (tcons h t)
    | occurs_free_cons1:
        forall i h t,
            occurs_free i t ->
            occurs_free i (tcons h t)
    | occurs_free_lcase:
        forall i l h t casenil casel,
            occurs_free i l ->
            occurs_free i (lcase l casenil h t casel)
    | occurs_free_lcase0:
        forall i l h t casenil casel,
            occurs_free i casenil ->
            occurs_free i (lcase l casenil h t casel)
    | occurs_free_lcase1:
            forall i l h t casenil casel,
                i <> h ->
                i <> t ->
                occurs_free i casel ->
                occurs_free i (lcase l casenil h t casel)
    | occurs_free_fix:
        forall i x,
            occurs_free i x ->
            occurs_free i (tfix x).

    Hint Constructors occurs_free.
Theorem occurs_dec :
    forall i x,
        {occurs_free i x} + {~occurs_free i x}.

    intros i x; generalize dependent i.
    induction x;
    intro ii;
    repeat (match goal with
        | [Hx : _ -> {_} + {_} |- _] =>
            destruct (Hx ii); generalize Hx; clear Hx
        end);
    intros;
    match goal with
    | [|- {?H} + {~?H}] =>
        try (assert H as HH; eauto; fail);
        try (assert (~H) as HH; eauto; intro HHH; inversion HHH; subst; eauto; fail)
    end.

    intros. destruct (eq_id_dec ii i); subst. left; eauto.
    right; intro h; inversion h; subst; destruct (n eq_refl).

    destruct (eq_id_dec ii i); subst. right; intro HH; inversion HH; subst. destruct (H2 eq_refl).
    left; eauto.
    destruct (eq_id_dec ii i); subst. right; intro HH; inversion HH; subst. destruct (H4 eq_refl).
    eauto.
    left; eauto.

    destruct (eq_id_dec ii i); destruct (eq_id_dec ii i0); subst; eauto. right; intro HH; inversion HH; subst; eauto.
    destruct (eq_id_dec ii i); destruct (eq_id_dec ii i0); subst; eauto. right; intro HH; inversion HH; subst; eauto. right ; intro HH; inversion HH; subst; eauto.
    destruct (eq_id_dec ii i); destruct (eq_id_dec ii i0); subst; eauto. right; intro HH; inversion HH; subst; eauto. right ; intro HH; inversion HH; subst; eauto.
    destruct (eq_id_dec ii i); destruct (eq_id_dec ii i0); subst; eauto;
    try (right; intro HH; inversion HH; subst; eauto; fail);
    try (left; eauto).
Qed.

Definition closed (t : tm) :=
    forall i, ~occurs_free i t.

Lemma occurs_free_in_ctx:
    forall x i G T,
        G |= x \in T ->
        occurs_free i x ->
        exists U, byContext G i = Some U.
    intro x; induction x;
    try (intros i G T h1 h2; inversion h1; inversion h2; subst; eauto; fail
    );
    try (
        intros i0 G T h1 h2; inversion h1; inversion h2; subst;
        repeat (match goal with
            | [H1 : _ -> _ -> _ -> _ |= ?x \in  _ -> occurs_free _ ?x -> _ ,
                H2: _ |= ?x \in _,
                H3 : occurs_free _ ?x |- _ ] =>
                destruct (H1 _ _ _ H2 H3); generalize H1 H2 H3; clear H1 H2 H3
        end) ;intros; cbn in *;
        destruct (eq_id_dec i0 i); subst;
        try (
            match goal with
                | [H1 : ?x <> ?x |- _] => destruct (H1 eq_refl)
            end
        );
        eauto).

    intros. inversion H0 ; inversion H; subst. eauto.
    intros. inversion H0; inversion H; subst; eauto.
    destruct (IHx2 _ _ _ H16 H8). cbn in  *.
    destruct (eq_id_dec i1 i); subst; eauto. destruct (H4 eq_refl).
    intros.
    destruct (IHx3 _ _ _ H17 H8). cbn in  *.
    destruct (eq_id_dec i1 i0); subst; eauto.
    destruct (H4 eq_refl).
    intros. inversion H; inversion H0; subst; eauto.
    destruct (IHx3 _ _ _ H10 H20). cbn in *.
    destruct (eq_id_dec i1 i); destruct (eq_id_dec i1 i0); subst;
    try (match goal with
        | [H1 : ?x <> ?x |- _] => destruct (H1 eq_refl)
    end); eauto.

Qed.

Theorem empty_is_closed:
    forall x T,
        empty |= x \in T ->
        closed x.

    unfold closed; unfold not.
    intro x; induction x;
    try (intros T h1 k h2; inversion h1; inversion h2; subst; eauto; fail);
    try (    intros;
    pose occurs_free_in_ctx as e;
    destruct (e _ _ _ _ H H0); inversion H1).
Qed.

Theorem ctx_swap:
    forall x T U V ,
        U |= x \in T ->
        U =-= V ->
        V |= x \in T.

    intros x T U V h.
    generalize dependent V.
    induction h; try (unfold context_equivalence ; eauto; fail).

    intros. eapply tyVar; eauto. rewrite <- H0; auto.
    intros. eapply tyAbs; eauto.
    assert (update i T Gamma =-= update i T V); eauto.
    eapply update_inc. auto.

    intros. eapply tyLet. eapply IHh1. eapply update_inc. auto.
    eapply IHh2; eauto.

    intros. Print has_type. eapply tySCase; [eapply IHh1 | eapply IHh2 | eapply IHh3].
    eapply update_inc; eauto.
    eapply update_inc; eauto.
    auto.

    intros. eapply tyLCase; eauto. eapply IHh2.
    repeat eapply update_inc; auto.
Qed.

Hint Resolve  occurs_dec contrapositive  : occurs_free_db.

Hint Resolve refl_ctxeq trans_ctxeq ctx_swap update_permute update_shadow : ctx_db.

Lemma non_occurs_free_ctx_add:
forall x i T U G,
    G |= x \in T ->
    ~occurs_free i x ->
    update i U G |= x \in T.

intro x; induction x;
try (intros i T U G hh; inversion hh; subst;  eauto 10 with occurs_free_db
; fail).

intros. eapply tyVar. cbn.
inversion H; subst. destruct (eq_id_dec i i0); subst; eauto.
destruct (H0 (occurs_free_var _)).

intros. inversion H; subst.
destruct (occurs_dec i0 x); destruct (eq_id_dec i0 i); subst;
eapply tyAbs. eapply ctx_swap. eauto. eapply symm_ctxeq. eapply update_shadow.
apply refl_ctxeq. assert (occurs_free i0 (tabs i t x)); eauto. destruct (H0 H1).
eapply ctx_swap. eauto. eapply symm_ctxeq. eapply update_shadow.
apply refl_ctxeq. eapply ctx_swap. eapply (IHx _ _ _ _ H6 n).
eapply update_permute; eauto. apply refl_ctxeq.
intros i T U G h1 h2; inversion h1; subst;
assert (~occurs_free i x1) as hh1; eauto with occurs_free_db;
assert (~occurs_free i x2) as hh2; eauto with occurs_free_db;
assert (~occurs_free i x3) as hh3; eauto with occurs_free_db;
eauto with occurs_free_db.

intros i0 T U G h1 h2; inversion h1; subst; eauto with occurs_free_db; eauto with ctx_db; eauto with occurs_free_db.
assert (~occurs_free i0 x1) as hh1; eauto with occurs_free_db.
destruct (eq_id_dec i0 i); subst; eapply tyLet; eauto with ctx_db.
eapply ctx_swap. apply H4. eapply symm_ctxeq. eapply update_shadow.
eapply refl_ctxeq. eauto.
assert (~occurs_free i0 x2); eauto 10 with occurs_free_db.
forwards : IHx2; eauto 5 with ctx_db. eapply ctx_swap; eauto with ctx_db.
eapply update_permute; eauto. eapply refl_ctxeq.

intros. assert (~occurs_free i1 x1); eauto with occurs_free_db.
inversion H; subst.
Print has_type.
eapply tySCase; eauto with occurs_free_db.
destruct (eq_id_dec i1 i); subst; eauto with ctx_db.
Print symm_ctxeq.
eapply ctx_swap;  eauto 10 using symm_ctxeq with ctx_db. eapply symm_ctxeq; eauto with ctx_db.
eapply update_shadow. eapply refl_ctxeq.
assert (~occurs_free i1 x2); eauto with occurs_free_db.
eapply ctx_swap; try eapply update_permute; eauto.
eapply refl_ctxeq.
destruct (eq_id_dec i0 i1); subst.
eapply ctx_swap; eauto using update_shadow.
eapply symm_ctxeq; eapply update_shadow; eapply refl_ctxeq.
eapply ctx_swap; try eapply update_permute.
eapply IHx3; eauto with occurs_free_db. eauto. eapply refl_ctxeq.

intros. inversion H; subst. eapply tyLCase; eauto with occurs_free_db.
destruct (eq_id_dec i i1); subst.
eapply ctx_swap; try eapply update_permute.
eapply ctx_swap; try eapply update_inc. eapply ctx_swap ; try eapply update_permute; eauto.
eapply refl_ctxeq. eapply symm_ctxeq; eapply update_shadow.
eapply refl_ctxeq. eauto. eapply refl_ctxeq.
destruct (eq_id_dec i1 i0); subst.
eapply ctx_swap; try eapply update_inc; eauto.
eapply symm_ctxeq; eapply update_shadow. eapply refl_ctxeq.
assert (~occurs_free i1 x3); eauto with occurs_free_db.
pose (IHx3 _ _ U _ H10 H1).
assert (update i T0 (update i1 U (update i0 (TList T0) G)) |= x3 \in T).
eapply ctx_swap; try eapply update_permute; eauto.
eapply refl_ctxeq.
eapply ctx_swap; try eapply update_inc; eauto.
eapply update_permute. eauto. eapply refl_ctxeq.

Qed.

Theorem empty_is_strong :
    forall G t T,
        empty |= t \in T ->
        G |= t \in T.

    intro G; induction G; eauto.
    intros. pose (empty_is_closed _ _ H).
    unfold closed in *.
    pose (c i).
    eapply non_occurs_free_ctx_add; eauto.
Qed.

Lemma app_preserv:
    forall t x y T G U,
        U |= tabs x T t \in TArrow T G ->
        empty |= y \in T ->
        U |= [x := y] t \in G.

    intro t; induction t; eauto;
    cbn; intros x y T G U h1 h2;
    try (inversion h1; subst;
    try match goal with
        | [H1: update _ _ _ |= _ \in _ |- _] =>
    inversion H1;subst; eauto 10
    end; fail).

    intros. inversion h1; subst.
    unfold subst. inversion H1; subst.
    cbn in *.
    destruct (eq_id_dec i x); destruct (eq_id_dec x i); subst;
    try match goal with
        | [H1 : ?x <> ?x |- _] => destruct (H1 eq_refl)
        end.
    inversion H2; subst;eauto. eapply empty_is_strong; eauto.
    eauto.

    cbn; intros. inversion h1; subst. inversion H1; subst.
    destruct (eq_id_dec i x); subst. eapply tyAbs. eapply ctx_swap; try eapply update_shadow.
    eauto. eapply refl_ctxeq. eapply tyAbs. eapply IHt; eauto.
    eapply tyAbs; eapply ctx_swap ; try eapply update_permute; eauto.
    eapply refl_ctxeq.

    inversion h1; subst. inversion H1; subst.
    destruct (eq_id_dec i x); subst; eauto 10;
    eapply tyLet. eapply ctx_swap; try eapply update_shadow; eauto.
    eapply refl_ctxeq.
    eauto. eapply IHt2. eapply tyAbs. eapply ctx_swap; try eapply update_permute; eauto.
    eapply refl_ctxeq. eapply empty_is_strong; eauto.
    eapply IHt1; eauto.

    inversion h1; subst. inversion H1; subst; eauto.
    eapply tySCase; eauto. destruct (eq_id_dec i x); subst.
    eapply ctx_swap; try eapply update_shadow; eauto. eapply refl_ctxeq.
    eapply IHt2. eapply tyAbs; eauto. eapply ctx_swap; try eapply update_permute;eauto.
    eapply refl_ctxeq; eauto. eauto.
    destruct (eq_id_dec i0 x); subst; eauto.
    eapply ctx_swap; try eapply update_shadow; eauto. eapply refl_ctxeq.
    eapply IHt3; eauto. eapply tyAbs; eauto. eapply ctx_swap; try eapply update_permute; eauto 10.
    eapply refl_ctxeq.

    inversion h1; subst. inversion H1; subst; eapply tyLCase; destruct (eq_id_dec i x); subst; eauto.
    eapply ctx_swap; try (eapply symm_ctxeq; eapply update_shadow); eauto.
    eapply trans_ctxeq. eapply update_inc. eapply update_permute; eauto.
    eapply refl_ctxeq. eapply update_shadow. eapply refl_ctxeq.
    destruct (eq_id_dec i0 x); subst. eapply ctx_swap; try eapply update_inc. eapply H9.
    eapply update_shadow. eapply refl_ctxeq. eapply IHt3. eapply tyAbs.
    eapply ctx_swap; try eapply H9. eapply trans_ctxeq; try (eapply update_inc; eapply update_permute); eauto.
    eapply refl_ctxeq. eapply update_permute; eauto. eapply refl_ctxeq. eauto.
Qed.

Theorem preservation :
    forall t t' T,
        empty |= t \in T ->
        step t t' ->
        empty |= t' \in T.

    intro t; induction t;
    try (intros t' T h1 h2; try value_stepping_false; fail);
    try (intros t' T h1 h2; inversion h1; inversion h2; subst; eauto; fail).

    intros t' T h1 h2; inversion h1; subst; inversion h2; subst; eauto.
    eapply app_preserv; eauto. inversion H2; subst; eauto.

    intros t' T h1 h2; inversion h1; inversion h2; subst; eauto.
    eapply app_preserv; eauto.

    intros t' T h1 h2; inversion h1; inversion h2; subst; eauto.
    inversion H1; subst; eauto.
    intros t' T h1 h2; inversion h1; inversion h2; subst; eauto.
    inversion H1; subst; eauto.
    intros t' T h1 h2; inversion h1; inversion h2; subst; eauto.
    eapply app_preserv; eauto. inversion H8; eauto.
    eapply app_preserv; eauto. inversion H8; eauto.

    intros t' T h1 h2; inversion h1; inversion h2; subst; eauto.
    inversion H9;subst; eauto.
    eapply app_preserv; eauto. eapply tyAbs. eapply app_preserv; eauto.
    eapply tyAbs; eauto. eapply ctx_swap; try eapply update_permute; eauto.
    eapply refl_ctxeq.

    intros t' T h1 h2; inversion h1; inversion h2; subst; eauto.
    inversion h1; subst; inversion H1; subst; eauto.
    eapply app_preserv; eauto.
Qed.

Definition stuck (t: tm) : Prop :=
(normal_form step) t /\ ~ value t.

Notation "t '==>*' t'" := (multi step t t') (at level 40).

Corollary soundness :
    forall t t' T,
        empty |= t \in T ->
        t ==>* t' ->
        ~(stuck t').

        unfold stuck; unfold not; unfold normal_form; unfold not.
        intros t t' T h1 h.
        generalize dependent T.
        induction h; eauto; try tauto.
        intros T h1 h2. destruct h2.
        destruct (progress _ _ h1); eauto.
        intros T h1 h2; destruct h2.
        pose (preservation _ _ _ h1 H).
        eauto.
Qed.

End STLCEXTENDED.