Require Import lecture11.

Section Nasty.
  Variables A B C D E F G H I J K L M N O P Q R S T U V W X Y Z : Prop.

  (*Theorem t6 : A /\ B /\ C /\ D /\ E /\ F /\ G /\ H /\ I /\ J /\ K /\ L /\ M
    /\ N /\ O /\ P /\ Q /\ R /\ S /\ T /\ U /\ V /\ W /\ X /\ Y /\ Z
    -> Z.
    tauto.
  Qed.*)

  Theorem t7 : (A \/ B) /\ (C \/ D) /\ (E \/ F) /\ (G \/ H) /\ (I \/ J)
    /\ (K \/ L) /\ (M \/ N)
    -> (B \/ A) /\ (D \/ C) /\ (F \/ E) /\ (H \/ G) /\ (J \/ I)
    /\ (L \/ K) /\ (N \/ M).
    tauto.
  Qed.

  Print t7.
End Nasty.


Require Import HoTT.
From GR.bicategories Require Import
     bicategory.bicategory_laws
     lax_functor.lax_functor
     lax_functor.examples.composition
     lax_functor.examples.identity
     lax_transformation.lax_transformation
     lax_transformation.examples.identity
     general_category.

Section LaxRightIdentityInv.
  Context `{Univalence}
          {C D : BiCategory}.
  Variable (F : LaxFunctor C D).

  Definition lax_right_identity_inv_d
    : PseudoTransformation_d F (lax_comp F (lax_id_functor C)).
  Proof.
    make_pseudo_transformation.
    - exact (fun X => id₁ (F X)).
    - exact (fun X Y f => (left_unit_inv (F ₁ f)) ∘ right_unit (F ₁ f)).
    - exact (fun X Y f => right_unit_inv (F ₁ f) ∘ left_unit (F ₁ f)).
  Defined.

  Definition is_lax_right_inv_d
    : is_pseudo_transformation_p lax_right_identity_inv_d.
  Proof.
    make_is_pseudo_transformation.
    - intros X Y f g α ; simpl.
      rewrite vcomp_assoc.
      rewrite right_unit_natural.
      rewrite <- vcomp_assoc.
      rewrite left_unit_inv_natural.
      rewrite !vcomp_assoc.
      reflexivity.
    - intros X ; cbn in *.
      rewrite <- right_unit_id_is_left_unit_id.
      rewrite !vcomp_assoc.
      rewrite right_unit_right.
      rewrite vcomp_right_identity.
      rewrite right_unit_natural.
      rewrite <- vcomp_assoc.
      rewrite left_unit_inv_natural.
      rewrite right_unit_id_is_left_unit_id.
      rewrite vcomp_assoc.
      rewrite left_unit_right.
      rewrite !vcomp_right_identity.
      rewrite Fmor₂_id₂, vcomp_left_identity.
      reflexivity.
    - intros X Y Z f g ; cbn in *.
      rewrite vcomp_assoc.
      rewrite right_unit_natural.
      rewrite <- vcomp_assoc.
      rewrite left_unit_inv_natural.
      symmetry.
      rewrite <- (vcomp_left_identity (id₂ (F ₁ f))).
      rewrite <- (vcomp_left_identity (id₂ (F ₁ g))).
      rewrite !interchange.
      rewrite !vcomp_assoc.
      rewrite !(ap (fun z => _ ∘ (_ ∘ (_ ∘ z))) (vcomp_assoc _ _ _)^).
      rewrite triangle_l.
      rewrite <- interchange.
      rewrite left_unit_left.
      rewrite vcomp_left_identity, hcomp_id₂, Fmor₂_id₂.
      rewrite !vcomp_left_identity.
      f_ap.
      rewrite <- right_unit_assoc.
      rewrite <- !vcomp_assoc.
      f_ap.
      pose (left_unit_inv_assoc (F ₁ g) (F ₁ f)) as p.
      unfold bc_whisker_r in p.
      rewrite p ; clear p.
      rewrite <- vcomp_assoc.
      rewrite assoc_left.
      apply vcomp_left_identity.
    - intros X Y f ; simpl in *.
      rewrite !vcomp_assoc.
      rewrite (ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
      rewrite right_unit_left, vcomp_left_identity.
      apply left_unit_right.
    - intros X Y f ; simpl in *.
      rewrite !vcomp_assoc.
      rewrite (ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
      rewrite left_unit_left, vcomp_left_identity.
      apply right_unit_right.
  Qed.

  Definition lax_right_identity_inv
    : PseudoTransformation F (lax_comp F (lax_id_functor C))
    := Build_PseudoTransformation lax_right_identity_inv_d is_lax_right_inv_d.
End LaxRightIdentityInv.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.HoareLogic.ImperativeLanguage.
Require Import Logic.HoareLogic.BigStepSemantics.
Require Import Logic.HoareLogic.ConcurrentSemantics_Angelic.
Require Import Logic.HoareLogic.HoareTriple_BigStepSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelSingleNotation.
Import KripkeModelNotation_Intuitionistic.

Definition guarded_triple_partial_valid
           {L: Language}
           {P: ProgrammingLanguage}
           {MD: Model}
           {guard: Type}
           {TLBSS: ThreadLocalBigStepSemantics P (model) guard}
           {SM: Semantics L MD}
           (Inv: guard)
           (Pre: expr)
           (c: cmd)
           (Post: expr):
  Prop :=
  exists h,
  @triple_partial_valid L _ MD (guarded_BSS Inv) SM Pre (existT _ c h) Post.

Definition guarded_triple_total_valid
           {L: Language}
           {P: ProgrammingLanguage}
           {MD: Model}
           {guard: Type}
           {TLBSS: ThreadLocalBigStepSemantics P (model) guard}
           {SM: Semantics L MD}
           (Inv: guard)
           (Pre: expr)
           (c: cmd)
           (Post: expr):
  Prop :=
  exists h,
  @triple_total_valid L _ MD (guarded_BSS Inv) SM Pre (existT _ c h) Post.


(*
	Here's a weird example.
	Naively, one would hope that whenever a proof term p exists, that we could instead complete the proof by replacing random subterms with holes, and refining the result.
	Then, in each subgoal we could exact whatever was removed from that hole (modulo whatever unification has already solved/partially solved), and complete the proof.
	This simply doesn't hold when one hole appears in the scope of a binder whose value is determined by another hole.
	As an example:
*)
Theorem six_factors : exists a b, a * b = 6.
Proof.
  exists 2. exists 3.
  exact eq_refl.
Qed.

Theorem six_factors' : exists a b, a * b = 6.
Proof.
  (* Let us expand out this proof term with lets to form binders, with which we statically pick the factors once out front. *)
  exact (
    let a' := 2 in
    let b' := 3 in
    ex_intro (fun a : nat => exists b : nat, a * b = 6) a'
      (ex_intro (fun b : nat => a' * b = 6) b' eq_refl)
  ).
Qed.

Theorem six_factors'' : exists a b, a * b = 6.
Proof.
  (* Now let us repeat the same, only using refine. *)
  refine (
    let a' := _ in
    let b' := _ in
    ex_intro (fun a : nat => exists b : nat, a * b = 6) a'
      (ex_intro (fun b : nat => a' * b = 6) b' _)
  ).
  (* Here filling in these holes with 2, 3, and eq_refl respectively solves the problem. *)
  (* However, as each hole is nested inside a binder formed with another hole, this information isn't carried between the goals, and the proof becomes impossible from this point. *)
  (* To demonstrate this, we will attempt to fill in the holes correctly: *)
  exact 2.
  exact 3.
  (* Unsolvable goal: a' * b' = 6, where a' and b' are just naturals. *)
  admit.
Qed.


Set Implicit Arguments.
Unset Strict Implicit.

Require Import ProofIrrelevance.
Require Import QArith.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

Import GRing.Theory Num.Def Num.Theory.
Require Import OUVerT.extrema.
Require Import OUVerT.numerics.
Require Import OUVerT.dyadic.
Require Import OUVerT.strings.
Require Import OUVerT.compile.
(*The computable state representation is an FMap over
  player indices, represented as positive.*)
Require Import Coq.FSets.FMapAVL Coq.FSets.FMapFacts.
Require Import Structures.Orders NArith.

Module Enum_table.

  Definition nonempty_head (T : Type) (l : list T) (H : O <> length l) : T.
    destruct l eqn:e.
      exfalso. apply H. auto.
    exact t.
  Defined.

  Lemma nonempty_head_correct: forall (T : Type) (l : list T) (x : T) (H : O <> length (x :: l)),
    @nonempty_head T (x :: l) H = x.
  Proof. auto. Qed.

  Lemma nonempty_head_map: forall (T1 T2 : Type) (l : list T1) (f : T1->T2)
      (H : O <> length l) (H0 : O <> length (map f l)),
    f (nonempty_head (l:=l) H) = @nonempty_head T2 (map f l) H0.
  Proof.
    intros.
    destruct l.
    { exfalso.  auto. }
    rewrite -> nonempty_head_correct. auto.
  Qed.

  (**Finds the index of an element if it is in the list, otherwise returns the length of the list**)
  Fixpoint index_of (T : Type) (l : list T) (f : T->bool) : nat :=
  match l with
  | nil => O
  | t :: l' => if f t then O else S (index_of l' f)
  end.

  Lemma zip_map: forall (T1 T2 : Type) (l : list T1) (f : T1->T2), zip l (map f l) = map (fun x => (x,f x)) l.
  Proof.
    intros.
    induction l; auto.
    simpl. rewrite IHl. auto.
  Qed.

  Lemma index_of_cons_true: forall (T : Type) (l : list T) (f : T->bool) (x: T),
    f x -> index_of (x :: l) f = O.
  Proof. intros. simpl. rewrite H. auto. Qed.

  Lemma nth_seq_nth_same: forall (T : Type) (l : list T) (A : T) (n : nat),
      nth n l A = seq.nth A l n.
  Proof. intros.
    generalize dependent n.
    induction l.
      destruct n; auto.
    intros.
    simpl.
    destruct n; simpl; auto.
  Qed.

  Lemma length_size_eq: forall (T : Type) (l : list T), length l = size l.
  Proof. intros. auto. Qed.

    Lemma in_zip_swap: forall {T1 T2 : Type} (l1 : list T1) (l2 : list T2) (t1 : T1) (t2 : T2),
        In (t1,t2) (zip l1 l2) -> In (t2,t1) (zip l2 l1).
    Proof.
      intros.
      generalize dependent l1.
      induction l2; intros; auto.
      {
        simpl in H.
        induction l1; auto.
      }
      simpl in H.
      induction l1; auto.
      simpl in *.
      destruct H; auto.
      inversion H. auto.
    Qed.

  (**Lemma eqType_eq_dec: forall (T : eqType) (x y : T), {x = y} + {x <> y}.
  Proof.
    intros.
    destruct (eqVneq x y); auto.
    right.
    assert (x <> y /\ true).
    2: { destruct H. auto. }
    assert(reflect (x <> y /\ true) ((x != y) && true)).
      apply predD1P.
    inversion H; auto.
    rewrite andbT in H0.
    inversion i; auto.
    rewrite H3 in H0; auto.
  Qed.

  Definition eqType_eqb {T : eqType} (x y : T) : bool :=
    eqType_eq_dec x y.

  Lemma eqType_eqb_true_iff: forall {T : eqType} (t1 t2 : T), eqType_eqb t1 t2 = true <-> t1 = t2.
  Proof.
    intros.
    split; intros.
    2:{ rewrite H. unfold eqType_eqb. destruct eqType_eq_dec; auto. }
    unfold eqType_eqb in H. destruct (eqType_eq_dec t1 t2); auto. inversion H.
  Qed.

  Lemma eqType_eqb_false_iff: forall {T : eqType} (t1 t2 : T), eqType_eqb t1 t2 = false <-> t1 <> t2.
  Proof.
    intros. unfold eqType_eqb.
    split; intros;
      destruct (eqType_eq_dec t1 t2) eqn:e; auto.
    exfalso. apply H. auto.
  Qed.**)

  Section eqb_proofs.
    Variable T : Type.
    Hypothesis eqb: forall (t1 t2 : T), {t1 = t2} + {t1 <> t2}.

    Lemma nth_index_of_eqb: forall (l : list T) (t1 t2 : T),
      In t1 l -> nth (index_of l (eqb t1)) l t2 = t1.
    Proof.
      intros.
      induction l; auto.
        inversion H.
      simpl.
      destruct (eqb t1 a) eqn:e; auto.
      apply IHl.
      simpl in H.
      destruct H; auto.
      exfalso. auto.
    Qed.

    Lemma eqb_refl: forall t : T, eqb t t.
    Proof. intros. destruct eqb; auto. Qed.

    Lemma eqb_iff: forall t1 t2 : T, eqb t1 t2 <-> t1 = t2.
    Proof.
      intros.
      split; intros; destruct (eqb t1 t2); auto.
      inversion H.
    Qed.

    Lemma index_of_nth_dec_eq: forall (l : list T) (A : T) (n : nat),
      NoDupA (fun x : T => [eta eq x]) l -> (n < length l)%coq_nat -> index_of l (eqb (nth n l A)) = n.
    Proof.
      intros.
      generalize dependent l.
      induction n.
      {
        intros.
        destruct l; auto.
        simpl.
        rewrite eqb_refl; auto.
      }
      intros.
      destruct l; auto.
        inversion H0.
      simpl.
      destruct (eqb (nth n l A) t) eqn:e; auto.
      {
        inversion H.
        exfalso. apply H3.
        apply In_InA; auto.
        rewrite <- e0.
        apply nth_In.
        apply lt_S_n; auto.
      }
      rewrite IHn; auto.
        inversion H; auto.
      apply lt_S_n; auto.
    Qed.

  (**Lemma reflet_eqType_eqb: forall (T : eqType) (x y : T), reflect (x=y) (eqType_eqb x y).
  Proof.
    intros.
    destruct (eqType_eqb x y) eqn:e; auto.
    { constructor. apply eqType_eqb_true_iff. auto. }
    constructor. apply eqType_eqb_false_iff. auto.
  Qed.**)
  End eqb_proofs.
  Section enum_table.

    Variable T1 : Type.
    Variable T2 : Type.
    Variable T1_enum : Enumerable T1.
    Variable T1_enum_ok : @Enum_ok T1 T1_enum.
    Variable T1_enum_ne : O <> length T1_enum.
    Variable T1_eqdec : forall t1 t2 : T1, {t1 = t2} + {t1 <> t2}.

    Record table : Type :=
      table_mk {
        t_list : list T2;
        t_list_length : length T1_enum = length t_list
      }.

    Program Definition table_head (t : table) : T2 := @nonempty_head T2 (t_list t) _.
    Next Obligation. rewrite <- (t_list_length t). apply T1_enum_ne. Defined.

    Definition enum_head (t : table)  : T1 := @nonempty_head T1 T1_enum T1_enum_ne.

    Definition lookup  (t : table) (x : T1) : T2 :=
     nth  (index_of T1_enum (T1_eqdec x)) (t_list t) (table_head t).

    Definition zip_table (t : table)  := zip T1_enum (t_list t).

    Definition eq_func (t : table) (f : T1->T2):= forall (x : T1), lookup t x = f x.

    Definition to_func (t : table) : (T1->T2) := (fun x => lookup t x).

    Lemma zip_table_length: forall (t : table), length (zip_table t) = length T1_enum.
    Proof.
      intros.
      unfold zip_table.
      rewrite length_size_eq.
      rewrite size_zip.
      repeat rewrite <- length_size_eq.
      rewrite (t_list_length t).
      repeat rewrite length_size_eq.
      unfold minn.
        destruct (size (t_list t) < size (t_list t))%N; auto.
    Qed.

    Lemma nth_lookup: forall (t : table) (n : nat) (x A1: T1) (y A2 : T2) ,
        (n < length T1_enum)%coq_nat -> nth n T1_enum A1 = x -> nth n (t_list t) A2 = y ->
        lookup t x = y.
    Proof.
      intros.
      unfold lookup.
      rewrite <- H0.
      rewrite -> index_of_nth_dec_eq; auto.
      {
        rewrite -> nth_indep with _ _ _ _ A2; auto.
        rewrite <- t_list_length.
        auto.
      }
      apply (T1_enum_ok).
    Qed.

    Program Definition map_to_table (f : T1->T2) :=
      @table_mk (map f T1_enum) _.
    Next Obligation.
      rewrite map_length. auto.
    Defined.

    Lemma table_head_map: forall (f : T1->T2), table_head (map_to_table f) = f  (nonempty_head  T1_enum_ne).
    Proof.
      intros.
      unfold table_head.
      simpl.
      rewrite <- nonempty_head_map with T1 T2 T1_enum f T1_enum_ne (table_head_obligation_1 (t:=map_to_table f)); auto.
    Qed.

    Lemma lookup_map: forall (f : T1->T2) (x : T1), @lookup (map_to_table f) x = f x.
    Proof.
      intros.
      unfold lookup. simpl.
      rewrite table_head_map.
      rewrite -> map_nth.
      rewrite nth_index_of_eqb; intros; auto.
      destruct T1_enum_ok. auto.
    Qed.

    Lemma zip_table_map: forall (f : T1->T2), zip_table (map_to_table f) = map (fun x => (x, f x)) T1_enum.
    Proof.
      intros.
      unfold map_to_table. unfold zip_table. simpl.
      rewrite zip_map. auto.
    Qed.

    Lemma map_to_table_ext: forall (f1 f2 : T1->T2), (forall x : T1, f1 x = f2 x) ->
      map_to_table f1 = map_to_table f2.
    Proof.
      intros. unfold map_to_table.
      apply map_ext with _ _ f1 f2 T1_enum in H.
      generalize dependent (map_to_table_obligation_1 f1).
      rewrite -> H.
      intros. f_equal. apply proof_irrelevance.
    Qed.

  End enum_table.

  Definition table_eqb (T1 T2 : eqType) (T1_enum : Enumerable T1) (t1 t2 : table T2 T1_enum) : bool :=
   eq_op (t_list t1) (t_list t2).

  Definition table_eqb_func (T1 T2 : eqType) (T1_enum : Enumerable T1)
      (t : table T2 T1_enum) (f : T1->T2) : bool :=
   table_eqb t (map_to_table T1_enum f).

  Lemma table_eqnP : forall (T1 T2 : eqType) (T1_enum : Enumerable T1) (x y : table T2 T1_enum), reflect (x = y) (table_eqb x y).
  Proof.
    intros.
    unfold table_eqb.
    destruct (eq_op (t_list x) (t_list y)) eqn:e.
    {
      constructor.
      assert(t_list x = t_list y).
        apply/(eqP). auto.
      destruct x; destruct y. simpl in *. generalize t_list_length0.
      rewrite H. intros. f_equal. apply proof_irrelevance.
    }
    constructor. destruct x; destruct y.
    unfold not in *. intros.
    simpl in *. inversion H. rewrite H1 in e.
    rewrite eq_refl in e. inversion e.
  Qed.

  (**Definition table_eqMixin (T1 T2 : eqType) (T1_enum : Enumerable T1) : Equality.mixin_of (Enum_table.table T2 T1_enum) :=
    EqMixin (op:=(@table_eqb T1 T2 T1_enum)) (@table_eqnP _ _ _).

  Definition table_eqType (T1 T2: eqType) (T1_enum : Enumerable T1) := Equality.Pack (@table_eqMixin T1 T2 T1_enum) (@table T1 T2 T1_enum).
  **)

End Enum_table.

Lemma InA_map_inj: forall (T1 T2 : Type) (l : list T1) (f : T1->T2) (x : T1),
    (forall (t1 t2 : T1), f t1 = f t2 -> t1 = t2) ->
    (InA (fun x : T1 => [eta eq x]) x l <-> InA (fun x : T2 => [eta eq x]) (f x) (map f l)).
Proof.
  intros.
  split; intros.
  {
    induction l.
      inversion H0.
    inversion H0.
    { apply In_InA; auto. rewrite <- H2. apply in_map. apply in_eq. }
    simpl. auto.
  }
  induction l.
    inversion H0.
  inversion H0; auto.
Qed.

Lemma NoDupA_map_inj: forall (T1 T2 : Type) (l : list T1) (f : T1->T2),
    NoDupA (fun x : T1 => [eta eq x]) l ->
    (forall (t1 t2 : T1), f t1 = f t2 -> t1 = t2) ->
    NoDupA (fun x : T2 => [eta eq x]) (map f l).
Proof.
  intros.
  induction l.
    simpl. auto.
  simpl.
  inversion H.
  constructor; auto.
  rewrite <- InA_map_inj; auto.
Qed.

Lemma In_pair: forall (T1 T2 : Type) (x1 x2: T1) (y : T2) (l : list T2),
    In (x1, y) (map [eta pair x2] l) -> x1 = x2.
Proof.
  intros.
  induction l.
    exfalso. auto.
  simpl in H.
  destruct H; auto.
  inversion H. auto.
Qed.

Lemma prodEnumerableInstance_nodup: forall (aT bT:  Type) (la : Enumerable aT) (lb : Enumerable bT),
     NoDupA (fun x : aT => [eta eq x]) (enumerate _ la) ->
     NoDupA (fun x : bT => [eta eq x]) (enumerate _ lb) ->
     NoDupA (fun x : aT * bT => [eta eq x]) (prodEnumerableInstance la lb).
Proof.
  intros.
    unfold prodEnumerableInstance.
    unfold Enumerable in *.
    unfold enumerable_fun in *.
    generalize dependent lb.
    induction la.
      simpl. auto.
    intros. simpl.
    inversion H.
    apply NoDupA_app; auto.
    { apply NoDupA_map_inj; auto. intros. inversion H5. auto. }
    intros.
    rewrite -> InA_alt in H5. destruct H5. destruct H5.
    rewrite <- H5 in H7. clear H5. clear x1.
    rewrite -> InA_alt in H6.
    destruct H6.
    destruct H5.
    rewrite <- H5 in H6.
    clear H5. clear x1.
    destruct x0.
    rewrite -> in_prod_iff in H6.
    destruct H6.
    apply In_pair in H7.
    apply H3.
    rewrite H7 in H5; auto.
    apply In_InA; auto.
Qed.

Lemma prodEnumerableInstance_ok (aT bT:  Type)
     (enumerableA : Enumerable aT)
     (enumerableB : Enumerable bT)
     (enum_okA: @Enum_ok aT enumerableA)
     (enum_okB: @Enum_ok bT enumerableB)
  : @Enum_ok _ (prodEnumerableInstance enumerableA enumerableB).
  destruct enum_okA.
  destruct enum_okB.
  constructor.
    apply prodEnumerableInstance_nodup; auto.
  intros.
  destruct a.
  apply in_prod_iff.
  split; auto.
Qed.

Record list_len {T : Type} (n : nat) : Type :=
  mk_list_len {
    list_len_l : list T;
    list_len_ok : length list_len_l = n
  }.

Fixpoint cons_all {T : Type} (l : list T) (l2 : list (list T)) :=
match l with
| nil => nil
| x :: l' =>  ( map (fun l2' => x :: l2') l2) ++ (cons_all l' l2)
end.

Fixpoint list_enum {T : Type} (l : list T) (n : nat) : list (list T) :=
match n with
| O => (nil) :: nil
| S n' => cons_all l (list_enum l n')
end.

Lemma in_cons_all: forall (T : Type) (a : T) (l l1: list T) (l2 : list (list T)),
    (In a l1 /\ In l l2) <-> In (a :: l) (cons_all l1 l2).
Proof.
  intros.
  split; intros.
  {
    destruct H.
    induction l1; intuition.
    simpl. simpl in H.
    rewrite in_app_iff.
    destruct H; auto.
    left. rewrite H.
    rewrite in_map_iff.
    exists l; auto.
  }
  induction l1.
  { simpl in H. inversion H. }
  simpl in *.
  rewrite -> in_app_iff in H.
  split.
  {
    destruct H.
    {
      rewrite -> in_map_iff in H.
      destruct H.
      destruct H.
      inversion H. auto.
    }
    right.
    apply IHl1. auto.
  }
  destruct H.
  {
    rewrite -> in_map_iff in H.
    destruct H.
    destruct H.
    inversion H.
    rewrite <- H3. auto.
  }
  apply IHl1. auto.
Qed.

Lemma cons_all_nonempty: forall {T : Type} (l1 l2 : list T) (l3 : list (list T)),
    In l1 (cons_all l2 l3) -> l1 <> [::].
Proof.
  intros.
  generalize dependent l1.
  generalize dependent l3.
  induction l2; intuition.
  destruct l1.
  2: { inversion H0. }
  simpl in H.
  apply in_app_or in H.
  destruct H.
  {
    apply in_map_iff in H.
    destruct H.
    destruct H.
    inversion H.
  }
  eapply IHl2; eauto.
Qed.

Lemma in_list_enum_cons: forall {T : Type} (l1 l2 : list T) (x : T) (n : nat),
  In l1 (list_enum l2 n) -> In l1 (list_enum (x :: l2) n).
Proof.
  intros.
  generalize dependent l1.
  generalize dependent l2.
  induction n; auto.
  simpl. intros.
  rewrite -> in_app_iff.
  right.
  destruct l1.
  { exfalso. eapply  cons_all_nonempty; eauto. }
  apply in_cons_all.
  apply in_cons_all in H.
  destruct H.
  split; auto.
Qed.

Lemma list_enum_len: forall {T : Type} (l1 l2 : list T) (n : nat), In l1 (list_enum l2 n) -> length l1 = n.
Proof.
  intros.
  generalize dependent l2.
  generalize dependent l1.
  induction n.
  { intros. simpl in H. destruct H; intuition. rewrite <- H. auto. }
  intros.
  simpl in H.
  destruct l1.
    exfalso. eapply cons_all_nonempty; eauto.
  simpl.
  apply in_cons_all in H.
  destruct H.
  erewrite IHn; eauto.
Qed.

Program Fixpoint list_to_list_len {T : Type} (l : list (list T)) (n : nat) (H : forall l' : list T, In l' l -> length l' = n) :
    list (@list_len T n) := match l with
| nil => nil
| x :: l' => (@mk_list_len T n x _) :: @list_to_list_len T l' n _
end.
Next Obligation.
  apply H. simpl. auto.
Defined.
Next Obligation.
  apply H. simpl. auto.
Defined.

Lemma list_len0_same: forall {T : Type} (l1 l2 : @list_len T O), l1 = l2.
Proof.
  intros.
  destruct l1.
  destruct l2.
  destruct list_len_l0.
  2: { inversion list_len_ok0. }
  destruct list_len_l1.
  2: { inversion list_len_ok1. }
  f_equal. apply proof_irrelevance.
Qed.

Program Definition list_len_enumerate {T : Type} (l : list T) (n : nat) : list (@list_len T n) :=
  @list_to_list_len T (list_enum l n) n _.
Next Obligation.
  apply list_enum_len with l. auto.
Defined.

Lemma no_dup_cons_all: forall (T : Type) (l : list T) (l2 : list (list T)),
    NoDupA (fun x => [eta eq x]) l -> NoDupA (fun x => [eta eq x]) l2 -> NoDupA (fun x => [eta eq x]) (cons_all l l2).
Proof.
  intros.
  generalize dependent l2.
  induction l.
  { simpl. constructor. }
  intros. simpl.
  apply NoDupA_app; auto.
  {
    apply NoDupA_map_inj; auto.
    intros.
    inversion H1. auto.
  }
  {
    apply IHl; auto.
    inversion H; auto.
  }
  intros.
  apply InA_alt in H1.
  destruct H1. destruct H1.
  apply InA_alt in H2.
  destruct H2. destruct H2.
  rewrite <- H1 in H3. clear H1.
  rewrite <- H2 in H4. clear H2 x0 x1.
  destruct x.
  { eapply cons_all_nonempty; eauto. }
  rewrite <- in_cons_all in H4.
  destruct H4.
  rewrite -> in_map_iff in H3.
  destruct H3. destruct H3.
  inversion H3.
  rewrite H7 in H4. clear H3 H7 x0.
  inversion H.  apply H7.
  apply InA_alt. eauto.
Qed.

Lemma no_dup_enum_list: forall (T : Type) (l : list T) (n : nat),
  NoDupA (fun x => [eta eq x]) l -> NoDupA (fun x => [eta eq x]) (list_enum l n).
Proof.
  intros.
  generalize dependent l.
  induction n; intros; simpl.
  { constructor; auto. unfold not. intros. inversion H0. }
  apply no_dup_cons_all; auto.
Qed.

Lemma in_list_to_len_list: forall (T : Type) (l : list (list T)) (n : nat) (H : forall l' : list T, In l' l -> length l' = n)
    (x : list T) (H0 : length x = n), In  (@mk_list_len T n x H0) (@list_to_list_len T l n H) <-> In x l.
Proof.
  intros.
  split; intros.
  {
    generalize dependent n.
    generalize dependent x.
    induction l. intros. inversion H1.
    simpl in *. intros.
    destruct H1.
      inversion H1. auto.
    right. eapply IHl.
    assert (forall H', (list_to_list_len (l:=l) H') = (list_to_list_len (l:=l) (fun (l'0 : seq.seq T) (H0 : In l'0 l) => H l'0 (or_intror H0)))).
    { intros. f_equal. apply proof_irrelevance. }
    erewrite H2. apply H1.
  }
  generalize dependent n.
  generalize dependent x.
  induction l. intros. inversion H1.
  intros. simpl.
  simpl in H1. destruct H1.
  2: { right. apply IHl. auto. }
  left.
  generalize H.
  generalize H0.
  rewrite H1.
  intros. f_equal. apply proof_irrelevance.
  Unshelve. auto.
Qed.

Lemma no_dup_list_to_len_list: forall (T : Type) (l : list (list T)) (n : nat) (H : forall l' : list T, In l' l -> length l' = n),
    NoDupA (fun x => [eta eq x]) l -> NoDupA (fun x => [eta eq x]) (@list_to_list_len T l n H).
Proof.
  intros.
  generalize dependent n.
  generalize dependent H0.
  induction l.
    simpl. constructor.
  simpl in *.
  intros.
  inversion H0.
  constructor.
  2: { apply IHl. auto. }
  unfold not.
  intros.
  apply H3.
  rewrite InA_alt. eexists. split;  eauto.
  eapply in_list_to_len_list; eauto.
  erewrite InA_alt in H5.
  destruct H5.
  destruct H5.
  rewrite <- H5 in H6.
  eauto.
Qed.

Lemma list_len_enumerate_ok: forall (T : Type) (enum : Enumerable T) (enum_ok : @Enum_ok T enum) (n : nat),
    @Enum_ok (@list_len T n) (@enumerable_fun (@list_len T n) (@list_len_enumerate T enum n)).
Proof.
  intros.
  inversion enum_ok.
  induction n.
  {
    constructor; unfold enumerable_fun.
    { unfold list_len_enumerate. simpl. apply NoDupA_singleton. }
    intros.
    simpl.
    left.
    apply list_len0_same.
  }
  inversion IHn.
  constructor.
  {
    unfold enumerable_fun.
    unfold list_len_enumerate.
    apply no_dup_list_to_len_list. simpl.
    apply no_dup_cons_all; auto.
    apply no_dup_enum_list. auto.
  }
  intros.
  unfold enumerable_fun.
  unfold list_len_enumerate.
  destruct a.
  apply in_list_to_len_list; auto.
  simpl.
  unfold enumerable_fun in enum_total0.
  unfold list_len_enumerate in enum_total0.
  destruct list_len_l0.
  { inversion list_len_ok0. }
  apply in_cons_all; auto.
  split; auto.
  inversion list_len_ok0.
  rewrite H0.
  rewrite <- in_list_to_len_list; auto.
  Unshelve.
  auto.
Qed.

Program Definition enumerate_table {T1 T2 : Type} (T1_eqdec : forall a b : T1, {a = b} + {a <> b}) (T1_enum : Enumerable T1) (T2_enum : Enumerable T2)
      (T1_enum_ok : @Enum_ok T1 T1_enum) (T2_enum_ok : @Enum_ok T2 T2_enum) (T1_enum_ne : O <> length T1_enum)
       : Enumerable (@Enum_table.table T1 T2 T1_enum)
  := map (fun l => @Enum_table.table_mk  T1 T2 T1_enum (list_len_l l) _)
      (list_len_enumerate (enumerate T2) (length (enumerate T1))).
Next Obligation.
  destruct l. auto.
Defined.

Lemma length_list_to_list_len:forall (T : Type) (l : list (list T)) (n : nat)
      (H : forall l' : list T, In l' l -> length l' = n) (x : list T),
        length (list_to_list_len H) = length l.
Proof. intros. induction l; simpl; auto. Qed.

Lemma length_cons_all: forall (T : Type) (l : list T) (l2 : list (list T)), length (cons_all l l2) = (length l * length l2)%coq_nat.
Proof.
  intros.
  induction l; auto.
  simpl.
  rewrite  Enum_table.length_size_eq.
  rewrite size_cat.
  rewrite size_map.
  rewrite <- Enum_table.length_size_eq.
  rewrite <- IHl. auto.
Qed.

Lemma list_enum_nonempty: forall {T : Type} (l : list T) (n : nat),
  O <> length l -> O <> length (list_enum l n).
Proof.
  intros.
  induction n.
    simpl. auto.
  simpl.
  rewrite length_cons_all.
  apply lt_0_neq.
  apply Nat.mul_pos_pos.
  {
    destruct (length l).
      exfalso. apply H. auto.
    apply Nat.lt_0_succ.
  }
  destruct (length (list_enum l n)).
    exfalso. apply IHn. auto.
  apply Nat.lt_0_succ.
Qed.

Lemma enumerate_table_nonempty: forall {T1 T2 : Type} (T1_eqdec : forall a b : T1, {a = b} + {a <> b}) T1_enum T2_enum  T1_enum_ok T2_enum_ok  T1_enum_ne ,
      O <> (length T2_enum) -> O <> length (@enumerate_table T1 T2 T1_eqdec T1_enum T2_enum T1_enum_ok T2_enum_ok T1_enum_ne ).
Proof.
  intros.
  unfold enumerate_table.
  unfold enumerable_fun.
  rewrite Enum_table.length_size_eq.
  rewrite size_map.
  unfold list_len_enumerate.
  rewrite <- Enum_table.length_size_eq.
  rewrite length_list_to_list_len; auto.
  apply list_enum_nonempty. auto.
Qed.

Lemma NoDupA_map: forall (T1 T2 : Type) (f : T1->T2) (l : list T1),
  (forall (x y : T1), f x = f y -> x = y) -> NoDupA (fun x=> [eta eq x]) l ->
    NoDupA (fun x => [eta eq x]) (map f l).
Proof.
  intros.
  induction l; simpl; auto.
  constructor.
  {
    inversion H0.
    unfold not. intros.
    apply H3.
    apply In_InA; auto.
    rewrite -> InA_alt in H5.
    destruct H5. destruct H5.
    rewrite -> in_map_iff in H6.
    destruct H6. destruct H6.
    rewrite <- H5 in H6.
    apply H in H6.
    rewrite H6 in H7.
    auto.
  }
  apply IHl.
  inversion H0. auto.
Qed.

Lemma enum_table_total: forall {T1 T2 : Type} (T1_eqdec : forall a b : T1, {a = b} + {a <> b}) (T1_enum : Enumerable T1) (T2_enum : Enumerable T2)
      (T1_enum_ok : @Enum_ok T1 T1_enum) (T2_enum_ok : @Enum_ok T2 T2_enum) (T1_enum_ne : O <> length T1_enum)
      (t : (@Enum_table.table T1 T2 T1_enum)),
      In t (@enumerate_table T1 T2 T1_eqdec T1_enum T2_enum  _ _ T1_enum_ne).
Proof.
  intros.
  unfold enumerate_table.
  destruct list_len_enumerate_ok with T2 T2_enum (length (enumerate T1)); auto.
  erewrite in_map_iff.
  destruct t.
  assert(length t_list = (length (enumerate T1))).
  { unfold enumerable_fun. rewrite <- t_list_length. auto. }
  exists (mk_list_len H).
  split; auto.
  simpl.
  f_equal.
  apply proof_irrelevance.
Qed.

Lemma enum_table_ok: forall {T1 T2 : Type} (T1_eqdec : forall a b : T1, {a = b} + {a <> b}) (T1_enum : Enumerable T1) (T2_enum : Enumerable T2)
      (T1_enum_ok : @Enum_ok T1 T1_enum) (T2_enum_ok : @Enum_ok T2 T2_enum) (T1_enum_ne : O <> length T1_enum),
  @Enum_ok (@Enum_table.table T1 T2 T1_enum) (@enumerate_table T1 T2 T1_eqdec T1_enum T2_enum  _ _ T1_enum_ne).
Proof.
  intros.
  constructor; unfold enumerable_fun.
  {
    apply NoDupA_map.
    {
      intros. inversion H.
      destruct x. destruct y.
      unfold list_len_l in H1.
      generalize list_len_ok0.
      rewrite H1. intros. f_equal.
      apply proof_irrelevance.
    }
    apply list_len_enumerate_ok.
    auto.
  }
  apply enum_table_total.
Qed.

Record enum_nat (n : nat) : Type :=
  mk_enum_nat {
    enum_nat_n : nat;
    enum_nat_lt : lt enum_nat_n n
  }.

Program Fixpoint enum_nat_enumerate_aux (n : nat) (m : nat) (H : le m n) : list (enum_nat n):=
match m with
| O => nil
| S m' => (@mk_enum_nat n m' _) :: (@enum_nat_enumerate_aux n m' _)
end.
Next Obligation.
  unfold lt in *.
  apply Nat.le_trans with (S m'); auto.
Qed.

Program Definition enum_nat_enumerate (n : nat) : list (enum_nat n) :=
  @enum_nat_enumerate_aux n n _.

Lemma enum_nat_enumerate_aux_max: forall (n m : nat) (p : enum_nat n) (H : le m n),
  In p (@enum_nat_enumerate_aux n m H) -> lt (enum_nat_n p) m.
Proof.
  intros.
  generalize dependent p.
  generalize dependent n.
  induction m; intros.
    inversion H0.
  simpl in H0.
  destruct H0.
  {
    destruct p.
    simpl in *.
    by inversion H0.
  }
  apply IHm in H0.
  apply lt_trans with m; auto.
Qed.

Program Definition enum_nat_list_to_succ (n : nat) (l : list (enum_nat n))
    : list (enum_nat (S n)) :=
  map (fun x => @mk_enum_nat (S n) (enum_nat_n x) _) l.
Next Obligation.
  destruct x.
  simpl.
  apply Nat.le_trans with n; auto.
Qed.

Lemma enum_nat_enumerate_aux_to_succ: forall (n m : nat) (H0 : le m n) (H1 : le m (S n)),
    @enum_nat_enumerate_aux (S n) m H1 = enum_nat_list_to_succ (@enum_nat_enumerate_aux n m H0).
Proof.
  intros.
  generalize dependent n.
  induction m; auto; intros.
  unfold enum_nat_list_to_succ in *.
  simpl in *.
  rewrite IHm; auto.
  {
    apply le_trans with (S m); auto.
  }
  intros.
  assert(H1 = enum_nat_list_to_succ_obligation_1 {| enum_nat_n := m; enum_nat_lt := H0 |}).
    apply proof_irrelevance.
  rewrite <- H.
  assert((enum_nat_enumerate_aux Hyp0) = enum_nat_enumerate_aux (enum_nat_enumerate_aux_obligation_2 H0 (erefl (S m)))).
  2:{ rewrite H2. auto. }
  assert(Hyp0 =   (enum_nat_enumerate_aux_obligation_2 H0 (erefl (S m)))).
    apply proof_irrelevance.
  by rewrite H2.
Qed.

Lemma enum_nat_ok: forall n : nat, @Enum_ok (enum_nat n) (enum_nat_enumerate n).
Proof.
  intros.
  constructor; unfold enumerable_fun;
    unfold enum_nat_enumerate.
  {
    induction n.
      simpl. auto.
    simpl.
    constructor.
    {
      unfold not.
      intros.
      apply InA_alt in H.
      destruct H.
      destruct H.
      apply enum_nat_enumerate_aux_max in H0.
      destruct x.
      simpl in *.
      inversion H.
      rewrite H2 in H0.
      eapply Nat.lt_irrefl. apply H0.
    }
    rewrite enum_nat_enumerate_aux_to_succ.
    unfold enum_nat_list_to_succ.
    apply NoDupA_map.
    {
      intros.
      destruct x.
      destruct y.
      inversion H.
      generalize enum_nat_lt0.
      generalize enum_nat_lt1.
      rewrite H1.
      intros. f_equal. apply proof_irrelevance.
    }
    assert (le_n n = enum_nat_enumerate_obligation_1 n).
      apply proof_irrelevance.
    rewrite H.
    auto.
  }
  intros.
  induction n.
  { inversion a. inversion enum_nat_lt0. }
  simpl.
  destruct (Nat.eq_dec (enum_nat_n a) n).
  {
    left. destruct a. simpl in e.
    generalize enum_nat_lt0.
    rewrite e.
    intros. f_equal. apply proof_irrelevance.
  }
  right.
  rewrite enum_nat_enumerate_aux_to_succ.
  unfold enum_nat_list_to_succ.
  remember (fun x : enum_nat n =>
      {| enum_nat_n := enum_nat_n x; enum_nat_lt := enum_nat_list_to_succ_obligation_1 x |}) as f.
  destruct a.
  simpl in *.
  unfold lt in enum_nat_lt0.
  remember enum_nat_lt0 as H.
  clear HeqH.
  apply le_S_n in enum_nat_lt0.
  assert(enum_nat_n0 < n)%coq_nat.
    apply Nat.le_neq. split; auto.
  assert ({| enum_nat_n := enum_nat_n0; enum_nat_lt := H |} = f (@mk_enum_nat n enum_nat_n0 H0)).
    rewrite Heqf. simpl. f_equal. apply proof_irrelevance.
  rewrite H1.
  apply in_map.
  assert (enum_nat_enumerate_obligation_1 n = le_n n).
    apply proof_irrelevance.
  rewrite <- H2.
  apply IHn.
Qed.


(** * System LM for minimal logic encoded as an LL theory

This file encodes the inference rules of the system LM (minimal logic).

 *)

Require Export FLL.OL.CutCoherence.OLCuti.
Require Import Coq.Init.Nat.
Require Import FLL.Misc.Permutations.

Export ListNotations.
Export LLNotations.
Set Implicit Arguments.

(** ** Syntax *)
(** No constants *)
Inductive Constants := .
(**  conjunction, disjunction and implication *)
Inductive Connectives := AND | IMP  .
(** universal quantifier *)
Inductive Quantifiers := ALL .
(* No unary connectives  *)
Inductive UConnectives := .

Instance SimpleOLSig : OLSyntax:=
  {|
    OLType := nat;
    constants := Constants ;
    uconnectives := UConnectives;
    connectives := Connectives ;
    quantifiers := Quantifiers
  |}.

(** ** Inference rules *)

(**  Constants *)
Definition rulesCTE (c:constants) : ContantEnc:=
  match c with
  end.

(**  Binary connectives *)
Definition rulesBC (c :connectives) :=
  match c with
  | AND => PLUSWITH
  | IMP => TENSORPAR
  end.

(*** Quantifiers *)
Definition rulesQD (q :quantifiers) :=
  match q with
  | ALL => ALLSOME
  end
.

Instance SimpleOORUles : OORules :=
  {|
    rulesCte := rulesCTE ;
    rulesBin := rulesBC;
    rulesQ := rulesQD
  |}.

(** An inductive definition for LM. This will be used to prove that
the LL encoding is sound and complete *)

Inductive LMSeq : list uexp -> uexp -> Prop :=
| LMinit : forall L F,  LMSeq (F:: L) F
| LMAndL1 : forall L F G R, LMSeq (F :: L) R -> LMSeq ( (t_bin AND F G) :: L) R
| LMAndL2 : forall L F G R, LMSeq (G :: L) R -> LMSeq ( (t_bin AND F G) :: L) R
| LMAndR : forall L F G , LMSeq L F -> LMSeq L G -> LMSeq L (t_bin AND F G)
| LMImpL : forall L A B G , LMSeq L A -> LMSeq (B:: L) G -> LMSeq (t_bin IMP A B ::L) G
| LMImpR : forall L A B  , LMSeq (A:: L) B ->  LMSeq L (t_bin IMP A B)
| LMAllL : forall L t FX G, uniform FX -> proper t -> LMSeq( FX t :: L) G -> LMSeq (t_quant ALL FX :: L) G
| LMAllR : forall L FX , uniform FX -> (forall x, proper x -> LMSeq L (FX x)) -> LMSeq L (t_quant ALL FX)
| (* contraction is needed *)
LMContr : forall L F G, (LMSeq (F :: F:: L)) G -> (LMSeq (F :: L)) G
| (* Explicit exchange *)
LMEx : forall L L' G, Permutation L L' -> LMSeq L G -> LMSeq L' G
.
Hint Constructors LMSeq : core .
Hint Constructors LMSeq : core .
Hint Constructors OLTheory buildTheory : core.
Hint Constructors  isOLFormula : core.
Hint Unfold IsPositiveLAtomFormulaL : core.
Hint Constructors IsPositiveRAtomFormula : core .

Global Instance LML_morph :
  Proper ((@Permutation uexp) ==> eq ==> iff) (LMSeq).
Proof.
  unfold Proper; unfold respectful.
  intros.
  split;intros;subst.
  eapply LMEx;eauto.
  apply Permutation_sym in H.
  eapply LMEx;eauto.
Qed.

Ltac solveOLTheory :=
  try
    match goal with
    | [|- OLTheory _] =>
      first [ apply ooth_init ; auto ; SolveIS
            | do 2 constructor;auto ; SolveIS ]
    end.

(** Soundness *)
Theorem Soundeness: forall L F, LMSeq L F ->
                                isOLFormulaL L ->
                                isOLFormula F ->
                                seq OLTheory (LEncode L) (REncode [F]) (> []).
Proof with solveF;solveLL;solveOLTheory;SolveIS;solveOLTheory.
  intros.
  induction H.
  + (* init *)
    decide3 (RINIT F)...
    tensor (REncode [F]) (@nil oo)...
  + (* ANDL1 *)
    decide3 (makeRuleBin AND Left F G)...
    tensor (@nil oo) (REncode [R])...
    oplus1.
    LLPerm ( d| t_bin AND F G | :: d| F |  :: LEncode L).
    apply weakening.
    apply IHLMSeq...
  +  (* ANDL2 *)
    decide3 (makeRuleBin AND Left F G)...
    tensor (@nil oo) (REncode [R])...
    oplus2.
    LLPerm ( d| t_bin AND F G | :: d| G |  :: LEncode L).
    apply weakening.
    apply IHLMSeq...
  + (* And R *)
    decide3 (makeRuleBin AND Right F G)...
    tensor (REncode [t_bin AND F G]) (@nil oo).
    apply  IHLMSeq1...
    apply  IHLMSeq2...
  + (* implication left *)
    decide3 (makeRuleBin IMP Left A B)...
    tensor (@nil oo) (REncode [G])...
    tensor (@nil oo) (REncode [G])...
    apply weakening.
    apply IHLMSeq1...
    apply weakening.
    LLPerm (d| B | :: LEncode L ) .
    apply IHLMSeq2...
  + (* implication right *)
    decide3 (makeRuleBin IMP Right A B)...
    tensor (REncode [t_bin IMP A B]) (@nil oo).

    LLPerm (d| A | :: LEncode L ) .
    apply IHLMSeq...
  + (* forall left *)
    decide3 (makeRuleQ ALL Left FX)...
    tensor (@nil oo) (REncode [G])...
    existential t...
    apply weakening.
    LLPerm(d| FX t |:: LEncode L )...
    apply IHLMSeq...
  + (* forall right *)
    decide3 (makeRuleQ ALL Right FX)...
    tensor (REncode [t_quant ALL FX]) (@nil oo)...
    apply H3...
  + (* contraction *)
    eapply contractionSet with (L0:=LEncode [F]);[firstorder|]...
    apply IHLMSeq...
  + (* exchange *)
    eapply Permutation_map in  H as H'.
    unfold LEncode; rewrite <- H'...
    apply IHLMSeq...
    rewrite H...
Qed.

Ltac toLM H :=
  match (type of H) with
  | In (u| _ |)(LEncode _ ++ REncode _) =>
    apply upRight in H; apply OLInPermutation in H;CleanContext
  | In (d| _ |)(LEncode _) =>
    apply OLInPermutationL in H;CleanContext;
    eapply LMEx; [apply Permutation_sym;eauto | ]
  | seqN _ _ (u| ?F | :: LEncode ?L ++ REncode ?R) [] (> []) =>
    apply exchangeCCN with (CC' := LEncode L ++ REncode (F :: R)) in H ;[| simpl; perm]
  | seqN _ _ (u| ?F | :: ?T :: LEncode ?L ++ REncode ?R) [] (> []) =>
    apply exchangeCCN with (CC' := T :: LEncode L ++ REncode (F :: R)) in H ;[| simpl; perm]
  | seqN _ _ (d| ?F | :: LEncode ?L ++ REncode ?R) [] (> []) =>
    apply exchangeCCN with (CC' := LEncode (F :: L) ++ REncode R) in H ;[| simpl; perm]
  | seqN _ _ (d| ?F | :: ?T :: LEncode ?L ++ REncode ?R) [] (> []) =>
    apply exchangeCCN with (CC' := T :: LEncode (F::L) ++ REncode R) in H ;[| simpl; perm]
  end.

(** Completeness *)
Theorem Completeness: forall n L F ,
    isOLFormulaL L ->
    isOLFormula F ->
    seqN OLTheory n (LEncode L)  (REncode [F]) (> []) ->
    LMSeq L F .
Proof with solveF;solveLL;SolveIS;CleanContext.
  induction n using strongind;intros.
  inversion H1.

  inversion H2;subst.
  simpl in H5.
  apply RemoveUnique in H5...
  apply InIsPositiveL in H5;contradiction.
  inversion H4...
  + (* from the theory *)
    inversion H3...
    ++ (* Constants *)
      destruct C.
    ++ (* Constants *)
      destruct C.
    ++ (* binary connective right *)
      apply FocusingRightRule in H6...
      (* by cases on C *)
      destruct C;simpl in H8...
      { (* case AND *)
        apply AppPLUSWITHRight in H8...
        apply LMAndR; apply (H x0)...
      }
    { (* impl *)
        apply AppTENSORPARRight in H8...
        apply LMImpR.
        apply (H x0)...
      }
    ++  (* binary connective left *)
      apply FocusingLeftRule in H6...
      (* by cases on C *)
      destruct C;simpl in H8...
      { (* case AND *)
        apply AppPLUSWITHLeft in H8...
        destruct H8.
        + toLM H7.
          apply LMContr.
          apply LMAndL1; rewrite <- H7.
          eapply (H x0)...
        + toLM H7.
          apply LMContr.
          apply LMAndL2; rewrite <- H7.
          eapply (H x0)...
      }
      { (* impl *)
        apply AppTENSORPARLeft in H8...
        toLM H7.
        apply LMContr.
        apply LMImpL; rewrite <- H6; eapply (H x0)...
      }
    ++ (* Quantifier right *)
      apply FocusingRightQ in H6...
      (* by cases on C*)
      destruct C;simpl in H9...
      { (* case ALL *)
        apply AppALLSOMERight in H9...
        apply LMAllR;intros...
        specialize (H8 x H6).
        eapply (H x0)...
      }
    ++ (* Quantifier left *)
      apply FocusingLeftQ in H6...
      (* by cases on C*)
      destruct C;simpl in H9...
      { (* case ALL *)
        apply AppALLSOMELeft in H9...
        toLM H8.
        apply LMContr.
        apply LMAllL with (t:= x1)...
        rewrite <- H6; eapply (H x0)...
      }

  + (* init *)
    apply Init_inversion1 in H6...
    toLM H6.
    apply LMinit.
Qed.

Theorem Adequacy:  forall L F ,
    isOLFormulaL L ->
    isOLFormula F ->
    (
      seq OLTheory  (LEncode L) (REncode [F]) (> []) <->
      LMSeq L F ).
Proof with solveF;solveLL.
  intros.
  split;intros.
  + apply seqtoSeqN in H1;CleanContext.
    apply  Completeness in H1...
  +  apply Soundeness in H1...
Qed.

(** The cut-elimination theorem instantiated for LM *)
Check Adequacy .
Check CutElimination.


Require Import Iron.Language.SystemF.SubstTypeExp.
Require Import Iron.Language.SystemF.SubstExpExp.
Require Export Iron.Language.SystemF.Exp.

(* Small step evaluation *)
Inductive STEP : exp -> exp -> Prop :=
  (* value applications *)
  | ESLamApp
    :  forall t11 x12 v2
    ,  value v2
    -> STEP (XApp (XLam t11 x12) v2) (substXX 0 v2 x12)

  | ESApp1
    :  forall x1 x1' x2
    ,  STEP x1 x1'
    -> STEP (XApp x1 x2) (XApp x1' x2)

  | ESApp2
    :  forall v1 x2 x2'
    ,  value v1
    -> STEP x2 x2'
    -> STEP (XApp v1 x2) (XApp v1 x2')

  (* type applications *)
  | ESLAMAPP
    :  forall x12 t2
    ,  STEP (XAPP (XLAM x12) t2) (substTX 0 t2 x12)

  | ESAPP1
    :  forall x1 x1' t2
    ,  STEP x1 x1'
    -> STEP (XAPP x1 t2) (XAPP x1' t2).

Hint Constructors STEP.

(********************************************************************)
(* Multi-step evaluation.
   A sequence of small step transitions.
   As opposed to STEPSL, this version has an append constructor
   ESAppend that makes it easy to join two evaluations together.
   We use this when converting big-step evaluations to small-step.
 *)
Inductive STEPS : exp -> exp -> Prop :=

 (* After no steps, we get the same exp.
    We need this constructor to match the EVDone constructor
    in the big-step evaluation, so we can convert between big-step
    and multi-step evaluations. *)
 | ESNone
   :  forall x1
   ,  STEPS x1 x1

 (* Take a single step. *)
 | ESStep
   :  forall x1 x2
   ,  STEP  x1 x2
   -> STEPS x1 x2

 (* Combine two evaluations into a third. *)
 | ESAppend
   :  forall x1 x2 x3
   ,  STEPS x1 x2 -> STEPS x2 x3
   -> STEPS x1 x3.

Hint Constructors STEPS.

(* Context lemmas
   These help when proving something about a reduction in a given
   context. They're all trivial.
   TODO: Define contexts directly like in the Simple proof.
 *)
Lemma steps_app1
 :  forall x1 x1' x2
 ,  STEPS x1 x1'
 -> STEPS (XApp x1 x2) (XApp x1' x2).
Proof.
 intros. induction H; eauto.
Qed.
Hint Resolve steps_app1.

Lemma steps_app2
 :  forall v1 x2 x2'
 ,  value v1
 -> STEPS x2 x2'
 -> STEPS (XApp v1 x2) (XApp v1 x2').
Proof.
 intros. induction H0; eauto.
Qed.
Hint Resolve steps_app2.

Lemma steps_APP1
 :  forall x1 x1' t2
 ,  STEPS x1 x1'
 -> STEPS (XAPP x1 t2) (XAPP x1' t2).
Proof.
 intros. induction H; eauto.
Qed.

(********************************************************************)
(* Left linearised multi-step evaluation
   As opposed to STEPS, this version provides a single step at a time
   and does not have an append constructor. This is convenient
   when converting a small-step evaluations to big-step, via the
   eval_expansion lemma.
 *)
Inductive STEPSL : exp -> exp -> Prop :=

 | ESLNone
   : forall x1
   , STEPSL x1 x1

 | ESLCons
   :  forall x1 x2 x3
   ,  STEP   x1 x2 -> STEPSL x2 x3
   -> STEPSL x1 x3.

Hint Constructors STEPSL.

(* Transitivity of left linearised multi-step evaluation.
   We use this when "flattening" a big step evaluation to the
   small step one.
 *)
Lemma stepsl_trans
 :  forall x1 x2 x3
 ,  STEPSL x1 x2 -> STEPSL x2 x3
 -> STEPSL x1 x3.
Proof.
 intros.
 induction H.
  eauto.
  eapply ESLCons. eauto. eauto.
Qed.

(* Linearise a regular multi-step evaluation.
   This flattens out all the append constructors, leaving us with
   a list of individual transitions.
 *)
Lemma stepsl_of_steps
 :  forall x1 x2
 ,  STEPS  x1 x2
 -> STEPSL x1 x2.
Proof.
 intros.
 induction H.
  auto.
  eauto.
  eapply stepsl_trans; eauto.
Qed.


(** * Utils/tactics.v
-----------------

Provides the definition of a number of helper tactics used to automate
common proof steps that arise when reasoning about probabilistic
computations.*)

From mathcomp.ssreflect Require Import
     ssreflect ssrbool ssrnat eqtype fintype
     choice ssrfun seq path bigop finfun binomial.

From mathcomp.ssreflect Require Import tuple.

From mathcomp Require Import path.

From infotheo Require Import
      fdist ssrR Reals_ext logb ssr_ext ssralg_ext bigop_ext Rbigop proba.

Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.Logic.FunctionalExtensionality.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

From ProbHash.Computation
     Require Import Comp Notationv1.

From ProbHash.Core
     Require Import Hash HashVec  FixedList  FixedMap.

From ProbHash.Utils
     Require Import InvMisc seq_ext seq_subset rsum_ext stirling.

Lemma eq_rmull (f g x: Rdefinitions.R) :
  f = g -> (f *R* x) = (g *R* x).
Proof. by move=>->. Qed.

Lemma eq_rmulr (f g x: Rdefinitions.R) :
  f = g -> (x *R* f) = (x *R* g).
Proof. by move=>->. Qed.
Lemma cons_tuple_base (A:Type) (a:A) : [tuple a] = cons_tuple a [tuple].
Proof. by rewrite cons_tuple_eq_tuple //=. Qed.

(**
Normalizes a probabilistic computation into a standard form where the steps
of the computation are multiplied together
P[ c1; c2; c3; ...] => \sum ... \sum P[ c1 = x1 ] * P[c2 = x2] ....
 *)
Ltac comp_normalize :=
  match goal with
  | [ |-  context [FDistBind.d _ _  ] ] => rewrite !FDistBind.dE //=; comp_normalize
  | [ |-  context [Uniform.d _  ] ] => rewrite !Uniform.dE //=; comp_normalize
  | [ |- context [FDist1.d _]] => rewrite !FDist1.dE //=; comp_normalize
  | [ |- context [(cons_tuple _ _ )]] => rewrite -cons_tuple_eq_tuple; comp_normalize
  | [ |- context [(_ *R* _)]] => rewrite !(rsum_Rmul_distr_l, rsum_Rmul_distr_r, mulR1, mulR0, mul1R, mul0R) //=; comp_normalize
  | [ |- context [(d[ _ ])] ] => rewrite //= !FDistBind.dE //=; comp_normalize
  | [ |- context [\sum_(_ in _) _]] =>
    rewrite ?( rsum_empty, rsum_split, rsum_Rmul_distr_l, rsum_Rmul_distr_r)
            //=; tryif under eq_bigr => ? ? do idtac then under eq_bigr => ? ? do comp_normalize else comp_normalize
  | [ |- context [(?X1 *R* ?X2)]] => progress (under eq_rmull do comp_normalize);
                                     progress (under eq_rmulr do comp_normalize); comp_normalize
  | [ |- _ ] => idtac
  end.

(** pulls the nth (0-indexed) summation to the outermost point *)
Ltac exchange_big_outwards n :=
  match n with
  |  ?n'.+1 => (under eq_bigr => ? ? do try exchange_big_outwards n'); rewrite exchange_big
  | 0 => idtac
  end.

(** moves the outermost summation to the innermost and then executes tactic f in that context
                                                    b,c
----------------------------------                ----------------------------------
\sum_{a) \sum_{b} \sum_{c} g(a,b,c)        =>      \sum_{a) g(a,b,c)                     => apply f.
 *)
Ltac exchange_big_inwards f :=
  match goal  with
  |  [ |- context [\sum_(_ in _) _ ] ] => rewrite exchange_big //=; under eq_bigr => ? ? do exchange_big_inwards f
  |  [ |- context [\sum_(_ in _) _ ] ] =>  f
  |  [ |- _ ] => fail
  end.

(** applies the provided tactic under all the summations *)
Ltac under_all x :=
  match goal  with
  |  [ |- context [\sum_(_ in _) _ ] ] =>  under eq_bigr => ? ? do (under_all x)
  | _ => x
  end.

(**
Given a summation index, rearranges the goal such that any equalities on the index are brought to the left.
Once in this form, -big_pred_demote can be applied to raise the equality into the summation index,
and big_pred1_eq can then be used to simplify the summation.
 *)
Ltac comp_simplify_eq x :=
  match goal with
  | [ |-  (Under_rel _ _ ((_ (x == _) %R) *R* _)) _ ] => idtac
  | [ |-  (((_ (x == _) %R) *R* _)) ] => idtac
  | [ |-  context [(_ (_ == x) %R)] ] => rewrite [_ == x]eq_sym; comp_simplify_eq x
  | [ |- context [(((_ (x == _) %R) *R* _) *R* _)] ] =>
    rewrite -[(((_ (x == _) %R) *R* _) *R* _)]mulRA;
    comp_simplify_eq x
  | [ |- context [(_ *R* ((_ (x == _) %R) *R* _))] ] =>
    rewrite
      [(_ *R* ((_ (x == _) %R) *R* _))]mulRA
      [(_ *R* (_ (x == _) %R))]mulRC
    -[(((_ (x == _) %R) *R* _) *R* _)]mulRA;  comp_simplify_eq x
  | [ |- context [(_ *R* (_ (x == _) %R))] ] =>
    rewrite [(_ *R* (_ (x == _) %R))]mulRC; comp_simplify_eq x
  | [ |- context [(x,_) == (_,_)]] =>
    rewrite [(x,_) == (_,_)]xpair_eqE
            [((x == _) && _  %R)]boolR_distr; comp_simplify_eq x
  | [ |- context [(_,x) == (_,_)]] =>
    rewrite [(_,x) == (_,_)]xpair_eqE
            [(_ && (x == _) %R)]boolR_distr; comp_simplify_eq x
  | [ |- context [(_,_) == (x,_)]] =>
    rewrite [(_,_) == (x,_)]xpair_eqE
            [((_ == x) && _ %R)]boolR_distr; comp_simplify_eq x
  | [ |- context [(_,_) == (_,x)]] =>
    rewrite [(_,_) == (x,_)]xpair_eqE
            [(_ && (_ == x) %R)]boolR_distr; comp_simplify_eq x
  | [ |- context [(cons_tuple _ _)]] =>
    rewrite !(xpair_eqE, xcons_eqE, cons_tuple_eq_tuple, cons_tuple_base, ntuple_cons_eq, ntuple_tailE);
    comp_simplify_eq x
  | [ |- _ ] => fail
  end.

(**
 Recursively attempts to perform probabilistic beta reduction with every summation index in context
 *)
Ltac comp_simplify_internal :=
  match goal with
  | [|- context [\sum_(i in _) _]] =>
    progress (exchange_big_inwards
                ltac:(
                (* once we've moved the summation to the inside *)
                (* move the equalities on the summation index to start of the summand  *)
                under eq_bigr => i _ do comp_simplify_eq i;
                                 (* promote equality on summation index to summation and simplify
                 i.e \sum(i in _) (i == 3 * f(i) ...) =>
                     \sum(i == 3 ) (f(i) ...) =>
                     f(3) ... *)
                                 ((
                                     rewrite -rsum_pred_demote big_pred1_eq //=

                                   ) ||
                                  (* if that failed, it could be because the summation already has some predicate:
                            \sum(i | P i) (i == 3 * f(i) ...)
                           if so, the demote the existing predicate, and retry
                            \sum(i) (P i * i == 3 * f(i) ...)
                                   *)
                                  (
                                    rewrite rsum_pred_demote;
                                    under eq_bigr => i Hi do  comp_simplify_eq i; rewrite -rsum_pred_demote big_pred1_eq //=))
             )) ||
             (
               under eq_bigr => ? ? do progress comp_simplify_internal)
  end.

(**
  Performs beta reduction until no further progress is made
 *)
Ltac comp_simplify :=
  do !(progress comp_simplify_internal).

(**
  Same as comp_simplify, but only runs a fixed number of times
  (sometimes comp_simplify_internal can exchange the order of summands without making progress)
 *)
Ltac comp_simplify_n n :=
  do n!(progress comp_simplify_internal).

(** dispatches 0 <= obligations that arise during proofs *)
Ltac dispatch_eq0_obligations :=
  intros;
  match goal with
  | [|- context [_ *R* _]] => apply RIneq.Rmult_le_pos
  | [|- context [\sum_(_ in _) _]] => apply rsumr_ge0
  | [|- context [#| _ |]] => rewrite card_ord
  | [|- context [_ -<=- _]] => apply fdist_ge0_le1 || apply leR0n || apply prob_invn
  | [|- context [Rdefinitions.Rinv (?x.+1 %R)]] => rewrite -add1n
  end.

(** given that a probabilistic computation is possible (d[ c1; c2; c3] v) != 0,
   derives that individual statements of computation are also possible
 *)
Ltac comp_possible_decompose  :=
  match goal with
  | [ |- ((?X ->- ?Y)) -> ?F ] =>
    move=> /RIneq.Rgt_not_eq; comp_possible_decompose
  | [ |- (is_true (?X != ?Y)) -> ?F ] =>
    move=>/eqP; comp_possible_decompose
  | [ |- ( (?X *R* ?Y <> ?Z)) -> ?F ] =>
    move=>/RIneq.Rmult_neq_0_reg [];
    comp_possible_decompose
  | [ |- ( (?X <> ?Y)) -> ?F ] =>
    let name := fresh "value" in
    (move=> /prsumr_ge0; case; first (by do?dispatch_eq0_obligations);
            move=> name; comp_possible_decompose; move:name)
    || ( move=>/eqP name; comp_possible_decompose; move: name )                                                          | _ => idtac
  end.

(** simplifies a  impossibility statement i.e (c1 * c2 * c3 = 0)
by automatically solving any cases with booleans and introducing
them into the context:
i.e (i == g (y)) * f = 0  -> i = g(y) -> f = 0
intended to be used internally by comp impossible_decompose
 *)
Ltac comp_impossible_simpl :=
  move=>//=;
      match goal with
      | [ |- context [(true == _)] ] => rewrite eq_sym; comp_impossible_simpl
      | [ |- context [(_ == true)] ] => rewrite eqb_id; comp_impossible_simpl
      | [ |- context [(_ && _)]] => rewrite boolR_distr; comp_impossible_simpl
      | [ |- context [((_,_) == (_,_))]] => rewrite xpair_eqE; comp_impossible_simpl
      | [ |- context [(nat_of_bool ?X %R)]] =>
        let tmp := fresh "tmp" in
        let name := fresh "P" in case tmp: X; move: tmp => name; rewrite //= ?(mulR0,mul0R,mulR1,mul1R); try (by []);
                                                           comp_impossible_simpl;
                                                           move: name
      | [ |- ?X ] => idtac
      end.

(**
 automatically decomposes an impossibility statement (\sum_{v1} ... \sum_{vn} P[c1 = v1] * ... *  P[ cn = vn ] = 0)
 into properties about its component parts (forall v1,..,vn, P[c1 = v1] * ... * P[cn = vn] = 0)
 *)
Ltac comp_impossible_decompose  :=
  match goal with
  | [ |- ( ?X = _) ] =>
    let value_name := fresh "value" in
    let hyp_name := fresh "P_value" in
    apply prsumr_eq0P => value_name hyp_name; first (by do?dispatch_eq0_obligations);
                         comp_impossible_decompose;
                         move: value_name hyp_name

  | _ => idtac
  end;
  comp_impossible_simpl.

(**
   decomposes a possibility goal into a corresponding sequence of existence proofs - i.e
  (\sum_{v1} ... \sum_{vn} P[c1 = v1] * ... *  P[ cn = vn ] != 0)  ->
  (exists v1,...,vn,  P[c1 = v1] * ... *  P[ cn = vn ] != 0)
 *)
Ltac comp_possible_exists  :=
  match goal with
  | [ |- context [((?X ->- ?Y))]  ] =>
    apply/RIneq.Rgt_not_eq; comp_possible_exists
  | [ |- context [ (?X <> ?Y) ] ] =>
    apply/eqP; comp_possible_exists
  | [ |- context [(?X != ?Y)] ] =>
    let value_name := fresh "value" in
     rewrite prsumr_neq0_eq; last (by do?dispatch_eq0_obligations);
     under eq_existsb => value_name do comp_possible_exists
  | _ => idtac
  end;
  move=>//=.


(** (This following part of this file is copied from <<Software Foundation>>
volume 1 & 2. It should be only used for lecture notes and homework assignments
for course CS263 of Shanghai Jiao Tong University, 2020 spring. Any other usage
are not allowed. For the material of thses parts, please refer to the original
book.) *)

Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import PL.RTClosure.
Local Open Scope Z.
Local Open Scope string.
Local Open Scope list.

Module LambdaIB.

Inductive op : Type :=
  | Oplus
  | Ominus
  | Omult
  | Oeq
  | Ole
  | Onot
  | Oand
  | Oifthenelse.

Inductive constant : Type :=
  | int_const (n: Z): constant
  | bool_const (b: bool): constant
  | op_const (o: op): constant.

Inductive tm : Type :=
  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> tm -> tm
  | con : constant -> tm.

Coercion var: string >-> tm.
Coercion op_const: op >-> constant.
Coercion bool_const: bool >-> constant.
Coercion int_const: Z >-> constant.
Coercion con: constant >-> tm.

Example do_it_three_times: tm :=
  abs "f" (abs "x" (app "f" (app "f" (app "f" "x")))).

Example add_one: tm :=
  abs "x" (app (app Oplus "x") 1).

Example square: tm :=
  abs "x" (app (app Omult "x") "x").

Inductive tm_base_halt: tm -> Prop :=
  | BH_plus: forall n: Z, tm_base_halt (app Oplus n)
  | BH_minus: forall n: Z, tm_base_halt (app Ominus n)
  | BH_mult: forall n: Z, tm_base_halt (app Omult n)
  | BH_eq: forall n: Z, tm_base_halt (app Oeq n)
  | BH_le: forall n: Z, tm_base_halt (app Ole n)
  | BH_and: forall b: bool, tm_base_halt (app Oand b)
  | BH_if1: forall b: bool, tm_base_halt (app Oifthenelse b)
  | BH_if2: forall (b: bool) (t: tm), tm_base_halt (app (app Oifthenelse b) t).

Inductive tm_base_pend: tm -> Prop :=
  | BP_plus: forall n: Z, tm_base_pend (app Oplus n)
  | BP_minus: forall n: Z, tm_base_pend (app Ominus n)
  | BP_mult: forall n: Z, tm_base_pend (app Omult n)
  | BP_eq: forall n: Z, tm_base_pend (app Oeq n)
  | BP_le: forall n: Z, tm_base_pend (app Ole n)
  | BP_and_true: tm_base_pend (app Oand true).

Inductive tm_halt: tm -> Prop :=
  | H_abs: forall x t, tm_halt (abs x t)
  | H_con: forall c, tm_halt (con c)
  | H_base: forall t, tm_base_halt t -> tm_halt t.

Inductive tm_pend: tm -> Prop :=
  | P_abs: forall x t, tm_pend (abs x t)
  | P_con: forall c, tm_pend (con c)
  | P_base: forall t, tm_base_pend t -> tm_pend t.

Inductive base_step: tm -> tm -> Prop :=
  | BS_plus: forall n1 n2: Z, base_step (app (app Oplus n1) n2) (n1 + n2)
  | BS_minus: forall n1 n2: Z, base_step (app (app Ominus n1) n2) (n1 - n2)
  | BS_mult: forall n1 n2: Z, base_step (app (app Omult n1) n2) (n1 * n2)
  | BS_eq_true: forall n1 n2: Z,
                  n1 = n2 -> base_step (app (app Oeq n1) n2) (true)
  | BS_eq_false: forall n1 n2: Z,
                  n1 <> n2 -> base_step (app (app Oeq n1) n2) (false)
  | BS_le_true: forall n1 n2: Z,
                  n1 <= n2 -> base_step (app (app Ole n1) n2) (true)
  | BS_le_false: forall n1 n2: Z,
                  n1 > n2 -> base_step (app (app Ole n1) n2) (false)
  | BS_not: forall b: bool, base_step (app Onot b) (negb b)
  | BS_and_true: forall b: bool, base_step (app (app Oand true) b) b
  | BS_and_false: forall t: tm, base_step (app (app Oand false) t) false
  | BS_if_true: forall t1 t2: tm,
                  base_step (app (app (app Oifthenelse true) t1) t2) t1
  | BS_if_false: forall t1 t2: tm,
                  base_step (app (app (app Oifthenelse false) t1) t2) t2
.

Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
  match t with
  | var x' =>
      if string_dec x x' then s else t
  | abs x' t1 =>
      abs x' (if string_dec x x' then t1 else subst x s t1)
  | app t1 t2 =>
      app (subst x s t1) (subst x s t2)
  | con c =>
      con c
  end.

Notation "t [ x |-> s ]" := (subst x s t) (at level 10, x at next level).

Inductive step: tm -> tm -> Prop :=
  | S_base: forall t t',
              base_step t t' -> step t t'
  | S_beta: forall x t1 t2,
              tm_halt t2 -> step (app (abs x t1) t2) (t1 [ x |-> t2])
  | S_app1: forall t1 t1' t2,
              step t1 t1' -> step (app t1 t2) (app t1' t2)
  | S_app2: forall t1 t2 t2',
              tm_pend t1 -> step t2 t2' -> step (app t1 t2) (app t1 t2')
.

Definition is_base_halting (t: tm): bool :=
  match t with
  | app (con (op_const Oplus)) (con (int_const _)) => true
  | app (con (op_const Ominus)) (con (int_const _)) => true
  | app (con (op_const Omult)) (con (int_const _)) => true
  | app (con (op_const Oeq)) (con (int_const _)) => true
  | app (con (op_const Ole)) (con (int_const _)) => true
  | app (con (op_const Oand)) (con (bool_const _)) => true
  | app (con (op_const Oifthenelse)) (con (bool_const _)) => true
  | app
      (app (con (op_const Oifthenelse)) (con (bool_const _)))
      (con (int_const _)) => true
  | _ => false
  end.

Definition is_base_pending (t: tm): bool :=
  match t with
  | app (con (op_const Oplus)) (con (int_const _)) => true
  | app (con (op_const Ominus)) (con (int_const _)) => true
  | app (con (op_const Omult)) (con (int_const _)) => true
  | app (con (op_const Oeq)) (con (int_const _)) => true
  | app (con (op_const Ole)) (con (int_const _)) => true
  | app (con (op_const Oand)) (con (bool_const true)) => true
  | _ => false
  end.

Definition is_halting (t: tm): bool :=
  match t with
  | abs _ _ => true
  | con _ => true
  | _ => is_base_halting t
  end.

Definition is_pending (t: tm): bool :=
  match t with
  | abs _ _ => true
  | con _ => true
  | _ => is_base_pending t
  end.

Definition base_next_state (t: tm): option tm :=
  match t with
  | app (app Oplus (con (int_const n1))) (con (int_const n2)) =>
      Some (con (int_const (n1 + n2)))
  | app (app Ominus (con (int_const n1))) (con (int_const n2)) =>
      Some (con (int_const (n1 - n2)))
  | app (app Omult (con (int_const n1))) (con (int_const n2)) =>
      Some (con (int_const (n1 * n2)))
  | app (app Oeq (con (int_const n1))) (con (int_const n2)) =>
      if Z.eq_dec n1 n2
      then Some (con (bool_const true))
      else Some (con (bool_const false))
  | app (app Ole (con (int_const n1))) (con (int_const n2)) =>
      if Z_le_gt_dec n1 n2
      then Some (con (bool_const true))
      else Some (con (bool_const false))
  | app Onot (con (bool_const b)) =>
      Some (con (bool_const (negb b)))
  | app (app Oand (con (bool_const true))) (con (bool_const b)) =>
      Some (con (bool_const b))
  | app (app Oand (con (bool_const false))) _ =>
      Some (con (bool_const false))
  | app (app (app Oifthenelse (con (bool_const true))) t1) _ =>
      Some t1
  | app (app (app Oifthenelse (con (bool_const false))) _) t2 =>
      Some t2
  | _ => None
  end.

Definition beta_next_state (t: tm): option tm :=
  match t with
  | app (abs x t1) t2 => Some (t1 [x |-> t2])
  | _ => None
  end.

Definition core_next_state (t: tm): option tm :=
  match beta_next_state t, base_next_state t with
  | Some t', _ => Some t'
  | _, Some t' => Some t'
  | _, _ => None
  end.

Fixpoint next_state (t: tm): option tm :=
  match t with
  | app t1 t2 =>
      match next_state t1 with
      | Some t1' => Some (app t1' t2)
      | None => if is_pending t1
                then match next_state t2 with
                     | Some t2' => Some (app t1 t2')
                     | None => if is_halting t2
                               then core_next_state t
                               else None
                     end
                else base_next_state t
      end
  | _ => None
  end.

Ltac case_analysis_and_discriminiate H :=
  match type of H with
  | match ?t with _ => _ end = _ =>
      destruct t;
      match type of H with
      | false = true => discriminate H
      | None = Some _ => discriminate H
      | Some _ = Some _ => injection H as H
      | _ => idtac
      end
  end.

Lemma is_base_halting_sound: forall t,
  is_base_halting t = true ->
  tm_base_halt t.
Proof.
  intros.
  unfold is_base_halting in H.
  repeat case_analysis_and_discriminiate H; constructor.
Qed.

Lemma is_base_pending_sound: forall t,
  is_base_pending t = true ->
  tm_base_pend t.
Proof.
  intros.
  unfold is_base_pending in H.
  repeat case_analysis_and_discriminiate H; constructor.
Qed.

Lemma is_halting_sound: forall t,
  is_halting t = true ->
  tm_halt t.
Proof.
  intros.
  unfold is_halting in H.
  repeat case_analysis_and_discriminiate H; try constructor.
  + apply is_base_halting_sound in H; auto.
  + apply is_base_halting_sound in H; auto.
Qed.

Lemma is_pending_sound: forall t,
  is_pending t = true ->
  tm_pend t.
Proof.
  intros.
  unfold is_pending in H.
  repeat case_analysis_and_discriminiate H; try constructor.
  + apply is_base_pending_sound in H; auto.
  + apply is_base_pending_sound in H; auto.
Qed.

Lemma base_next_state_sound: forall t t',
  base_next_state t = Some t' ->
  base_step t t'.
Proof.
  intros.
  unfold base_next_state in H.
  repeat case_analysis_and_discriminiate H; try (subst; constructor).
  + reflexivity.
  + tauto.
  + tauto.
  + tauto.
Qed.

Lemma beta_next_state_sound: forall t1 t2 t',
  tm_halt t2 ->
  beta_next_state (app t1 t2) = Some t' ->
  step (app t1 t2) t'.
Proof.
  intros.
  unfold beta_next_state in H0.
  repeat case_analysis_and_discriminiate H0.
  subst.
  apply S_beta, H.
Qed.

Lemma core_next_state_sound: forall t1 t2 t',
  tm_halt t2 ->
  core_next_state (app t1 t2) = Some t' ->
  step (app t1 t2) t'.
Proof.
  intros.
  unfold core_next_state in H0.
  destruct (beta_next_state (app t1 t2)) eqn:?H.
  + injection H0 as H0; subst t'.
    apply beta_next_state_sound; tauto.
  + destruct (base_next_state (app t1 t2)) eqn:?H; [| discriminate H0].
    injection H0 as H0; subst t'.
    apply base_next_state_sound in H2.
    apply S_base; tauto.
Qed.

Arguments base_next_state: simpl never.
Arguments beta_next_state: simpl never.
Arguments core_next_state: simpl never.

Lemma next_state_sound: forall t t',
  next_state t = Some t' ->
  step t t'.
Proof.
  intros.
  revert t' H; induction t; intros; simpl in H;
    [discriminate H | | discriminate H | discriminate H].
  destruct (next_state t1) eqn:?H in H.
  {
    apply IHt1 in H0.
    injection H as H; subst t'.
    apply S_app1, H0.
  }
  destruct (is_pending t1) eqn:?H in H.
  2: {
    apply base_next_state_sound in H.
    apply S_base, H.
  }
  apply is_pending_sound in H1.
  destruct (next_state t2) eqn:?H in H.
  {
    apply IHt2 in H2.
    injection H as H; subst t'.
    apply S_app2; tauto.
  }
  destruct (is_halting t2) eqn:?H in H.
  {
    apply is_halting_sound in H3.
    apply core_next_state_sound; tauto.
  }
  {
    discriminate H.
  }
Qed.

Inductive ty : Type :=
  | TBool : ty
  | TInt : ty
  | TArrow : ty -> ty -> ty.

Notation "T1 ~> T2" := (TArrow T1 T2) (right associativity, at level 30).

Definition context := string -> option ty.

Definition empty_context: context := fun _ => None.

Definition context_update (Gamma : context) (x : string) (T : ty) :=
  fun x' => if string_dec x x' then Some T else Gamma x'.

Notation "x '|->' T ';' Gamma" := (context_update Gamma x T)
  (at level 100, T at next level, right associativity).

Inductive op_type: op -> ty -> Prop :=
  | OT_plus: op_type Oplus (TInt ~> TInt ~> TInt)
  | OT_minus: op_type Ominus (TInt ~> TInt ~> TInt)
  | OT_mult: op_type Omult (TInt ~> TInt ~> TInt)
  | OT_eq: op_type Oeq (TInt ~> TInt ~> TBool)
  | OT_le: op_type Ole (TInt ~> TInt ~> TBool)
  | OT_not: op_type Onot (TBool ~> TBool)
  | OT_and: op_type Oand (TBool ~> TBool ~> TBool)
  | OT_if: forall T, op_type Oifthenelse (TBool ~> T ~> T ~> T)
.

Inductive const_type: constant -> ty -> Prop :=
  | CT_int: forall n, const_type (int_const n) TInt
  | CT_bool: forall b, const_type (bool_const b) TBool
  | CT_op: forall o T, op_type o T -> const_type (op_const o) T
.

Inductive has_type: context -> tm -> ty -> Prop :=
  | T_var : forall Gamma x T,
      Gamma x = Some T ->
      has_type Gamma (var x) T
  | T_abs : forall Gamma x T11 T12 t12,
      has_type (x |-> T11 ; Gamma) t12 T12 ->
      has_type Gamma (abs x t12) (T11 ~> T12)
  | T_app : forall T11 T12 Gamma t1 t2,
      has_type Gamma t1 (T11 ~> T12) ->
      has_type Gamma t2 T11 ->
      has_type Gamma (app t1 t2) T12
  | T_con : forall T Gamma c,
      const_type c T ->
      has_type Gamma (con c) T
.

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

Ltac base_deduce_types_from_head H :=
  match type of H with
  | const_type (int_const _) _ =>
    inversion H
  | const_type (bool_const _) _ =>
    inversion H
  | const_type (op_const _) _ =>
    let H1 := fresh "H" in
    inversion H as [| | ? ? H1]; subst;
    base_deduce_types_from_head H1;
    clear H1
  | op_type _ _ =>
    inversion H; subst
  | _ => idtac
  end.

Example type_of_add_one: empty_context |- add_one \in (TInt ~> TInt).
Proof.
  unfold add_one.
  apply T_abs.
  eapply T_app.
  + eapply T_app.
    - constructor.
      constructor.
      constructor.
    - constructor.
      unfold context_update; simpl.
      reflexivity.
  + constructor.
    constructor.
Qed.

Example type_of_do_it_three_times: forall T,
  empty_context |- do_it_three_times \in ((T ~> T) ~> (T ~> T)).
Proof.
  intros.
  unfold do_it_three_times.
  apply T_abs.
  apply T_abs.
  eapply T_app.
  {
    constructor.
    unfold context_update; simpl.
    reflexivity.
  }
  eapply T_app.
  {
    constructor.
    unfold context_update; simpl.
    reflexivity.
  }
  eapply T_app.
  {
    constructor.
    unfold context_update; simpl.
    reflexivity.
  }
  {
    constructor.
    unfold context_update; simpl.
    reflexivity.
  }
Qed.

Ltac deduce_types_from_head H :=
  match type of H with
  | _ |- app _ _ \in _ =>
    let H1 := fresh "H" in
    let H2 := fresh "H" in
    inversion H as [| | ? ? ? ? ? H1 H2 | ]; subst;
    deduce_types_from_head H1;
    clear H1
  | _ |- con _ \in _ =>
    let H1 := fresh "H" in
    inversion H as [| | | ? ? ? H1 ]; subst;
    base_deduce_types_from_head H1;
    clear H1
  | _ => idtac
  end.

Lemma eval_result_bool : forall (t: tm),
  empty_context |- t \in TBool ->
  tm_halt t ->
  exists b: bool, t = b.
Proof.
  intros.
  inversion H; subst.
  + discriminate H1.
  + inversion H0; subst.
    inversion H3; subst; deduce_types_from_head H1.
  + inversion H1; subst.
    - exists b; reflexivity.
    - inversion H2.
Qed.

Lemma eval_result_int : forall (t: tm),
  empty_context |- t \in TInt ->
  tm_halt t ->
  exists n: Z, t = n.
Proof.
  intros.
  inversion H; subst.
  + discriminate H1.
  + inversion H0; subst.
    inversion H3; subst; deduce_types_from_head H1.
  + inversion H1; subst.
    - exists n; reflexivity.
    - inversion H2.
Qed.

Ltac deduce_int_bool_result H1 H2 :=
  first
    [ let n := fresh "n" in
      let H := fresh "H" in
      pose proof eval_result_int _ H1 H2 as [n H]
    | let b := fresh "b" in
      let H := fresh "H" in
      pose proof eval_result_bool _ H1 H2 as [b H]
    ].

Inductive halt_not_pend: tm -> Prop :=
  | HNP_and_false:
      halt_not_pend (app Oand false)
  | HNP_if1: forall b: bool,
      halt_not_pend (app Oifthenelse b)
  | HNP_if2: forall (b: bool) (t: tm),
      halt_not_pend (app (app Oifthenelse b) t).

Lemma base_pend_or_not_pend: forall t,
  tm_base_halt t ->
  tm_base_pend t \/ halt_not_pend t.
Proof.
  intros.
  inversion H; try first [left; constructor | right; constructor].
  subst t.
  destruct b; [left | right]; constructor.
Qed.

Lemma pend_or_not_pend: forall t,
  tm_halt t ->
  tm_pend t \/ halt_not_pend t.
Proof.
  intros.
  inversion H.
  + subst.
    left.
    apply P_abs.
  + subst.
    left.
    apply P_con.
  + subst.
    apply base_pend_or_not_pend in H0.
    destruct H0; [| tauto].
    left.
    apply P_base, H0.
Qed.

Lemma app_not_pending_progress: forall t1 t2 T11 T12,
  empty_context |- t1 \in (T11 ~> T12) ->
  empty_context |- t2 \in T11 ->
  halt_not_pend t1 ->
  tm_halt (app t1 t2) \/ exists t', step (app t1 t2) t'.
Proof.
  intros.
  inversion H1; subst.
  + right.
    eexists.
    apply S_base.
    constructor.
  + left.
    apply H_base.
    constructor.
  + right.
    destruct b; eexists; apply S_base; constructor.
Qed.

Lemma app_const_halting_progress: forall (c: constant) t2 T11 T12,
  empty_context |- c \in (T11 ~> T12) ->
  empty_context |- t2 \in T11 ->
  tm_halt t2 ->
  tm_halt (app c t2) \/ exists t', step (app c t2) t'.
Proof.
  intros.
  destruct c.
  + (* int_const *)
    inversion H; subst.
    inversion H4.
  + (* bool_const *)
    inversion H; subst.
    inversion H4.
  + (* op_const *)
    destruct o;
    deduce_types_from_head H;
    deduce_int_bool_result H0 H1; subst t2.
    - left.
      apply H_base.
      constructor.
    - left.
      apply H_base.
      constructor.
    - left.
      apply H_base.
      constructor.
    - left.
      apply H_base.
      constructor.
    - left.
      apply H_base.
      constructor.
    - right.
      eexists.
      apply S_base.
      constructor.
    - left.
      apply H_base.
      constructor.
    - left.
      apply H_base.
      constructor.
Qed.

Lemma app_base_pending_halting_progress: forall t1 t2 T11 T12,
  empty_context |- t1 \in (T11 ~> T12) ->
  empty_context |- t2 \in T11 ->
  tm_base_pend t1 ->
  tm_halt t2 ->
  tm_halt (app t1 t2) \/ exists t', step (app t1 t2) t'.
Proof.
  intros.
  inversion H1; subst t1;
  deduce_types_from_head H;
  deduce_int_bool_result H0 H2; subst t2.
  + right.
    eexists.
    apply S_base.
    constructor.
  + right.
    eexists.
    apply S_base.
    constructor.
  + right.
    eexists.
    apply S_base.
    constructor.
  + right.
    destruct (Z.eq_dec n n0); eexists; apply S_base.
    - apply BS_eq_true; tauto.
    - apply BS_eq_false; tauto.
  + right.
    destruct (Z_le_gt_dec n n0); eexists; apply S_base.
    - apply BS_le_true; tauto.
    - apply BS_le_false; tauto.
  + right.
    eexists.
    apply S_base.
    constructor.
Qed.

Lemma app_pending_halting_progress: forall t1 t2 T11 T12,
  empty_context |- t1 \in (T11 ~> T12) ->
  empty_context |- t2 \in T11 ->
  tm_pend t1 ->
  tm_halt t2 ->
  tm_halt (app t1 t2) \/ exists t', step (app t1 t2) t'.
Proof.
  intros.
  inversion H1; subst t1.
  + right.
    eexists.
    apply S_beta, H2.
  + eapply app_const_halting_progress;
      [exact H | exact H0 | exact H2].
  + eapply app_base_pending_halting_progress;
      [exact H | exact H0 | exact H3 | exact H2].
Qed.

Theorem progress : forall t T,
  empty_context |- t \in T ->
  tm_halt t \/ exists t', step t t'.
Proof.
  intros t T Ht.
  remember empty_context as Gamma.
  induction Ht; subst Gamma.
  + (* T_var *)
    discriminate H.

  + (* T_abs *)
    left.
    apply H_abs.

  + (* T_app *)
    specialize (IHHt1 ltac:(reflexivity)).
    specialize (IHHt2 ltac:(reflexivity)).
    destruct IHHt1 as [| [t1' ?]].
    - (* evaluating t1 ends *)
      pose proof pend_or_not_pend _ H.
      destruct H0.
      * (* t2 needs to be evaluated *)
        destruct IHHt2 as [| [t2' ?]].
       ++ (* evaluating t2 also ends *)
          eapply app_pending_halting_progress;
            [exact Ht1 | exact Ht2 | exact H0 | exact H1].
       ++ (* t2 steps *)
          right; eexists.
          apply S_app2; [exact H0 |].
          apply H1.
      * (* t2 does not need to be evaluated *)
          eapply app_not_pending_progress;
            [exact Ht1 | exact Ht2 | exact H0].
    - (* t1 steps *)
      right; eexists.
      apply S_app1, H.

  + (* T_con *)
    left.
    apply H_con.
Qed.

Lemma base_preservation : forall t t' T,
  empty_context |- t \in T  ->
  base_step t t'  ->
  empty_context |- t' \in T.
Proof.
  intros.
  inversion H0; subst; deduce_types_from_head H; repeat constructor; tauto.
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 t,
      y <> x  ->
      appears_free_in x t ->
      appears_free_in x (abs y t).

Definition closed (t:tm) :=
  forall x, ~ appears_free_in x t.

Lemma free_in_context : forall x t T Gamma,
  appears_free_in x t ->
  Gamma |- t \in T ->
  exists T', Gamma x = Some T'.
Proof.
  intros.
  revert Gamma T H0; induction H; intros.
  + (* afi_var *)
    inversion H0; subst.
    exists T; tauto.
  + (* afi_app *)
    inversion H0; subst.
    eapply IHappears_free_in, H4.
  + (* afi_app *)
    inversion H0; subst.
    eapply IHappears_free_in, H6.
  + (* afi_abs *)
    inversion H1; subst.
    apply IHappears_free_in in H6.
    unfold context_update in H6.
    destruct (string_dec y x) in H6; [tauto |].
    exact H6.
Qed.

Corollary typable_empty__closed : forall t T,
    empty_context |- t \in T  ->
    closed t.
Proof.
  intros. unfold closed. intros ? ?.
  pose proof (free_in_context _ _ _ _ H0 H) as [?T ?].
  discriminate H1.
Qed.

Lemma context_invariance : forall Gamma Gamma' t T,
     Gamma |- t \in T  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     Gamma' |- t \in T.
Proof.
  intros.
  revert Gamma' H0; induction H; intros.
  + (* T_var *)
    apply T_var.
    rewrite <- H0.
    - exact H.
    - constructor.
  + (* T_abs *)
    apply T_abs.
    apply IHhas_type.
    intros x' Hafi.
    unfold context_update.
    destruct (string_dec x x'); [reflexivity |].
    apply H0.
    constructor; tauto.
  + (* T_App *)
    apply T_app with T11.
    - apply IHhas_type1.
      intros; apply H1.
      apply afi_app1, H2.
    - apply IHhas_type2.
      intros; apply H1.
      apply afi_app2, H2.
  + (* T_con *)
    apply T_con, H.
Qed.

Lemma substitution_preserves_typing : forall Gamma x U t v T,
  (x |-> U ; Gamma) |- t \in T ->
  empty_context |- v \in U   ->
  Gamma |- t [x |-> v] \in T.
Proof.
  intros.
  revert Gamma T H; induction t; intros; inversion H; subst.
  + (* var *)
    rename s into y.
    simpl; unfold context_update in H3.
    destruct (string_dec x y) as [Hxy | Hxy].
    - (* x=y *)
      injection H3 as ?.
      subst.
      eapply context_invariance; [apply H0 |].
      apply typable_empty__closed in H0. unfold closed in H0.
      intros.
      specialize (H0 x); tauto.
    - (* x<>y *)
      apply T_var. tauto.
  + (* app *)
    simpl.
    eapply T_app with T11.
    - apply IHt1; tauto.
    - apply IHt2; tauto.
  + (* abs *)
    rename s into y.
    simpl.
    apply T_abs.
    destruct (string_dec x y) as [Hxy | Hxy].
    - (* x=y *)
      subst.
      eapply context_invariance; [apply H5 |].
      intros.
      unfold context_update.
      destruct (string_dec y x); reflexivity.
    - (* x<>y *)
      apply IHt.
      eapply context_invariance; [apply H5 |].
      intros z ?.
      unfold context_update.
      destruct (string_dec y z).
      * (* y=z *)
        subst.
        destruct (string_dec x z); [tauto | reflexivity].
      * reflexivity.
  + simpl.
    apply T_con, H3.
Qed.

Theorem preservation : forall t t' T,
  empty_context |- t \in T  ->
  step t t'  ->
  empty_context |- t' \in T.
Proof.
  intros.
  revert T H; induction H0; intros.
  + eapply base_preservation; [exact H0 | exact H].
  + inversion H0; subst.
    inversion H4; subst.
    apply substitution_preserves_typing with T11; tauto.
  + inversion H; subst.
    apply T_app with T11.
    - apply IHstep, H4.
    - apply H6.
  + inversion H1; subst.
    apply T_app with T11.
    - apply H5.
    - apply IHstep, H7.
Qed.

End LambdaIB.

Module LambdaIBR.

Inductive op : Type :=
  | Oplus
  | Ominus
  | Omult
  | Oeq
  | Ole
  | Onot
  | Oand
  | Oifthenelse
  | Ounitele
  | Oread
  | Owrite
  | Oalloc
  .

Definition addr: Type := nat.

Inductive constant : Type :=
  | int_const (n: Z): constant
  | bool_const (b: bool): constant
  | op_const (o: op): constant
  | addr_const (p: addr): constant
.

Inductive tm : Type :=
  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> tm -> tm
  | con : constant -> tm.

Coercion var: string >-> tm.
Coercion op_const: op >-> constant.
Coercion bool_const: bool >-> constant.
Coercion int_const: Z >-> constant.
Coercion addr_const: addr >-> constant.
Coercion con: constant >-> tm.

Definition letx (x: string) (t1 t2: tm): tm :=
  app (abs x t2) t1.

Notation "'\let' x '\be' t1 '\in' t2" :=
  (letx x t1 t2) (at level 20).

Notation "t1 + t2" := (app (app Oplus t1) t2): tm_scope.
Notation "t1 - t2" := (app (app Ominus t1) t2): tm_scope.
Notation "t1 * t2" := (app (app Omult t1) t2): tm_scope.
Notation "t1 == t2" := (app (app Oeq t1) t2)
                         (at level 70, no associativity): tm_scope.
Delimit Scope tm_scope with tm.

Inductive tm_base_halt: tm -> Prop :=
  | BH_plus: forall n: Z, tm_base_halt (app Oplus n)
  | BH_minus: forall n: Z, tm_base_halt (app Ominus n)
  | BH_mult: forall n: Z, tm_base_halt (app Omult n)
  | BH_eq: forall n: Z, tm_base_halt (app Oeq n)
  | BH_le: forall n: Z, tm_base_halt (app Ole n)
  | BH_and: forall b: bool, tm_base_halt (app Oand b)
  | BH_if1: forall b: bool, tm_base_halt (app Oifthenelse b)
  | BH_if2: forall (b: bool) (t: tm), tm_base_halt (app (app Oifthenelse b) t)
  | BH_write: forall p: addr, tm_base_halt (app Owrite p)
.

Inductive tm_base_pend: tm -> Prop :=
  | BP_plus: forall n: Z, tm_base_pend (app Oplus n)
  | BP_minus: forall n: Z, tm_base_pend (app Ominus n)
  | BP_mult: forall n: Z, tm_base_pend (app Omult n)
  | BP_eq: forall n: Z, tm_base_pend (app Oeq n)
  | BP_le: forall n: Z, tm_base_pend (app Ole n)
  | BP_and_true: tm_base_pend (app Oand true)
  | BP_write: forall p, tm_base_pend (app Owrite p)
.

Inductive tm_halt: tm -> Prop :=
  | H_abs: forall x t, tm_halt (abs x t)
  | H_con: forall c, tm_halt (con c)
  | H_base: forall t, tm_base_halt t -> tm_halt t.

Inductive tm_pend: tm -> Prop :=
  | P_abs: forall x t, tm_pend (abs x t)
  | P_con: forall c, tm_pend (con c)
  | P_base: forall t, tm_base_pend t -> tm_pend t.

Definition state := list tm.

Fixpoint read_state (s: state) (p: addr): option tm :=
  match s, p with
  | t :: _, O => Some t
  | _ :: s', S p' => read_state s' p'
  | _, _ => None
  end.

Fixpoint write_state (s: state) (p: addr) (t: tm): option state :=
  match s, p with
  | _ :: s', O => Some (t :: s')
  | s0 :: s', S p' =>
      match write_state s' p' t with
      | Some s'' => Some (s0 :: s'')
      | None => None
      end
  | _, _ => None
  end.

Definition alloc_state (s: state) (t: tm): state := s ++ t :: nil.

Definition new_address (s: state): addr := length s.

Inductive base_step: tm * state -> tm * state -> Prop :=
  | BS_plus: forall (n1 n2: Z) (s: state),
      base_step (app (app Oplus n1) n2, s) (n1 + n2: tm, s)
  | BS_minus: forall (n1 n2: Z) (s: state),
      base_step (app (app Ominus n1) n2, s) (n1 - n2: tm, s)
  | BS_mult: forall (n1 n2: Z) (s: state),
      base_step (app (app Omult n1) n2, s) (n1 * n2: tm, s)
  | BS_eq_true: forall (n1 n2: Z) (s: state),
      n1 = n2 ->
      base_step (app (app Oeq n1) n2, s) (true: tm, s)
  | BS_eq_false: forall (n1 n2: Z) (s: state),
      n1 <> n2 ->
      base_step (app (app Oeq n1) n2, s) (false: tm, s)
  | BS_le_true: forall (n1 n2: Z) (s: state),
      n1 <= n2 ->
      base_step (app (app Ole n1) n2, s) (true: tm, s)
  | BS_le_false: forall (n1 n2: Z) (s: state),
      n1 > n2 ->
      base_step (app (app Ole n1) n2, s) (false: tm, s)
  | BS_not: forall (b: bool) (s: state),
      base_step (app Onot b, s) (negb b: tm, s)
  | BS_and_true: forall (b: bool) (s: state),
      base_step (app (app Oand true) b, s) (b: tm, s)
  | BS_and_false: forall (t: tm) (s: state),
      base_step (app (app Oand false) t, s) (false: tm, s)
  | BS_if_true: forall (t1 t2: tm) (s: state),
      base_step (app (app (app Oifthenelse true) t1) t2, s) (t1, s)
  | BS_if_false: forall (t1 t2: tm) (s: state),
      base_step (app (app (app Oifthenelse false) t1) t2, s) (t2, s)
  | BS_read: forall (p: addr) (s: state) (t: tm),
      read_state s p = Some t ->
      base_step (app Oread p, s) (t, s)
  | BS_write: forall (p: addr) (t: tm) (s s': state),
      tm_halt t ->
      write_state s p t = Some s' ->
      base_step (app (app Owrite p) t, s) (Ounitele: tm, s')
  | BS_alloc: forall (t: tm) (s: state),
      tm_halt t ->
      base_step (app Oalloc t, s) (new_address s: tm, alloc_state s t)
.

Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
  match t with
  | var x' =>
      if string_dec x x' then s else t
  | abs x' t1 =>
      abs x' (if string_dec x x' then t1 else subst x s t1)
  | app t1 t2 =>
      app (subst x s t1) (subst x s t2)
  | con c =>
      con c
  end.

Notation "t [ x |-> s ]" := (subst x s t) (at level 10, x at next level).

Inductive step: tm * state -> tm * state -> Prop :=
  | S_base: forall t1 t2 s1 s2,
      base_step (t1, s1) (t2, s2) ->
      step (t1, s1) (t2, s2)
  | S_beta: forall x t1 t2 s,
      tm_halt t2 ->
      step (app (abs x t1) t2, s) (t1 [ x |-> t2], s)
  | S_app1: forall t1 t1' t2 s s',
      step (t1, s) (t1', s') ->
      step (app t1 t2, s) (app t1' t2, s')
  | S_app2: forall t1 t2 t2' s s',
      tm_pend t1 ->
      step (t2, s) (t2', s') ->
      step (app t1 t2, s) (app t1 t2', s')
.

Definition is_base_halting (t: tm): bool :=
  match t with
  | app (con (op_const Oplus)) (con (int_const _)) => true
  | app (con (op_const Ominus)) (con (int_const _)) => true
  | app (con (op_const Omult)) (con (int_const _)) => true
  | app (con (op_const Oeq)) (con (int_const _)) => true
  | app (con (op_const Ole)) (con (int_const _)) => true
  | app (con (op_const Oand)) (con (bool_const _)) => true
  | app (con (op_const Oifthenelse)) (con (bool_const _)) => true
  | app
      (app (con (op_const Oifthenelse)) (con (bool_const _)))
      (con (int_const _)) => true
  | app (con (op_const Owrite)) (con (addr_const _)) => true
  | _ => false
  end.

Definition is_base_pending (t: tm): bool :=
  match t with
  | app (con (op_const Oplus)) (con (int_const _)) => true
  | app (con (op_const Ominus)) (con (int_const _)) => true
  | app (con (op_const Omult)) (con (int_const _)) => true
  | app (con (op_const Oeq)) (con (int_const _)) => true
  | app (con (op_const Ole)) (con (int_const _)) => true
  | app (con (op_const Oand)) (con (bool_const true)) => true
  | app (con (op_const Owrite)) (con (addr_const _)) => true
  | _ => false
  end.

Definition is_halting (t: tm): bool :=
  match t with
  | abs _ _ => true
  | con _ => true
  | _ => is_base_halting t
  end.

Definition is_pending (t: tm): bool :=
  match t with
  | abs _ _ => true
  | con _ => true
  | _ => is_base_pending t
  end.

Definition base_next_state (t_s: tm * state): option (tm * state) :=
  let (t, s) := t_s in
  match t with
  | app (app Oplus (con (int_const n1))) (con (int_const n2)) =>
      Some (con (int_const (n1 + n2)), s)
  | app (app Ominus (con (int_const n1))) (con (int_const n2)) =>
      Some (con (int_const (n1 - n2)), s)
  | app (app Omult (con (int_const n1))) (con (int_const n2)) =>
      Some (con (int_const (n1 * n2)), s)
  | app (app Oeq (con (int_const n1))) (con (int_const n2)) =>
      if Z.eq_dec n1 n2
      then Some (con (bool_const true), s)
      else Some (con (bool_const false), s)
  | app (app Ole (con (int_const n1))) (con (int_const n2)) =>
      if Z_le_gt_dec n1 n2
      then Some (con (bool_const true), s)
      else Some (con (bool_const false), s)
  | app Onot (con (bool_const b)) =>
      Some (con (bool_const (negb b)), s)
  | app (app Oand (con (bool_const true))) (con (bool_const b)) =>
      Some (con (bool_const b), s)
  | app (app Oand (con (bool_const false))) _ =>
      Some (con (bool_const false), s)
  | app (app (app Oifthenelse (con (bool_const true))) t1) _ =>
      Some (t1, s)
  | app (app (app Oifthenelse (con (bool_const false))) _) t2 =>
      Some (t2, s)
  | app Oread (con (addr_const p)) =>
      match read_state s p with
      | Some t' => Some (t', s)
      | None => None
      end
  | app (app Owrite (con (addr_const p))) t0 =>
      if is_halting t0
      then
        match write_state s p t0 with
        | Some s' => Some (con (op_const Ounitele), s')
        | None => None
        end
      else
        None
  | app Oalloc t0 =>
      if is_halting t0
      then Some (con (addr_const (new_address s)), alloc_state s t0)
      else None
  | _ => None
  end.

Definition beta_next_state (t: tm): option tm :=
  match t with
  | app (abs x t1) t2 => Some (t1 [x |-> t2])
  | _ => None
  end.

Definition core_next_state (t_s: tm * state): option (tm * state) :=
  let (t, s) := t_s in
  match beta_next_state t, base_next_state (t, s) with
  | Some t', _ => Some (t', s)
  | _, Some t_s' => Some t_s'
  | _, _ => None
  end.

Fixpoint next_state_rec (t: tm) (s: state): option (tm * state) :=
  match t with
  | app t1 t2 =>
      match next_state_rec t1 s with
      | Some (t1', s') => Some (app t1' t2, s')
      | None => if is_pending t1
                then match next_state_rec t2 s with
                     | Some (t2', s') => Some (app t1 t2', s')
                     | None => if is_halting t2
                               then core_next_state (t, s)
                               else None
                     end
                else base_next_state (t, s)
      end
  | _ => None
  end.

Definition next_state (t_s: tm * state): option (tm * state) :=
  let (t, s) := t_s in
  next_state_rec t s.

Ltac destruct_eqn t :=
  first
    [ is_var t; destruct t
    | match type of t with sumbool _ _ => destruct t end
    | destruct t eqn:?H ].

Ltac case_analysis_and_discriminiate H :=
  match type of H with
  | match ?t with _ => _ end = _ =>
      destruct_eqn t;
      match type of H with
      | false = true => discriminate H
      | None = Some _ => discriminate H
      | Some _ = Some _ => injection H as H
      | _ => idtac
      end
  end.

Lemma is_base_halting_sound: forall t,
  is_base_halting t = true ->
  tm_base_halt t.
Proof.
  intros.
  unfold is_base_halting in H.
  repeat case_analysis_and_discriminiate H; constructor.
Qed.

Lemma is_base_pending_sound: forall t,
  is_base_pending t = true ->
  tm_base_pend t.
Proof.
  intros.
  unfold is_base_pending in H.
  repeat case_analysis_and_discriminiate H; constructor.
Qed.

Lemma is_halting_sound: forall t,
  is_halting t = true ->
  tm_halt t.
Proof.
  intros.
  unfold is_halting in H.
  repeat case_analysis_and_discriminiate H; try constructor.
  + apply is_base_halting_sound in H; auto.
  + apply is_base_halting_sound in H; auto.
Qed.

Lemma is_pending_sound: forall t,
  is_pending t = true ->
  tm_pend t.
Proof.
  intros.
  unfold is_pending in H.
  repeat case_analysis_and_discriminiate H; try constructor.
  + apply is_base_pending_sound in H; auto.
  + apply is_base_pending_sound in H; auto.
Qed.

Lemma base_next_state_sound: forall t_s t_s',
  base_next_state t_s = Some t_s' ->
  base_step t_s t_s'.
Proof.
  intros.
  destruct t_s as [t s], t_s' as [t' s'].
  unfold base_next_state in H.
  repeat case_analysis_and_discriminiate H; try (subst; constructor; try tauto).
  + apply is_halting_sound, H0.
  + apply is_halting_sound, H0.
Qed.

Lemma beta_next_state_sound: forall t1 t2 t' s,
  tm_halt t2 ->
  beta_next_state (app t1 t2) = Some t' ->
  step (app t1 t2, s) (t', s).
Proof.
  intros.
  unfold beta_next_state in H0.
  repeat case_analysis_and_discriminiate H0.
  subst.
  apply S_beta, H.
Qed.

Lemma core_next_state_sound: forall t1 t2 t' s s',
  tm_halt t2 ->
  core_next_state (app t1 t2, s) = Some (t', s') ->
  step (app t1 t2, s) (t', s').
Proof.
  intros.
  unfold core_next_state in H0.
  destruct (beta_next_state (app t1 t2)) eqn:?H.
  + injection H0 as H0 H2; subst t' s'.
    apply beta_next_state_sound; tauto.
  + destruct (base_next_state (app t1 t2, s)) eqn:?H; [| discriminate H0].
    injection H0 as H0; subst p.
    apply base_next_state_sound in H2.
    apply S_base; tauto.
Qed.

Arguments base_next_state: simpl never.
Arguments beta_next_state: simpl never.
Arguments core_next_state: simpl never.

Lemma next_state_sound: forall t_s t_s',
  next_state t_s = Some t_s' ->
  step t_s t_s'.
Proof.
  intros.
  destruct t_s as [t s], t_s' as [t' s'].
  simpl in H.
  revert t' s' H; induction t; intros; simpl in H;
    [discriminate H | | discriminate H | discriminate H].
  destruct (next_state_rec t1 s) as [[? ?] |] eqn:?H in H.
  {
    apply IHt1 in H0.
    injection H as H; subst t' s'.
    apply S_app1, H0.
  }
  destruct (is_pending t1) eqn:?H in H.
  2: {
    apply base_next_state_sound in H.
    apply S_base, H.
  }
  apply is_pending_sound in H1.
  destruct (next_state_rec t2 s) as [[? ?] |] eqn:?H in H.
  {
    apply IHt2 in H2.
    injection H as H; subst t' s'.
    apply S_app2; tauto.
  }
  destruct (is_halting t2) eqn:?H in H.
  {
    apply is_halting_sound in H3.
    apply core_next_state_sound; tauto.
  }
  {
    discriminate H.
  }
Qed.

Inductive ty : Type :=
  | TBool : ty
  | TInt : ty
  | TArrow : ty -> ty -> ty
  | TUnit : ty
  | TRef : ty -> ty.

Notation "T1 ~> T2" := (TArrow T1 T2) (right associativity, at level 30).

Definition context := string -> option ty.

Definition empty_context: context := fun _ => None.

Definition context_update (Gamma : context) (x : string) (T : ty) :=
  fun x' => if string_dec x x' then Some T else Gamma x'.

Notation "x '|->' T ';' Gamma" := (context_update Gamma x T)
  (at level 100, T at next level, right associativity).

Definition state_ty := list ty.

Fixpoint addr_ty (ST: state_ty) (p: addr): option ty :=
  match ST, p with
  | T :: _, O => Some T
  | _ :: ST', S p' => addr_ty ST' p'
  | _, _ => None
  end.

Inductive op_type: op -> ty -> Prop :=
  | OT_plus: op_type Oplus (TInt ~> TInt ~> TInt)
  | OT_minus: op_type Ominus (TInt ~> TInt ~> TInt)
  | OT_mult: op_type Omult (TInt ~> TInt ~> TInt)
  | OT_eq: op_type Oeq (TInt ~> TInt ~> TBool)
  | OT_le: op_type Ole (TInt ~> TInt ~> TBool)
  | OT_not: op_type Onot (TBool ~> TBool)
  | OT_and: op_type Oand (TBool ~> TBool ~> TBool)
  | OT_if: forall T, op_type Oifthenelse (TBool ~> T ~> T ~> T)
  | OT_read: forall T, op_type Oread (TRef T ~> T)
  | OT_write: forall T, op_type Owrite (TRef T ~> T ~> TUnit)
  | OT_alloc: forall T, op_type Oalloc (T ~> TRef T)
.

Inductive const_type: state_ty -> constant -> ty -> Prop :=
  | CT_int: forall n ST, const_type ST (int_const n) TInt
  | CT_bool: forall b ST, const_type ST (bool_const b) TBool
  | CT_op: forall o ST T, op_type o T -> const_type ST (op_const o) T
  | CT_addr: forall p ST T,
      addr_ty ST p = Some T -> const_type ST (addr_const p) T
.

Inductive has_type: context -> state_ty -> tm -> ty -> Prop :=
  | T_var : forall Gamma ST x T,
      Gamma x = Some T ->
      has_type Gamma ST (var x) T
  | T_abs : forall Gamma ST x T11 T12 t12,
      has_type (x |-> T11 ; Gamma) ST t12 T12 ->
      has_type Gamma ST (abs x t12) (T11 ~> T12)
  | T_app : forall T11 T12 Gamma ST t1 t2,
      has_type Gamma ST t1 (T11 ~> T12) ->
      has_type Gamma ST t2 T11 ->
      has_type Gamma ST (app t1 t2) T12
  | T_con : forall T Gamma ST c,
      const_type ST c T ->
      has_type Gamma ST (con c) T
.

Notation "Gamma ';' ST '|-' t '\in' T" := (has_type Gamma ST t T) (at level 40).

End LambdaIBR.

(* 2021-05-12 08:49 *)